From 4d18610a79cc2d50b0c9b5acdae584a23654e97a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 17:44:06 +0900 Subject: [PATCH] refine error messages --- extlib/benz/boot.c | 492 +++++++++++++++++++++--------------------- extlib/benz/codegen.c | 6 +- extlib/benz/state.c | 8 +- extlib/benz/vm.c | 2 +- 4 files changed, 257 insertions(+), 251 deletions(-) diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index 328ca73d..81e82626 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -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", "", "" }; diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index a256b563..7b5e82da 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -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 diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 70e09571..ddbe27fa 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -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); diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index 13b8727c..47044312 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -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;