conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

492
extlib/benz/boot.c
View File

@ -109,7 +109,7 @@ my $src = <<'EOL';
(list the-define (list the-define
(car (cadr form)) (car (cadr form))
(cons the-lambda (cons (cdr (cadr form)) (cddr 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)))) (length form))))
(builtin:define-macro define-macro (builtin:define-macro define-macro
@ -117,7 +117,7 @@ my $src = <<'EOL';
(if (= (length form) 3) (if (= (length form) 3)
(if (variable? (cadr form)) (if (variable? (cadr form))
(cons the-builtin-define-macro (cdr 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)))) (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 ", "n-define (cdr form))\n (error \"illegal define form\" form))\n ",
" (if (pair? (cadr form))\n (list the-define\n ", " (if (pair? (cadr form))\n (list the-define\n ",
" (car (cadr form))\n (cons the-lambda (con", " (car (cadr form))\n (cons the-lambda (con",
"s (cdr (cadr form)) (cddr form))))\n (error \"illegal define for", "s (cdr (cadr form)) (cddr form))))\n (error \"define: binding to",
"m\" form)))))\n (length form))))\n\n(builtin:define-macro define-macro\n (lambda", " non-varaible object\" form)))))\n (length form))))\n\n(builtin:define-macro def",
" (form env)\n (if (= (length form) 3)\n (if (variable? (cadr form))\n ", "ine-macro\n (lambda (form env)\n (if (= (length form) 3)\n (if (variable",
" (cons the-builtin-define-macro (cdr form))\n (error \"illegal d", "? (cadr form))\n (cons the-builtin-define-macro (cdr form))\n ",
"efine-macro form\" form))\n (error \"illegal define-macro form\" form))))\n\n\n(", " (error \"define-macro: binding to non-variable object\" form))\n (error \"i",
"define-macro syntax-error\n (lambda (form _)\n (apply error (cdr form))))\n\n(de", "llegal define-macro form\" form))))\n\n\n(define-macro syntax-error\n (lambda (form ",
"fine-macro define-auxiliary-syntax\n (lambda (form _)\n (define message\n ", "_)\n (apply error (cdr form))))\n\n(define-macro define-auxiliary-syntax\n (lamb",
"(string-append\n \"invalid use of auxiliary syntax: '\" (symbol->string (cadr", "da (form _)\n (define message\n (string-append\n \"invalid use of auxi",
" form)) \"'\"))\n (list\n the-define-macro\n (cadr form)\n (list the-la", "liary syntax: '\" (symbol->string (cadr form)) \"'\"))\n (list\n the-define-ma",
"mbda '_\n (list (the 'error) message)))))\n\n(define-auxiliary-syntax els", "cro\n (cadr form)\n (list the-lambda '_\n (list (the 'error) mess",
"e)\n(define-auxiliary-syntax =>)\n(define-auxiliary-syntax unquote)\n(define-auxili", "age)))))\n\n(define-auxiliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-au",
"ary-syntax unquote-splicing)\n(define-auxiliary-syntax syntax-unquote)\n(define-au", "xiliary-syntax unquote)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxil",
"xiliary-syntax syntax-unquote-splicing)\n\n(define-macro let\n (lambda (form env)\n", "iary-syntax syntax-unquote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(",
" (if (variable? (cadr form))\n (list\n (list the-lambda '()\n ", "define-macro let\n (lambda (form env)\n (if (variable? (cadr form))\n (l",
" (list the-define (cadr form)\n (cons the-lambda\n ", "ist\n (list the-lambda '()\n (list the-define (cadr form)\n ",
" (cons (map car (car (cddr form)))\n ", " (cons the-lambda\n (cons (map car (c",
" (cdr (cddr form)))))\n (cons (cadr form) (map cadr (car", "ar (cddr form)))\n (cdr (cddr form)))))\n ",
" (cddr form))))))\n (cons\n (cons\n the-lambda\n (c", " (cons (cadr form) (map cadr (car (cddr form))))))\n (cons\n (",
"ons (map car (cadr form))\n (cddr form)))\n (map cadr (cadr", "cons\n the-lambda\n (cons (map car (cadr form))\n ",
" form))))))\n\n(define-macro and\n (lambda (form env)\n (if (null? (cdr form))\n ", "(cddr form)))\n (map cadr (cadr form))))))\n\n(define-macro and\n (lambda (",
" #t\n (if (null? (cddr form))\n (cadr form)\n (l", "form env)\n (if (null? (cdr form))\n #t\n (if (null? (cddr form))\n",
"ist the-if\n (cadr form)\n (cons (the 'and) (cdd", " (cadr form)\n (list the-if\n (cadr form)\n ",
"r form))\n #f)))))\n\n(define-macro or\n (lambda (form env)\n (i", " (cons (the 'and) (cddr form))\n #f)))))\n\n(defin",
"f (null? (cdr form))\n #f\n (let ((tmp (make-identifier 'it env)))\n ", "e-macro or\n (lambda (form env)\n (if (null? (cdr form))\n #f\n (l",
" (list (the 'let)\n (list (list tmp (cadr form)))\n ", "et ((tmp (make-identifier 'it env)))\n (list (the 'let)\n ",
" (list the-if\n tmp\n tmp\n ", "(list (list tmp (cadr form)))\n (list the-if\n ",
" (cons (the 'or) (cddr form))))))))\n\n(define-macro cond\n (lambda ", " tmp\n tmp\n (cons (the 'or) (cddr form)",
"(form env)\n (let ((clauses (cdr form)))\n (if (null? clauses)\n #", ")))))))\n\n(define-macro cond\n (lambda (form env)\n (let ((clauses (cdr form)))",
"undefined\n (let ((clause (car clauses)))\n (if (and (variable", "\n (if (null? clauses)\n #undefined\n (let ((clause (car cla",
"? (car clause))\n (variable=? (the 'else) (make-identifier (c", "uses)))\n (if (and (variable? (car clause))\n (vari",
"ar clause) env)))\n (cons the-begin (cdr clause))\n ", "able=? (the 'else) (make-identifier (car clause) env)))\n (cons th",
"(if (and (variable? (cadr clause))\n (variable=? (the '=>", "e-begin (cdr clause))\n (if (and (variable? (cadr clause))\n ",
") (make-identifier (cadr clause) env)))\n (let ((tmp (make-ide", " (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ",
"ntifier 'tmp here)))\n (list (the 'let) (list (list tmp (car", " (let ((tmp (make-identifier 'tmp here)))\n ",
" clause)))\n (list the-if tmp\n ", " (list (the 'let) (list (list tmp (car clause)))\n (li",
" (list (car (cddr clause)) tmp)\n (cons", "st the-if tmp\n (list (car (cddr clause)) tmp)\n ",
" (the 'cond) (cdr clauses)))))\n (list the-if (car clause)\n ", " (cons (the 'cond) (cdr clauses)))))\n ",
" (cons the-begin (cdr clause))\n (", " (list the-if (car clause)\n (cons the-begin (cd",
"cons (the 'cond) (cdr clauses))))))))))\n\n(define-macro quasiquote\n (lambda (for", "r clause))\n (cons (the 'cond) (cdr clauses))))))))))\n\n(",
"m env)\n\n (define (quasiquote? form)\n (and (pair? form)\n (varia", "define-macro quasiquote\n (lambda (form env)\n\n (define (quasiquote? form)\n ",
"ble? (car form))\n (variable=? (the 'quasiquote) (make-identifier (car ", " (and (pair? form)\n (variable? (car form))\n (variable=? (t",
"form) env))))\n\n (define (unquote? form)\n (and (pair? form)\n (v", "he 'quasiquote) (make-identifier (car form) env))))\n\n (define (unquote? form)",
"ariable? (car form))\n (variable=? (the 'unquote) (make-identifier (car", "\n (and (pair? form)\n (variable? (car form))\n (variable=",
" form) env))))\n\n (define (unquote-splicing? form)\n (and (pair? form)\n ", "? (the 'unquote) (make-identifier (car form) env))))\n\n (define (unquote-splic",
" (pair? (car form))\n (variable? (caar form))\n (variab", "ing? form)\n (and (pair? form)\n (pair? (car form))\n (var",
"le=? (the 'unquote-splicing) (make-identifier (caar form) env))))\n\n (define (", "iable? (caar form))\n (variable=? (the 'unquote-splicing) (make-identif",
"qq depth expr)\n (cond\n ;; unquote\n ((unquote? expr)\n (if", "ier (caar form) env))))\n\n (define (qq depth expr)\n (cond\n ;; unquo",
" (= depth 1)\n (car (cdr expr))\n (list (the 'list)\n ", "te\n ((unquote? expr)\n (if (= depth 1)\n (car (cdr expr))\n",
" (list (the 'quote) (the 'unquote))\n (qq (- depth 1) (", " (list (the 'list)\n (list (the 'quote) (the 'unquote",
"car (cdr expr))))))\n ;; unquote-splicing\n ((unquote-splicing? expr)\n", "))\n (qq (- depth 1) (car (cdr expr))))))\n ;; unquote-spli",
" (if (= depth 1)\n (list (the 'append)\n (car (", "cing\n ((unquote-splicing? expr)\n (if (= depth 1)\n (list ",
"cdr (car expr)))\n (qq depth (cdr expr)))\n (list (the", "(the 'append)\n (car (cdr (car expr)))\n (qq dep",
" 'cons)\n (list (the 'list)\n (list (the '", "th (cdr expr)))\n (list (the 'cons)\n (list (the 'list",
"quote) (the 'unquote-splicing))\n (qq (- depth 1) (car (cd", ")\n (list (the 'quote) (the 'unquote-splicing))\n ",
"r (car expr)))))\n (qq depth (cdr expr)))))\n ;; quasiquote", " (qq (- depth 1) (car (cdr (car expr)))))\n (qq dep",
"\n ((quasiquote? expr)\n (list (the 'list)\n (list (the '", "th (cdr expr)))))\n ;; quasiquote\n ((quasiquote? expr)\n (list ",
"quote) (the 'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))))\n ", "(the 'list)\n (list (the 'quote) (the 'quasiquote))\n (q",
" ;; list\n ((pair? expr)\n (list (the 'cons)\n (qq dept", "q (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n (l",
"h (car expr))\n (qq depth (cdr expr))))\n ;; vector\n ((ve", "ist (the 'cons)\n (qq depth (car expr))\n (qq depth (cdr",
"ctor? expr)\n (list (the 'list->vector) (qq depth (vector->list expr))))\n ", " expr))))\n ;; vector\n ((vector? expr)\n (list (the 'list->vect",
" ;; simple datum\n (else\n (list (the 'quote) expr))))\n\n (let", "or) (qq depth (vector->list expr))))\n ;; simple datum\n (else\n ",
" ((x (cadr form)))\n (qq 1 x))))\n\n(define-macro let*\n (lambda (form env)\n ", " (list (the 'quote) expr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(def",
" (let ((bindings (car (cdr form)))\n (body (cdr (cdr form))))\n ", "ine-macro let*\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n ",
" (if (null? bindings)\n `(,(the 'let) () ,@body)\n `(,(the 'let)", " (body (cdr (cdr form))))\n (if (null? bindings)\n `(,(the 'l",
" ((,(car (car bindings)) ,@(cdr (car bindings))))\n (,(the 'let*) (,@(", "et) () ,@body)\n `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindi",
"cdr bindings))\n ,@body))))))\n\n(define-macro letrec\n (lambda (form e", "ngs))))\n (,(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n",
"nv)\n `(,(the 'letrec*) ,@(cdr form))))\n\n(define-macro letrec*\n (lambda (form", "(define-macro letrec\n (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n",
" env)\n (let ((bindings (car (cdr form)))\n (body (cdr (cdr form))", "\n(define-macro letrec*\n (lambda (form env)\n (let ((bindings (car (cdr form))",
"))\n (let ((variables (map (lambda (v) `(,v #f)) (map car bindings)))\n ", ")\n (body (cdr (cdr form))))\n (let ((variables (map (lambda (v)",
" (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings)))\n `(,(t", " `(,v #f)) (map car bindings)))\n (initials (map (lambda (v) `(,(the ",
"he 'let) (,@variables)\n ,@initials\n ,@body)))))\n\n(define-macro", "'set!) ,@v)) bindings)))\n `(,(the 'let) (,@variables)\n ,@initial",
" let-values\n (lambda (form env)\n `(,(the 'let*-values) ,@(cdr form))))\n\n(def", "s\n ,@body)))))\n\n(define-macro let-values\n (lambda (form env)\n `(,(t",
"ine-macro let*-values\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", "he 'let*-values) ,@(cdr form))))\n\n(define-macro let*-values\n (lambda (form env)",
" (body (cdr (cdr form))))\n (if (null? formal)\n `(,(the '", "\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n ",
"let) () ,@body)\n `(,(the 'call-with-values) (,the-lambda () ,@(cdr (car", "(if (null? formal)\n `(,(the 'let) () ,@body)\n `(,(the 'call-wi",
" formal)))\n (,(the 'lambda) (,@(car (car formal)))\n (,(th", "th-values) (,the-lambda () ,@(cdr (car formal)))\n (,(the 'lambda) (,@",
"e 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n(define-macro defi", "(car (car formal)))\n (,(the 'let*-values) (,@(cdr formal))\n ",
"ne-values\n (lambda (form env)\n (let ((formal (car (cdr form)))\n (bo", " ,@body)))))))\n\n(define-macro define-values\n (lambda (form env)\n (let ((",
"dy (cdr (cdr form))))\n (let ((arguments (make-identifier 'arguments here)", "formal (car (cdr form)))\n (body (cdr (cdr form))))\n (let ((argum",
"))\n `(,the-begin\n ,@(let loop ((formal formal))\n (i", "ents (make-identifier 'arguments here)))\n `(,the-begin\n ,@(let l",
"f (pair? formal)\n `((,the-define ,(car formal) #undefined) ,@(l", "oop ((formal formal))\n (if (pair? formal)\n `((,the",
"oop (cdr formal)))\n (if (variable? formal)\n ", "-define ,(car formal) #undefined) ,@(loop (cdr formal)))\n (if (",
" `((,the-define ,formal #undefined))\n '())))\n (,(", "variable? formal)\n `((,the-define ,formal #undefined))\n ",
"the 'call-with-values) (,the-lambda () ,@body)\n (,the-lambda\n ", " '())))\n (,(the 'call-with-values) (,the-lambda () ,@b",
" ,arguments\n ,@(let loop ((formal formal) (args arguments))\n ", "ody)\n (,the-lambda\n ,arguments\n ,@(let loop ((fo",
" (if (pair? formal)\n `((,the-set! ,(car formal) (,(th", "rmal formal) (args arguments))\n (if (pair? formal)\n ",
"e 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))\n ", " `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(t",
"(if (variable? formal)\n `((,the-set! ,formal ,args))\n ", "he 'cdr) ,args)))\n (if (variable? formal)\n ",
" '()))))))))))\n\n(define-macro do\n (lambda (form env)\n (le", " `((,the-set! ,formal ,args))\n '()))))))))))\n\n(define",
"t ((bindings (car (cdr form)))\n (test (car (car (cdr (cdr form)))))", "-macro do\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (",
"\n (cleanup (cdr (car (cdr (cdr form)))))\n (body (cdr (cdr", "test (car (car (cdr (cdr form)))))\n (cleanup (cdr (car (cdr (cdr f",
" (cdr form)))))\n (let ((loop (make-identifier 'loop here)))\n `(,(the", "orm)))))\n (body (cdr (cdr (cdr form)))))\n (let ((loop (make-id",
" 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings)\n (,the-", "entifier 'loop here)))\n `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ",
"if ,test\n (,the-begin\n ,@cleanup)\n ", ",(cadr x))) bindings)\n (,the-if ,test\n (,the-begin\n ",
" (,the-begin\n ,@body\n (,loop ,@(m", " ,@cleanup)\n (,the-begin\n ",
"ap (lambda (x) (if (null? (cdr (cdr x))) (car x) (car (cdr (cdr x))))) bindings)", ",@body\n (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (",
"))))))))\n\n(define-macro when\n (lambda (form env)\n (let ((test (car (cdr form", "car x) (car (cdr (cdr x))))) bindings)))))))))\n\n(define-macro when\n (lambda (fo",
")))\n (body (cdr (cdr form))))\n `(,the-if ,test\n (,t", "rm env)\n (let ((test (car (cdr form)))\n (body (cdr (cdr form))))\n ",
"he-begin ,@body)\n #undefined))))\n\n(define-macro unless\n (lambda ", " `(,the-if ,test\n (,the-begin ,@body)\n #undefine",
"(form env)\n (let ((test (car (cdr form)))\n (body (cdr (cdr form))))\n", "d))))\n\n(define-macro unless\n (lambda (form env)\n (let ((test (car (cdr form)",
" `(,the-if ,test\n #undefined\n (,the-begin ,@b", "))\n (body (cdr (cdr form))))\n `(,the-if ,test\n #und",
"ody)))))\n\n(define-macro case\n (lambda (form env)\n (let ((key (car (cdr f", "efined\n (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (fo",
"orm)))\n (clauses (cdr (cdr form))))\n (let ((the-key (make-identifi", "rm env)\n (let ((key (car (cdr form)))\n (clauses (cdr (cdr form))",
"er 'key here)))\n `(,(the 'let) ((,the-key ,key))\n ,(let loop ((c", "))\n (let ((the-key (make-identifier 'key here)))\n `(,(the 'let) ((,t",
"lauses clauses))\n (if (null? clauses)\n #undefined\n ", "he-key ,key))\n ,(let loop ((clauses clauses))\n (if (null? c",
" (let ((clause (car clauses)))\n `(,the-if ,(if (", "lauses)\n #undefined\n (let ((clause (car clauses)",
"and (variable? (car clause))\n (variable=? ", "))\n `(,the-if ,(if (and (variable? (car clause))\n ",
"(the 'else) (make-identifier (car clause) env)))\n ", " (variable=? (the 'else) (make-identifier (car clause) ",
" #t\n `(,(the 'or) ,@(map (lambda (x) `(,(the ", "env)))\n #t\n `(",
"'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ,", ",(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car cla",
"(if (and (variable? (cadr clause))\n (varia", "use))))\n ,(if (and (variable? (cadr clause))\n ",
"ble=? (the '=>) (make-identifier (cadr clause) env)))\n ", " (variable=? (the '=>) (make-identifier (cadr cla",
" `(,(car (cdr (cdr clause))) ,the-key)\n ", "use) env)))\n `(,(car (cdr (cdr clause))) ,the-k",
"`(,the-begin ,@(cdr clause)))\n ,(loop (cdr clauses))", "ey)\n `(,the-begin ,@(cdr clause)))\n ",
")))))))))\n\n(define-macro parameterize\n (lambda (form env)\n (let ((formal (ca", " ,(loop (cdr clauses)))))))))))\n\n(define-macro parameterize\n (l",
"r (cdr form)))\n (body (cdr (cdr form))))\n `(,(the 'with-paramete", "ambda (form env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr",
"r)\n (,(the 'lambda) ()\n ,@formal\n ,@body)))))\n\n(define-ma", " form))))\n `(,(the 'with-parameter)\n (,(the 'lambda) ()\n ,@f",
"cro syntax-quote\n (lambda (form env)\n (let ((renames '()))\n (letrec\n ", "ormal\n ,@body)))))\n\n(define-macro syntax-quote\n (lambda (form env)\n ",
" ((rename (lambda (var)\n (let ((x (assq var renames)))", "(let ((renames '()))\n (letrec\n ((rename (lambda (var)\n ",
"\n (if x\n (cadr x)\n ", " (let ((x (assq var renames)))\n (if x\n ",
" (begin\n (set! renames `((,var ,(make-id", " (cadr x)\n (begin\n ",
"entifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ", " (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier)",
" (rename var))))))\n (walk (lambda (f form)\n ", " ',var ',env)) . ,renames))\n (rename var))))))\n ",
" (cond\n ((variable? form)\n (f fo", " (walk (lambda (f form)\n (cond\n ((vari",
"rm))\n ((pair? form)\n `(,(the 'cons) (walk", "able? form)\n (f form))\n ((pair? form)\n ",
" f (car form)) (walk f (cdr form))))\n ((vector? form)\n ", " `(,(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ",
" `(,(the 'list->vector) (walk f (vector->list form))))\n ", " ((vector? form)\n `(,(the 'list->vector) (walk",
" (else\n `(,(the 'quote) ,form))))))\n (let ((fo", " f (vector->list form))))\n (else\n `(,(the",
"rm (walk rename (cadr form))))\n `(,(the 'let)\n ,(map cdr ren", " 'quote) ,form))))))\n (let ((form (walk rename (cadr form))))\n `",
"ames)\n ,form))))))\n\n(define-macro syntax-quasiquote\n (lambda (form e", "(,(the 'let)\n ,(map cdr renames)\n ,form))))))\n\n(define-mac",
"nv)\n (let ((renames '()))\n (letrec\n ((rename (lambda (var)\n ", "ro syntax-quasiquote\n (lambda (form env)\n (let ((renames '()))\n (letrec",
" (let ((x (assq var renames)))\n (if x\n ", "\n ((rename (lambda (var)\n (let ((x (assq var rename",
" (cadr x)\n (begin\n ", "s)))\n (if x\n (cadr x)\n ",
" (set! renames `((,var ,(make-identifier var env) (,(the 'make-ide", " (begin\n (set! renames `((,var ,(mak",
"ntifier) ',var ',env)) . ,renames))\n (rename var))))", "e-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ",
")))\n\n (define (syntax-quasiquote? form)\n (and (pair? form)\n ", " (rename var)))))))\n\n (define (syntax-quasiquote? f",
" (variable? (car form))\n (variable=? (the 'syntax-quasiqu", "orm)\n (and (pair? form)\n (variable? (car form))\n ",
"ote) (make-identifier (car form) env))))\n\n (define (syntax-unquote? form)", " (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env))))\n\n",
"\n (and (pair? form)\n (variable? (car form))\n ", " (define (syntax-unquote? form)\n (and (pair? form)\n ",
" (variable=? (the 'syntax-unquote) (make-identifier (car form) env))))\n\n ", " (variable? (car form))\n (variable=? (the 'syntax-unquote) (make-",
" (define (syntax-unquote-splicing? form)\n (and (pair? form)\n ", "identifier (car form) env))))\n\n (define (syntax-unquote-splicing? form)\n ",
" (pair? (car form))\n (variable? (caar form))\n (va", " (and (pair? form)\n (pair? (car form))\n (var",
"riable=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env))))\n\n ", "iable? (caar form))\n (variable=? (the 'syntax-unquote-splicing) (m",
" (define (qq depth expr)\n (cond\n ;; syntax-unquote\n ", "ake-identifier (caar form) env))))\n\n (define (qq depth expr)\n (c",
" ((syntax-unquote? expr)\n (if (= depth 1)\n (car (", "ond\n ;; syntax-unquote\n ((syntax-unquote? expr)\n ",
"cdr expr))\n (list (the 'list)\n (list (the 'q", "(if (= depth 1)\n (car (cdr expr))\n (list (the 'lis",
"uote) (the 'syntax-unquote))\n (qq (- depth 1) (car (cdr exp", "t)\n (list (the 'quote) (the 'syntax-unquote))\n ",
"r))))))\n ;; syntax-unquote-splicing\n ((syntax-unquote-splici", " (qq (- depth 1) (car (cdr expr))))))\n ;; syntax-unquote-splic",
"ng? expr)\n (if (= depth 1)\n (list (the 'append)\n ", "ing\n ((syntax-unquote-splicing? expr)\n (if (= depth 1)\n ",
" (car (cdr (car expr)))\n (qq depth (cdr expr", " (list (the 'append)\n (car (cdr (car expr)))\n ",
")))\n (list (the 'cons)\n (list (the 'list)\n ", " (qq depth (cdr expr)))\n (list (the 'cons)\n ",
" (list (the 'quote) (the 'syntax-unquote-splicing))\n ", " (list (the 'list)\n (list (the 'quot",
" (qq (- depth 1) (car (cdr (car expr)))))\n ", "e) (the 'syntax-unquote-splicing))\n (qq (- depth 1) (",
" (qq depth (cdr expr)))))\n ;; syntax-quasiquote\n ((sy", "car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ",
"ntax-quasiquote? expr)\n (list (the 'list)\n (list (th", " ;; syntax-quasiquote\n ((syntax-quasiquote? expr)\n (list (",
"e 'quote) (the 'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))", "the 'list)\n (list (the 'quote) (the 'quasiquote))\n ",
"))\n ;; list\n ((pair? expr)\n (list (the 'cons)\n ", " (qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? e",
" (qq depth (car expr))\n (qq depth (cdr expr))))\n ", "xpr)\n (list (the 'cons)\n (qq depth (car expr))\n ",
" ;; vector\n ((vector? expr)\n (list (the 'list->vec", " (qq depth (cdr expr))))\n ;; vector\n ((vector? e",
"tor) (qq depth (vector->list expr))))\n ;; variable\n ((variab", "xpr)\n (list (the 'list->vector) (qq depth (vector->list expr))))\n ",
"le? expr)\n (rename expr))\n ;; simple datum\n (else", " ;; variable\n ((variable? expr)\n (rename expr))\n ",
"\n (list (the 'quote) expr))))\n\n (let ((body (qq 1 (cadr form))", " ;; simple datum\n (else\n (list (the 'quote) expr))))\n\n",
"))\n `(,(the 'let)\n ,(map cdr renames)\n ,body)))))", " (let ((body (qq 1 (cadr form))))\n `(,(the 'let)\n ,(m",
")\n\n(define (transformer f)\n (lambda (form env)\n (let ((register1 (make-regis", "ap cdr renames)\n ,body))))))\n\n(define (transformer f)\n (lambda (form",
"ter))\n (register2 (make-register)))\n (letrec\n ((wrap (lam", " env)\n (let ((register1 (make-register))\n (register2 (make-register)",
"bda (var1)\n (let ((var2 (register1 var1)))\n ", "))\n (letrec\n ((wrap (lambda (var1)\n (let ((var2 ",
" (if (undefined? var2)\n (let ((var2 (make-identifier va", "(register1 var1)))\n (if (undefined? var2)\n ",
"r1 env)))\n (register1 var1 var2)\n ", " (let ((var2 (make-identifier var1 env)))\n (regi",
" (register2 var2 var1)\n var2)\n ", "ster1 var1 var2)\n (register2 var2 var1)\n ",
" var2))))\n (unwrap (lambda (var2)\n (let ((var", " var2)\n var2))))\n (unwrap (lambda ",
"1 (register2 var2)))\n (if (undefined? var1)\n ", "(var2)\n (let ((var1 (register2 var2)))\n ",
" var2\n var1))))\n (walk (lambda (", " (if (undefined? var1)\n var2\n ",
"f form)\n (cond\n ((variable? form)\n ", " var1))))\n (walk (lambda (f form)\n (cond\n ",
" (f form))\n ((pair? form)\n (co", " ((variable? form)\n (f form))\n ",
"ns (walk f (car form)) (walk f (cdr form))))\n ((vector? form)", "((pair? form)\n (cons (walk f (car form)) (walk f (cdr form))",
"\n (list->vector (walk f (vector->list form))))\n ", "))\n ((vector? form)\n (list->vector (walk ",
" (else\n form)))))\n (let ((form (cdr form)))\n ", "f (vector->list form))))\n (else\n form))))",
" (walk unwrap (apply f (walk wrap form))))))))\n\n(define-macro define-synta", ")\n (let ((form (cdr form)))\n (walk unwrap (apply f (walk wrap fo",
"x\n (lambda (form env)\n (let ((formal (car (cdr form)))\n (body (cd", "rm))))))))\n\n(define-macro define-syntax\n (lambda (form env)\n (let ((formal (",
"r (cdr form))))\n (if (pair? formal)\n `(,(the 'define-syntax) ,(car", "car (cdr form)))\n (body (cdr (cdr form))))\n (if (pair? formal)\n ",
" formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-define-macro ,form", " `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body",
"al (,(the 'transformer) (,the-begin ,@body)))))))\n\n(define-macro letrec-syntax\n ", "))\n `(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body",
" (lambda (form env)\n (let ((formal (car (cdr form)))\n (body (cdr (", ")))))))\n\n(define-macro letrec-syntax\n (lambda (form env)\n (let ((formal (car",
"cdr form))))\n `(let ()\n ,@(map (lambda (x)\n `(,(th", " (cdr form)))\n (body (cdr (cdr form))))\n `(let ()\n ,@(ma",
"e 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))", "p (lambda (x)\n `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n ",
"))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@", " formal)\n ,@body))))\n\n(define-macro let-syntax\n (lambda (fo",
"(cdr form))))\n\n\n;;; library primitives\n\n(define-macro define-library\n (lambda (", "rm env)\n `(,(the 'letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(d",
"form _)\n (let ((name (cadr form))\n (body (cddr form)))\n (let ((", "efine-macro define-library\n (lambda (form _)\n (let ((name (cadr form))\n ",
"old-library (current-library))\n (new-library (or (find-library name) ", " (body (cddr form)))\n (let ((old-library (current-library))\n ",
"(make-library name))))\n (let ((env (library-environment new-library)))\n ", " (new-library (or (find-library name) (make-library name))))\n (let ((env ",
" (current-library new-library)\n (for-each (lambda (expr) (eval e", "(library-environment new-library)))\n (current-library new-library)\n ",
"xpr env)) body)\n (current-library old-library))))))\n\n(define-macro cond", " (for-each (lambda (expr) (eval expr env)) body)\n (current-library",
"-expand\n (lambda (form _)\n (letrec\n ((test (lambda (form)\n ", " old-library))))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec\n ",
" (or\n (eq? form 'else)\n (and (symbol? for", " ((test (lambda (form)\n (or\n (eq? form 'els",
"m)\n (memq form (features)))\n (and (pair? ", "e)\n (and (symbol? form)\n (memq form (feat",
"form)\n (case (car form)\n ((library", "ures)))\n (and (pair? form)\n (case (car fo",
") (find-library (cadr form)))\n ((not) (not (test (cadr f", "rm)\n ((library) (find-library (cadr form)))\n ",
"orm))))\n ((and) (let loop ((form (cdr form)))\n ", " ((not) (not (test (cadr form))))\n ((and) (l",
" (or (null? form)\n (", "et loop ((form (cdr form)))\n (or (null? form)\n ",
"and (test (car form)) (loop (cdr form))))))\n ((or) (let ", " (and (test (car form)) (loop (cdr form)))))",
"loop ((form (cdr form)))\n (and (pair? form)\n ", ")\n ((or) (let loop ((form (cdr form)))\n ",
" (or (test (car form)) (loop (cdr form))))))\n ", " (and (pair? form)\n (or (tes",
" (else #f)))))))\n (let loop ((clauses (cdr form)))\n ", "t (car form)) (loop (cdr form))))))\n (else #f)))))))\n ",
" (if (null? clauses)\n #undefined\n (if (test (caar cla", " (let loop ((clauses (cdr form)))\n (if (null? clauses)\n #und",
"uses))\n `(,the-begin ,@(cdar clauses))\n (loop (cdr", "efined\n (if (test (caar clauses))\n `(,the-begin ,@(cda",
" clauses))))))))\n\n(define-macro import\n (lambda (form _)\n (let ((caddr\n ", "r clauses))\n (loop (cdr clauses))))))))\n\n(define-macro import\n (",
" (lambda (x) (car (cdr (cdr x)))))\n (prefix\n (lambda (pr", "lambda (form _)\n (let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n ",
"efix symbol)\n (string->symbol\n (string-append\n ", " (prefix\n (lambda (prefix symbol)\n (string->symbol\n",
" (symbol->string prefix)\n (symbol->string symbol))))))\n ", " (string-append\n (symbol->string prefix)\n ",
"(letrec\n ((extract\n (lambda (spec)\n (case (car ", " (symbol->string symbol))))))\n (letrec\n ((extract\n (l",
"spec)\n ((only rename prefix except)\n (extract (ca", "ambda (spec)\n (case (car spec)\n ((only rename prefix",
"dr spec)))\n (else\n (or (find-library spec) (error", " except)\n (extract (cadr spec)))\n (else\n ",
" \"library not found\" spec))))))\n (collect\n (lambda (spec)\n ", " (or (find-library spec) (error \"library not found\" spec))))))\n ",
" (case (car spec)\n ((only)\n (let ((al", " (collect\n (lambda (spec)\n (case (car spec)\n ",
"ist (collect (cadr spec))))\n (map (lambda (var) (assq var alis", " ((only)\n (let ((alist (collect (cadr spec))))\n ",
"t)) (cddr spec))))\n ((rename)\n (let ((alist (coll", " (map (lambda (var) (assq var alist)) (cddr spec))))\n ((renam",
"ect (cadr spec))))\n (map (lambda (s) (or (assq (car s) (cddr s", "e)\n (let ((alist (collect (cadr spec))))\n (map",
"pec)) s)) alist)))\n ((prefix)\n (let ((alist (coll", " (lambda (s) (or (assq (car s) (cddr spec)) s)) alist)))\n ((prefi",
"ect (cadr spec))))\n (map (lambda (s) (cons (prefix (caddr spec", "x)\n (let ((alist (collect (cadr spec))))\n (map",
") (car s)) (cdr s))) alist)))\n ((except)\n (let ((", " (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ",
"alist (collect (cadr spec))))\n (let loop ((alist alist))\n ", " ((except)\n (let ((alist (collect (cadr spec))))\n ",
" (if (null? alist)\n '()\n ", " (let loop ((alist alist))\n (if (null? alist)\n ",
" (if (memq (caar alist) (cddr spec))\n (loop (", " '()\n (if (memq (caar alist) (cddr spec)",
"cdr alist))\n (cons (car alist) (loop (cdr alist)))))", ")\n (loop (cdr alist))\n (",
")))\n (else\n (let ((lib (or (find-library spec) (e", "cons (car alist) (loop (cdr alist))))))))\n (else\n ",
"rror \"library not found\" spec))))\n (map (lambda (x) (cons x x)", " (let ((lib (or (find-library spec) (error \"library not found\" spec))))\n ",
") (library-exports lib))))))))\n (letrec\n ((import\n ", " (map (lambda (x) (cons x x)) (library-exports lib))))))))\n (le",
" (lambda (spec)\n (let ((lib (extract spec))\n ", "trec\n ((import\n (lambda (spec)\n (let ((",
" (alist (collect spec)))\n (for-each\n (l", "lib (extract spec))\n (alist (collect spec)))\n ",
"ambda (slot)\n (library-import lib (cdr slot) (car slot)))\n ", " (for-each\n (lambda (slot)\n (librar",
" alist)))))\n (for-each import (cdr form)))))))\n\n(defi", "y-import lib (cdr slot) (car slot)))\n alist)))))\n (f",
"ne-macro export\n (lambda (form _)\n (letrec\n ((collect\n (lamb", "or-each import (cdr form)))))))\n\n(define-macro export\n (lambda (form _)\n (le",
"da (spec)\n (cond\n ((symbol? spec)\n `(,spec .", "trec\n ((collect\n (lambda (spec)\n (cond\n (",
" ,spec))\n ((and (list? spec) (= (length spec) 3) (eq? (car spec) 're", "(symbol? spec)\n `(,spec . ,spec))\n ((and (list? spec) (",
"name))\n `(,(list-ref spec 1) . ,(list-ref spec 2)))\n (e", "= (length spec) 3) (eq? (car spec) 'rename))\n `(,(list-ref spec 1) ",
"lse\n (error \"malformed export\")))))\n (export\n (la", ". ,(list-ref spec 2)))\n (else\n (error \"malformed export",
"mbda (spec)\n (let ((slot (collect spec)))\n (library-ex", "\")))))\n (export\n (lambda (spec)\n (let ((slot (coll",
"port (car slot) (cdr slot))))))\n (for-each export (cdr form)))))\n\n(export d", "ect spec)))\n (library-export (car slot) (cdr slot))))))\n (for",
"efine-library\n cond-expand\n import\n export)\n\n(export let le", "-each export (cdr form)))))\n\n(export define-library\n cond-expand\n ",
"t* letrec letrec*\n let-values let*-values define-values\n quasiquot", "import\n export)\n\n(export let let* letrec letrec*\n let-values let*-",
"e unquote unquote-splicing\n and or\n cond case else =>\n do w", "values define-values\n quasiquote unquote unquote-splicing\n and or\n",
"hen unless\n parameterize\n define-syntax\n syntax-quote synta", " cond case else =>\n do when unless\n parameterize\n de",
"x-unquote\n syntax-quasiquote syntax-unquote-splicing\n let-syntax l", "fine-syntax\n syntax-quote syntax-unquote\n syntax-quasiquote syntax",
"etrec-syntax\n syntax-error)\n\n\n", "-unquote-splicing\n let-syntax letrec-syntax\n syntax-error)\n\n\n",
"", "",
"" ""
}; };

6
extlib/benz/codegen.c
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, "ai = %zu\n", pic_gc_arena_preserve(pic));
fprintf(stdout, "# input expression\n"); fprintf(stdout, "# input expression\n");
pic_debug(pic, obj); pic_write(pic, obj);
fprintf(stdout, "\n"); fprintf(stdout, "\n");
fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); 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); obj = pic_expand(pic, obj, env);
#if DEBUG #if DEBUG
fprintf(stdout, "## expand completed\n"); fprintf(stdout, "## expand completed\n");
pic_debug(pic, obj); pic_write(pic, obj);
fprintf(stdout, "\n"); fprintf(stdout, "\n");
fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
#endif #endif
@ -1566,7 +1566,7 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_env *env)
obj = pic_analyze(pic, obj); obj = pic_analyze(pic, obj);
#if DEBUG #if DEBUG
fprintf(stdout, "## analyzer completed\n"); fprintf(stdout, "## analyzer completed\n");
pic_debug(pic, obj); pic_write(pic, obj);
fprintf(stdout, "\n"); fprintf(stdout, "\n");
fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
#endif #endif

8
extlib/benz/state.c
View File

@ -156,7 +156,13 @@ pic_init_core(pic_state *pic)
pic_init_attr(pic); DONE; pic_init_attr(pic); DONE;
pic_init_reg(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); pic_import(pic, pic->PICRIN_BASE);

2
extlib/benz/vm.c
View File

@ -633,7 +633,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
sym = irep->syms[c.u.i]; sym = irep->syms[c.u.i];
if (! pic_dict_has(pic, pic->globals, sym)) { 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)); PUSH(pic_dict_ref(pic, pic->globals, sym));
NEXT; NEXT;