From bcf53b9883fcea38f1ba19462115d5a5109b064b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 17:43:42 +0900 Subject: [PATCH 1/9] reimplement core syntaxes in scheme --- extlib/benz/boot.c | 650 ++++++++++++++++++++++++++------------------ extlib/benz/state.c | 19 +- extlib/benz/vm.c | 8 +- 3 files changed, 411 insertions(+), 266 deletions(-) diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index d24bcf40..328ca73d 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -8,25 +8,118 @@ use strict; my $src = <<'EOL'; -(define-macro call-with-current-environment - (lambda (form env) +(builtin:define-macro call-with-current-environment + (builtin:lambda (form env) (list (cadr form) env))) -(define here +(builtin:define here (call-with-current-environment - (lambda (env) + (builtin:lambda (env) env))) -(define (the var) ; synonym for #'var - (make-identifier var here)) +(builtin:define the ; synonym for #'var + (builtin:lambda (var) + (make-identifier var here))) + + +(builtin:define the-builtin-define (the (builtin:quote builtin:define))) +(builtin:define the-builtin-lambda (the (builtin:quote builtin:lambda))) +(builtin:define the-builtin-begin (the (builtin:quote builtin:begin))) +(builtin:define the-builtin-quote (the (builtin:quote builtin:quote))) +(builtin:define the-builtin-set! (the (builtin:quote builtin:set!))) +(builtin:define the-builtin-if (the (builtin:quote builtin:if))) +(builtin:define the-builtin-define-macro (the (builtin:quote builtin:define-macro))) + +(builtin:define the-define (the (builtin:quote define))) +(builtin:define the-lambda (the (builtin:quote lambda))) +(builtin:define the-begin (the (builtin:quote begin))) +(builtin:define the-quote (the (builtin:quote quote))) +(builtin:define the-set! (the (builtin:quote set!))) +(builtin:define the-if (the (builtin:quote if))) +(builtin:define the-define-macro (the (builtin:quote define-macro))) + +(builtin:define-macro quote + (builtin:lambda (form env) + (builtin:if (= (length form) 2) + (list the-builtin-quote (cadr form)) + (error "illegal quote form" form)))) + +(builtin:define-macro if + (builtin:lambda (form env) + ((builtin:lambda (len) + (builtin:if (= len 4) + (cons the-builtin-if (cdr form)) + (builtin:if (= len 3) + (list the-builtin-if (list-ref form 1) (list-ref form 2) #undefined) + (error "illegal if form" form)))) + (length form)))) + +(builtin:define-macro begin + (builtin:lambda (form env) + ((builtin:lambda (len) + (if (= len 1) + #undefined + (if (= len 2) + (cadr form) + (if (= len 3) + (cons the-builtin-begin (cdr form)) + (list the-builtin-begin + (cadr form) + (cons the-begin (cddr form))))))) + (length form)))) + +(builtin:define-macro set! + (builtin:lambda (form env) + (if (= (length form) 3) + (if (variable? (cadr form)) + (cons the-builtin-set! (cdr form)) + (error "illegal set! form" form)) + (error "illegal set! form" form)))) + +(builtin:define check-formal + (builtin:lambda (formal) + (if (null? formal) + #t + (if (variable? formal) + #t + (if (pair? formal) + (if (variable? (car formal)) + (check-formal (cdr formal)) + #f) + #f))))) + +(builtin:define-macro lambda + (builtin:lambda (form env) + (if (= (length form) 1) + (error "illegal lambda form" form) + (if (check-formal (cadr form)) + (list the-builtin-lambda (cadr form) (cons the-begin (cddr form))) + (error "illegal lambda form" form))))) + +(builtin:define-macro define + (lambda (form env) + ((lambda (len) + (if (= len 1) + (error "illegal define form" form) + (if (variable? (cadr form)) + (if (= len 3) + (cons the-builtin-define (cdr form)) + (error "illegal define form" form)) + (if (pair? (cadr form)) + (list the-define + (car (cadr form)) + (cons the-lambda (cons (cdr (cadr form)) (cddr form)))) + (error "illegal define form" form))))) + (length form)))) + +(builtin:define-macro define-macro + (lambda (form env) + (if (= (length form) 3) + (if (variable? (cadr form)) + (cons the-builtin-define-macro (cdr form)) + (error "illegal define-macro form" form)) + (error "illegal define-macro form" form)))) -(define the-define (the 'define)) -(define the-lambda (the 'lambda)) -(define the-begin (the 'begin)) -(define the-quote (the 'quote)) -(define the-set! (the 'set!)) -(define the-if (the 'if)) -(define the-define-macro (the 'define-macro)) (define-macro syntax-error (lambda (form _) @@ -623,251 +716,294 @@ EOL #endif const char pic_boot[][80] = { -"\n(define-macro call-with-current-environment\n (lambda (form env)\n (list (cad", -"r form) env)))\n\n(define here\n (call-with-current-environment\n (lambda (env)\n ", -" env)))\n\n(define (the var) ; synonym for #'var\n (make-id", -"entifier var here))\n\n(define the-define (the 'define))\n(define the-lambda (the '", -"lambda))\n(define the-begin (the 'begin))\n(define the-quote (the 'quote))\n(define", -" the-set! (the 'set!))\n(define the-if (the 'if))\n(define the-define-macro (the '", -"define-macro))\n\n(define-macro syntax-error\n (lambda (form _)\n (apply error (", -"cdr form))))\n\n(define-macro define-auxiliary-syntax\n (lambda (form _)\n (defi", -"ne message\n (string-append\n \"invalid use of auxiliary syntax: '\" (sym", -"bol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (cadr form)\n", -" (list the-lambda '_\n (list (the 'error) message)))))\n\n(define-aux", -"iliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-auxiliary-syntax unquot", -"e)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxiliary-syntax syntax-un", -"quote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(define-macro let\n (l", -"ambda (form env)\n (if (variable? (cadr form))\n (list\n (list th", -"e-lambda '()\n (list the-define (cadr form)\n (c", -"ons the-lambda\n (cons (map car (car (cddr form)))\n ", -" (cdr (cddr form)))))\n (cons (cadr for", -"m) (map cadr (car (cddr form))))))\n (cons\n (cons\n the-la", -"mbda\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 (nu", -"ll? (cdr form))\n #t\n (if (null? (cddr form))\n (cadr for", -"m)\n (list the-if\n (cadr form)\n (con", -"s (the 'and) (cddr form))\n #f)))))\n\n(define-macro or\n (lambda ", -"(form env)\n (if (null? (cdr form))\n #f\n (let ((tmp (make-identi", -"fier '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-macr", -"o cond\n (lambda (form env)\n (let ((clauses (cdr form)))\n (if (null? cla", -"uses)\n #undefined\n (let ((clause (car clauses)))\n (", -"if (and (variable? (car clause))\n (variable=? (the 'else) (m", -"ake-identifier (car clause) env)))\n (cons the-begin (cdr clause))", -"\n (if (and (variable? (cadr clause))\n (va", -"riable=? (the '=>) (make-identifier (cadr clause) env)))\n (le", -"t ((tmp (make-identifier 'tmp here)))\n (list (the 'let) (li", -"st (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 quasiquo", -"te\n (lambda (form env)\n\n (define (quasiquote? form)\n (and (pair? form)\n", -" (variable? (car form))\n (variable=? (the 'quasiquote) (make", -"-identifier (car form) env))))\n\n (define (unquote? form)\n (and (pair? fo", -"rm)\n (variable? (car form))\n (variable=? (the 'unquote) (mak", -"e-identifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and", -" (pair? form)\n (pair? (car form))\n (variable? (caar form))\n ", -" (variable=? (the 'unquote-splicing) (make-identifier (caar form) env))", -"))\n\n (define (qq depth expr)\n (cond\n ;; unquote\n ((unquote? ", -"expr)\n (if (= depth 1)\n (car (cdr expr))\n (list (th", -"e '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 (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ", -" ;; quasiquote\n ((quasiquote? expr)\n (list (the 'list)\n ", -" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) (car (c", -"dr expr)))))\n ;; list\n ((pair? expr)\n (list (the 'cons)\n ", -" (qq depth (car expr))\n (qq depth (cdr expr))))\n ;; v", -"ector\n ((vector? expr)\n (list (the 'list->vector) (qq depth (vector", -"->list expr))))\n ;; simple datum\n (else\n (list (the 'quote) e", -"xpr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(define-macro let*\n (lam", -"bda (form env)\n (let ((bindings (car (cdr form)))\n (body (cdr (c", -"dr form))))\n (if (null? bindings)\n `(,(the 'let) () ,@body)\n ", -" `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n (", -",(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n(define-macro letrec\n", -" (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n\n(define-macro letrec", -"*\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ", -" (cdr (cdr form))))\n (let ((variables (map (lambda (v) `(,v #f)) (map car b", -"indings)))\n (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings", -")))\n `(,(the 'let) (,@variables)\n ,@initials\n ,@body)))", -"))\n\n(define-macro let-values\n (lambda (form env)\n `(,(the 'let*-values) ,@(c", -"dr form))))\n\n(define-macro let*-values\n (lambda (form env)\n (let ((formal (c", -"ar (cdr form)))\n (body (cdr (cdr form))))\n (if (null? formal)\n ", -" `(,(the 'let) () ,@body)\n `(,(the 'call-with-values) (,the-lamb", -"da () ,@(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 ((arguments (make-identifier", -" 'arguments here)))\n `(,the-begin\n ,@(let loop ((formal formal))", -"\n (if (pair? formal)\n `((,the-define ,(car formal)", -" #undefined) ,@(loop (cdr formal)))\n (if (variable? formal)\n ", -" `((,the-define ,formal #undefined))\n '()", -")))\n (,(the 'call-with-values) (,the-lambda () ,@body)\n (,the", -"-lambda\n ,arguments\n ,@(let loop ((formal formal) (args ar", -"guments))\n (if (pair? formal)\n `((,the-set! ,(", -"car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))\n ", -" (if (variable? formal)\n `((,the-set! ,fo", -"rmal ,args))\n '()))))))))))\n\n(define-macro do\n (lambda (", -"form env)\n (let ((bindings (car (cdr form)))\n (test (car (car (c", -"dr (cdr form)))))\n (cleanup (cdr (car (cdr (cdr form)))))\n (b", -"ody (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 ,@c", -"leanup)\n (,the-begin\n ,@body\n ", -" (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car x) (car (cdr (cdr", -" x))))) bindings)))))))))\n\n(define-macro when\n (lambda (form env)\n (let ((te", -"st (car (cdr form)))\n (body (cdr (cdr form))))\n `(,the-if ,test\n ", -" (,the-begin ,@body)\n #undefined))))\n\n(define-macro ", -"unless\n (lambda (form env)\n (let ((test (car (cdr form)))\n (body (c", -"dr (cdr form))))\n `(,the-if ,test\n #undefined\n ", -" (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (form env)\n (let ((ke", -"y (car (cdr form)))\n (clauses (cdr (cdr form))))\n (let ((the-k", -"ey (make-identifier 'key here)))\n `(,(the 'let) ((,the-key ,key))\n ", -" ,(let loop ((clauses clauses))\n (if (null? clauses)\n ", -" #undefined\n (let ((clause (car clauses)))\n ", -" `(,the-if ,(if (and (variable? (car clause))\n ", -" (variable=? (the 'else) (make-identifier (car clause) env)))\n ", -" #t\n `(,(the 'or) ,@(map (la", -"mbda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ", -" ,(if (and (variable? (cadr clause))\n ", -" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ", -" `(,(car (cdr (cdr clause))) ,the-key)\n ", -" `(,the-begin ,@(cdr clause)))\n ,(lo", -"op (cdr clauses)))))))))))\n\n(define-macro parameterize\n (lambda (form env)\n ", -"(let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(,(t", -"he 'with-parameter)\n (,(the 'lambda) ()\n ,@formal\n ,@body", -")))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (let ((renames '()))\n", -" (letrec\n ((rename (lambda (var)\n (let ((x (as", -"sq var renames)))\n (if x\n (cadr ", -"x)\n (begin\n (set! renames ", -"`((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,ren", -"ames))\n (rename var))))))\n (walk (lambda (", +"\n(builtin:define-macro call-with-current-environment\n (builtin:lambda (form env", +")\n (list (cadr form) env)))\n\n(builtin:define here\n (call-with-current-enviro", +"nment\n (builtin:lambda (env)\n env)))\n\n(builtin:define the ", +" ; synonym for #'var\n (builtin:lambda (var)\n (make-identifier var here)))", +"\n\n\n(builtin:define the-builtin-define (the (builtin:quote builtin:define)))\n(bui", +"ltin:define the-builtin-lambda (the (builtin:quote builtin:lambda)))\n(builtin:de", +"fine the-builtin-begin (the (builtin:quote builtin:begin)))\n(builtin:define the-", +"builtin-quote (the (builtin:quote builtin:quote)))\n(builtin:define the-builtin-s", +"et! (the (builtin:quote builtin:set!)))\n(builtin:define the-builtin-if (the (bui", +"ltin:quote builtin:if)))\n(builtin:define the-builtin-define-macro (the (builtin:", +"quote builtin:define-macro)))\n\n(builtin:define the-define (the (builtin:quote de", +"fine)))\n(builtin:define the-lambda (the (builtin:quote lambda)))\n(builtin:define", +" the-begin (the (builtin:quote begin)))\n(builtin:define the-quote (the (builtin:", +"quote quote)))\n(builtin:define the-set! (the (builtin:quote set!)))\n(builtin:def", +"ine the-if (the (builtin:quote if)))\n(builtin:define the-define-macro (the (buil", +"tin:quote define-macro)))\n\n(builtin:define-macro quote\n (builtin:lambda (form e", +"nv)\n (builtin:if (= (length form) 2)\n (list the-builtin-quote (cadr form", +"))\n (error \"illegal quote form\" form))))\n\n(builtin:define-macro if\n (built", +"in:lambda (form env)\n ((builtin:lambda (len)\n (builtin:if (= len 4)\n ", +" (cons the-builtin-if (cdr form))\n (builtin:if (= len 3)\n ", +" (list the-builtin-if (list-ref form 1) (list-ref form 2) #undefined)\n ", +" (error \"illegal if form\" form))))\n (length form))))\n\n(builtin:d", +"efine-macro begin\n (builtin:lambda (form env)\n ((builtin:lambda (len)\n ", +" (if (= len 1)\n #undefined\n (if (= len 2)\n (ca", +"dr form)\n (if (= len 3)\n (cons the-builtin-begin", +" (cdr form))\n (list the-builtin-begin\n ", +" (cadr form)\n (cons the-begin (cddr form)))))))\n (le", +"ngth form))))\n\n(builtin:define-macro set!\n (builtin:lambda (form env)\n (if (", +"= (length form) 3)\n (if (variable? (cadr form))\n (cons the-bui", +"ltin-set! (cdr form))\n (error \"illegal set! form\" form))\n (err", +"or \"illegal set! form\" form))))\n\n(builtin:define check-formal\n (builtin:lambda ", +"(formal)\n (if (null? formal)\n #t\n (if (variable? formal)\n ", +" #t\n (if (pair? formal)\n (if (variable? (car form", +"al))\n (check-formal (cdr formal))\n #f)\n ", +" #f)))))\n\n(builtin:define-macro lambda\n (builtin:lambda (form env)\n", +" (if (= (length form) 1)\n (error \"illegal lambda form\" form)\n (", +"if (check-formal (cadr form))\n (list the-builtin-lambda (cadr form) (", +"cons the-begin (cddr form)))\n (error \"illegal lambda form\" form)))))\n", +"\n(builtin:define-macro define\n (lambda (form env)\n ((lambda (len)\n (if", +" (= len 1)\n (error \"illegal define form\" form)\n (if (variabl", +"e? (cadr form))\n (if (= len 3)\n (cons the-builti", +"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 `(,", -"(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ((vect", -"or? form)\n `(,(the 'list->vector) (walk f (vector->list form", -"))))\n (else\n `(,(the 'quote) ,form))))))\n", -" (let ((form (walk rename (cadr form))))\n `(,(the 'let)\n ", -" ,(map cdr renames)\n ,form))))))\n\n(define-macro syntax-quasiquote\n", -" (lambda (form env)\n (let ((renames '()))\n (letrec\n ((rename (", -"lambda (var)\n (let ((x (assq var renames)))\n ", -" (if x\n (cadr x)\n (beg", -"in\n (set! renames `((,var ,(make-identifier var env)", -" (,(the 'make-identifier) ',var ',env)) . ,renames))\n ", -" (rename var)))))))\n\n (define (syntax-quasiquote? form)\n (and (", -"pair? form)\n (variable? (car form))\n (variable=? (th", -"e 'syntax-quasiquote) (make-identifier (car form) env))))\n\n (define (synt", -"ax-unquote? form)\n (and (pair? form)\n (variable? (car for", -"m))\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 ", -" (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar ", -"form) env))))\n\n (define (qq depth expr)\n (cond\n ;; syn", -"tax-unquote\n ((syntax-unquote? expr)\n (if (= depth 1)\n ", -" (car (cdr expr))\n (list (the 'list)\n ", -" (list (the 'quote) (the 'syntax-unquote))\n (qq (- depth", -" 1) (car (cdr expr))))))\n ;; syntax-unquote-splicing\n ((synt", -"ax-unquote-splicing? expr)\n (if (= depth 1)\n (list (th", -"e 'append)\n (car (cdr (car expr)))\n (q", -"q depth (cdr expr)))\n (list (the 'cons)\n (li", -"st (the 'list)\n (list (the 'quote) (the 'syntax-unquo", -"te-splicing))\n (qq (- depth 1) (car (cdr (car expr)))", -"))\n (qq depth (cdr expr)))))\n ;; syntax-quasiquot", -"e\n ((syntax-quasiquote? expr)\n (list (the 'list)\n ", -" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) ", -"(car (cdr expr)))))\n ;; list\n ((pair? expr)\n (lis", -"t (the 'cons)\n (qq depth (car expr))\n (qq dept", -"h (cdr expr))))\n ;; vector\n ((vector? expr)\n (lis", -"t (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 ,(map cdr renames)\n ", -" ,body))))))\n\n(define (transformer f)\n (lambda (form env)\n (let ((regi", -"ster1 (make-register))\n (register2 (make-register)))\n (letrec\n ", -" ((wrap (lambda (var1)\n (let ((var2 (register1 var1)))\n ", -" (if (undefined? var2)\n (let ((var2 (m", -"ake-identifier var1 env)))\n (register1 var1 var2)\n ", -" (register2 var2 var1)\n var2)\n ", -" var2))))\n (unwrap (lambda (var2)\n ", -" (let ((var1 (register2 var2)))\n (if (undefined? var", -"1)\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 form))))))))\n\n(define-m", -"acro define-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", -" (body (cdr (cdr form))))\n (if (pair? formal)\n `(,(the 'def", -"ine-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-d", -"efine-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(define-macr", -"o letrec-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", -" (body (cdr (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n ", -" `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n", -" ,@body))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the '", -"letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro define-li", -"brary\n (lambda (form _)\n (let ((name (cadr form))\n (body (cddr form", -")))\n (let ((old-library (current-library))\n (new-library (or (fi", -"nd-library name) (make-library name))))\n (let ((env (library-environment ", -"new-library)))\n (current-library new-library)\n (for-each (lamb", -"da (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 'else)\n ", -"(and (symbol? form)\n (memq form (features)))\n ", -" (and (pair? form)\n (case (car form)\n ", -" ((library) (find-library (cadr form)))\n ((not) (", -"not (test (cadr form))))\n ((and) (let loop ((form (cdr f", -"orm)))\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 ((clause", -"s (cdr form)))\n (if (null? clauses)\n #undefined\n (i", -"f (test (caar clauses))\n `(,the-begin ,@(cdar clauses))\n ", -" (loop (cdr clauses))))))))\n\n(define-macro import\n (lambda (form _)\n (", -"let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n (prefix\n ", -" (lambda (prefix symbol)\n (string->symbol\n (string", -"-append\n (symbol->string prefix)\n (symbol->string sy", -"mbol))))))\n (letrec\n ((extract\n (lambda (spec)\n ", -" (case (car spec)\n ((only rename prefix except)\n ", -" (extract (cadr spec)))\n (else\n (or (find-lib", -"rary 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 (va", -"r) (assq var alist)) (cddr spec))))\n ((rename)\n (", -"let ((alist (collect (cadr spec))))\n (map (lambda (s) (or (ass", -"q (car s) (cddr spec)) s)) alist)))\n ((prefix)\n (", -"let ((alist (collect (cadr spec))))\n (map (lambda (s) (cons (p", -"refix (caddr spec) (car s)) (cdr s))) alist)))\n ((except)\n ", -" (let ((alist (collect (cadr spec))))\n (let loop ((al", -"ist alist))\n (if (null? alist)\n '()\n", -" (if (memq (caar alist) (cddr spec))\n ", -" (loop (cdr alist))\n (cons (car alist) (loo", -"p (cdr alist))))))))\n (else\n (let ((lib (or (find", -"-library spec) (error \"library not found\" spec))))\n (map (lamb", -"da (x) (cons x x)) (library-exports lib))))))))\n (letrec\n ((im", -"port\n (lambda (spec)\n (let ((lib (extract spec))\n ", -" (alist (collect spec)))\n (for-each\n ", -" (lambda (slot)\n (library-import lib (cdr slo", -"t) (car slot)))\n alist)))))\n (for-each import (cdr f", -"orm)))))))\n\n(define-macro export\n (lambda (form _)\n (letrec\n ((collec", -"t\n (lambda (spec)\n (cond\n ((symbol? spec)\n ", -" `(,spec . ,spec))\n ((and (list? spec) (= (length spec) 3) (e", -"q? (car spec) 'rename))\n `(,(list-ref spec 1) . ,(list-ref spec 2))", -")\n (else\n (error \"malformed export\")))))\n (expo", -"rt\n (lambda (spec)\n (let ((slot (collect spec)))\n ", -" (library-export (car slot) (cdr slot))))))\n (for-each export (cdr for", -"m)))))\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 els", -"e =>\n do when unless\n parameterize\n define-syntax\n s", -"yntax-quote syntax-unquote\n syntax-quasiquote syntax-unquote-splicing\n ", -" let-syntax letrec-syntax\n syntax-error)\n\n\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", "", "" }; diff --git a/extlib/benz/state.c b/extlib/benz/state.c index f334a23c..70e09571 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -109,23 +109,26 @@ pic_features(pic_state *pic) #define DONE pic_gc_arena_restore(pic, ai); +#define define_builtin_syntax(uid, name) \ + pic_define_syntactic_keyword_(pic, pic->lib->env, pic_intern_cstr(pic, name), uid) + static void pic_init_core(pic_state *pic) { - void pic_define_syntactic_keyword(pic_state *, struct pic_env *, pic_sym *, pic_sym *); + void pic_define_syntactic_keyword_(pic_state *, struct pic_env *, pic_sym *, pic_sym *); pic_init_features(pic); pic_deflibrary (pic, "(picrin base)") { size_t ai = pic_gc_arena_preserve(pic); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->uDEFINE); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->uSETBANG); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->uQUOTE); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->uLAMBDA); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->uIF); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->uBEGIN); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_MACRO, pic->uDEFINE_MACRO); + define_builtin_syntax(pic->uDEFINE, "builtin:define"); + define_builtin_syntax(pic->uSETBANG, "builtin:set!"); + define_builtin_syntax(pic->uQUOTE, "builtin:quote"); + define_builtin_syntax(pic->uLAMBDA, "builtin:lambda"); + define_builtin_syntax(pic->uIF, "builtin:if"); + define_builtin_syntax(pic->uBEGIN, "builtin:begin"); + define_builtin_syntax(pic->uDEFINE_MACRO, "builtin:define-macro"); pic_defun(pic, "features", pic_features); diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index f661f10a..13b8727c 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -1110,9 +1110,15 @@ pic_apply5(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2 } void -pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *uid) +pic_define_syntactic_keyword_(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *uid) { pic_put_variable(pic, env, pic_obj_value(sym), uid); +} + +void +pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *uid) +{ + pic_define_syntactic_keyword_(pic, env, sym, uid); if (pic->lib && pic->lib->env == env) { pic_export(pic, sym); From 4d18610a79cc2d50b0c9b5acdae584a23654e97a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 17:44:06 +0900 Subject: [PATCH 2/9] 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; From 1bed1bd42034d0763af015e465dd50449b2d06a8 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 17:50:14 +0900 Subject: [PATCH 3/9] remove unnecessary error checks --- extlib/benz/codegen.c | 33 ++++----------------------------- 1 file changed, 4 insertions(+), 29 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 7b5e82da..a7a3cc6e 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -13,7 +13,7 @@ lookup(pic_state PIC_UNUSED(*pic), pic_value var, struct pic_env *env) { khiter_t it; - assert(pic_var_p(var)); + pic_assert_type(pic, var, var); while (env != NULL) { it = kh_get(env, &env->map, pic_ptr(var)); @@ -30,9 +30,10 @@ pic_resolve(pic_state *pic, pic_value var, struct pic_env *env) { pic_sym *uid; - assert(pic_var_p(var)); assert(env != NULL); + pic_assert_type(pic, var, var); + while ((uid = lookup(pic, var, env)) == NULL) { if (pic_sym_p(var)) { break; @@ -145,26 +146,14 @@ expand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) struct pic_env *in; pic_value a, deferred; - if (pic_length(pic, expr) < 2) { - pic_errorf(pic, "syntax error"); - } - in = pic_make_env(pic, env); for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) { - pic_value var = pic_car(pic, a); - - if (! pic_var_p(var)) { - pic_errorf(pic, "syntax error"); - } - pic_add_variable(pic, in, var); + pic_add_variable(pic, in, pic_car(pic, a)); } if (pic_var_p(a)) { pic_add_variable(pic, in, a); } - else if (! pic_nil_p(a)) { - pic_errorf(pic, "syntax error"); - } deferred = pic_list1(pic, pic_nil_value()); @@ -189,14 +178,7 @@ expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value def expr = pic_list3(pic, pic_obj_value(pic->uDEFINE), var, pic_cons(pic, pic_obj_value(pic->sLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr)))); } - if (pic_length(pic, expr) != 3) { - pic_errorf(pic, "syntax error"); - } - var = pic_cadr(pic, expr); - if (! pic_var_p(var)) { - pic_errorf(pic, "binding to non-variable object"); - } if ((uid = pic_find_variable(pic, env, var)) == NULL) { uid = pic_add_variable(pic, env, var); } else { @@ -213,14 +195,7 @@ expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) pic_value var, val; pic_sym *uid; - if (pic_length(pic, expr) != 3) { - pic_errorf(pic, "syntax error"); - } - var = pic_cadr(pic, expr); - if (! pic_var_p(var)) { - pic_errorf(pic, "binding to non-variable object"); - } if ((uid = pic_find_variable(pic, env, var)) == NULL) { uid = pic_add_variable(pic, env, var); } From f98a5ab14d9e80db445a5ed65f2f7f68c958397f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 18:23:08 +0900 Subject: [PATCH 4/9] cleanup --- extlib/benz/codegen.c | 22 +--------------------- 1 file changed, 1 insertion(+), 21 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index a7a3cc6e..012eceb9 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -171,13 +171,6 @@ expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value def pic_sym *uid; pic_value var, val; - while (pic_length(pic, expr) >= 2 && pic_pair_p(pic_cadr(pic, expr))) { - var = pic_car(pic, pic_cadr(pic, expr)); - val = pic_cdr(pic, pic_cadr(pic, expr)); - - expr = pic_list3(pic, pic_obj_value(pic->uDEFINE), var, pic_cons(pic, pic_obj_value(pic->sLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr)))); - } - var = pic_cadr(pic, expr); if ((uid = pic_find_variable(pic, env, var)) == NULL) { uid = pic_add_variable(pic, env, var); @@ -201,7 +194,6 @@ expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) } val = pic_eval(pic, pic_list_ref(pic, expr, 2), env); - if (! pic_proc_p(val)) { pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); } @@ -211,12 +203,6 @@ expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) return pic_undef_value(); } -static pic_value -expand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env) -{ - return pic_apply2(pic, mac, expr, pic_obj_value(env)); -} - static pic_value expand_node(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred) { @@ -251,7 +237,7 @@ expand_node(pic_state *pic, pic_value expr, struct pic_env *env, pic_value defer } if ((mac = find_macro(pic, functor)) != NULL) { - return expand_node(pic, expand_macro(pic, mac, expr, env), env, deferred); + return expand_node(pic, pic_apply2(pic, mac, expr, pic_obj_value(env)), env, deferred); } } return expand_list(pic, expr, env, deferred); @@ -267,12 +253,6 @@ expand(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred) size_t ai = pic_gc_arena_preserve(pic); pic_value v; -#if DEBUG - printf("[expand] expanding... "); - pic_debug(pic, expr); - puts(""); -#endif - v = expand_node(pic, expr, env, deferred); pic_gc_arena_restore(pic, ai); From 5633bbefaeeb938bab8b0ce6b298e9665c2130ed Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 18:38:16 +0900 Subject: [PATCH 5/9] don't enclose load_cstr with try-catch --- extlib/benz/state.c | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/extlib/benz/state.c b/extlib/benz/state.c index ddbe27fa..70e09571 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -156,13 +156,7 @@ pic_init_core(pic_state *pic) pic_init_attr(pic); DONE; pic_init_reg(pic); DONE; - pic_try { - pic_load_cstr(pic, &pic_boot[0][0]); - } - pic_catch { - pic_print_backtrace(pic, xstdout); - pic_raise(pic, pic->err); - } + pic_load_cstr(pic, &pic_boot[0][0]); } pic_import(pic, pic->PICRIN_BASE); From 36c498e7d7598815234e3e19fcdd609876c4ca0b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 18:47:16 +0900 Subject: [PATCH 6/9] cleanup analyzer --- extlib/benz/codegen.c | 208 ++++++++++++++---------------------------- 1 file changed, 67 insertions(+), 141 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 012eceb9..d539281e 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -157,12 +157,12 @@ expand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) deferred = pic_list1(pic, pic_nil_value()); - formal = expand_list(pic, pic_cadr(pic, expr), in, deferred); - body = expand_list(pic, pic_cddr(pic, expr), in, deferred); + formal = expand_list(pic, pic_list_ref(pic, expr, 1), in, deferred); + body = expand(pic, pic_list_ref(pic, expr, 2), in, deferred); expand_deferred(pic, deferred, in); - return pic_cons(pic, pic_obj_value(pic->uLAMBDA), pic_cons(pic, formal, body)); + return pic_list3(pic, pic_obj_value(pic->uLAMBDA), formal, body); } static pic_value @@ -297,28 +297,30 @@ typedef struct analyze_scope { struct analyze_scope *up; } analyze_scope; -static bool analyze_args(pic_state *, pic_value, analyze_scope *); - -static bool -analyzer_scope_init(pic_state *pic, analyze_scope *scope, pic_value formals, analyze_scope *up) +static void +analyzer_scope_init(pic_state *pic, analyze_scope *scope, pic_value formal, analyze_scope *up) { + int ret; + kh_init(a, &scope->args); kh_init(a, &scope->locals); kh_init(a, &scope->captures); - if (analyze_args(pic, formals, scope)) { - scope->up = up; - scope->depth = up ? up->depth + 1 : 0; - scope->defer = pic_nil_value(); - - return true; + /* analyze formal */ + for (; pic_pair_p(formal); formal = pic_cdr(pic, formal)) { + kh_put(a, &scope->args, pic_sym_ptr(pic_car(pic, formal)), &ret); + } + if (pic_nil_p(formal)) { + scope->rest = NULL; } else { - kh_destroy(a, &scope->args); - kh_destroy(a, &scope->locals); - kh_destroy(a, &scope->captures); - return false; + scope->rest = pic_sym_ptr(formal); + kh_put(a, &scope->locals, pic_sym_ptr(formal), &ret); } + + scope->up = up; + scope->depth = up ? up->depth + 1 : 0; + scope->defer = pic_nil_value(); } static void @@ -329,33 +331,6 @@ analyzer_scope_destroy(pic_state *pic, analyze_scope *scope) kh_destroy(a, &scope->captures); } -static bool -analyze_args(pic_state *pic, pic_value formals, analyze_scope *scope) -{ - pic_value v, t; - int ret; - - for (v = formals; pic_pair_p(v); v = pic_cdr(pic, v)) { - t = pic_car(pic, v); - if (! pic_sym_p(t)) { - return false; - } - kh_put(a, &scope->args, pic_sym_ptr(t), &ret); - } - if (pic_nil_p(v)) { - scope->rest = NULL; - } - else if (pic_sym_p(v)) { - scope->rest = pic_sym_ptr(v); - kh_put(a, &scope->locals, pic_sym_ptr(v), &ret); - } - else { - return false; - } - - return true; -} - static bool search_scope(analyze_scope *scope, pic_sym *sym) { @@ -482,66 +457,58 @@ analyze_deferred(pic_state *pic, analyze_scope *scope) } static pic_value -analyze_procedure(pic_state *pic, analyze_scope *up, pic_value name, pic_value formals, pic_value body_exprs) +analyze_procedure(pic_state *pic, analyze_scope *up, pic_value name, pic_value formals, pic_value body) { analyze_scope s, *scope = &s; - pic_value rest = pic_undef_value(), body; + pic_value rest = pic_undef_value(); pic_vec *args, *locals, *captures; + size_t i, j; assert(pic_sym_p(name) || pic_false_p(name)); - if (analyzer_scope_init(pic, scope, formals, up)) { - size_t i, j; + analyzer_scope_init(pic, scope, formals, up); - /* analyze body */ - body = analyze(pic, scope, pic_cons(pic, pic_obj_value(pic->uBEGIN), body_exprs), true); - analyze_deferred(pic, scope); + /* analyze body */ + body = analyze(pic, scope, body, true); + analyze_deferred(pic, scope); - args = pic_make_vec(pic, kh_size(&scope->args)); - for (i = 0; pic_pair_p(formals); formals = pic_cdr(pic, formals), i++) { - args->data[i] = pic_car(pic, formals); - } - - if (scope->rest != NULL) { - rest = pic_obj_value(scope->rest); - } - - locals = pic_make_vec(pic, kh_size(&scope->locals)); - for (i = kh_begin(&scope->locals), j = 0; i < kh_end(&scope->locals); ++i) { - if (kh_exist(&scope->locals, i)) { - locals->data[j++] = pic_obj_value(kh_key(&scope->locals, i)); - } - } - - captures = pic_make_vec(pic, kh_size(&scope->captures)); - for (i = kh_begin(&scope->captures), j = 0; i < kh_end(&scope->captures); ++i) { - if (kh_exist(&scope->captures, i)) { - captures->data[j++] = pic_obj_value(kh_key(&scope->captures, i)); - } - } - - analyzer_scope_destroy(pic, scope); + args = pic_make_vec(pic, kh_size(&scope->args)); + for (i = 0; pic_pair_p(formals); formals = pic_cdr(pic, formals), i++) { + args->data[i] = pic_car(pic, formals); } - else { - pic_errorf(pic, "invalid formal syntax: ~s", formals); + + if (scope->rest != NULL) { + rest = pic_obj_value(scope->rest); } + locals = pic_make_vec(pic, kh_size(&scope->locals)); + for (i = kh_begin(&scope->locals), j = 0; i < kh_end(&scope->locals); ++i) { + if (kh_exist(&scope->locals, i)) { + locals->data[j++] = pic_obj_value(kh_key(&scope->locals, i)); + } + } + + captures = pic_make_vec(pic, kh_size(&scope->captures)); + for (i = kh_begin(&scope->captures), j = 0; i < kh_end(&scope->captures); ++i) { + if (kh_exist(&scope->captures, i)) { + captures->data[j++] = pic_obj_value(kh_key(&scope->captures, i)); + } + } + + analyzer_scope_destroy(pic, scope); + return pic_list7(pic, pic_obj_value(pic->sLAMBDA), name, rest, pic_obj_value(args), pic_obj_value(locals), pic_obj_value(captures), body); } static pic_value analyze_lambda(pic_state *pic, analyze_scope *scope, pic_value obj) { - pic_value formals, body_exprs; - - if (pic_length(pic, obj) < 2) { - pic_errorf(pic, "syntax error"); - } + pic_value formals, body; formals = pic_list_ref(pic, obj, 1); - body_exprs = pic_list_tail(pic, obj, 2); + body = pic_list_ref(pic, obj, 2); - return analyze_defer(pic, scope, pic_false_value(), formals, body_exprs); + return analyze_defer(pic, scope, pic_false_value(), formals, body); } static pic_value @@ -558,31 +525,21 @@ analyze_define(pic_state *pic, analyze_scope *scope, pic_value obj) pic_value var, val; pic_sym *sym; - if (pic_length(pic, obj) != 3) { - pic_errorf(pic, "syntax error"); - } - - var = pic_list_ref(pic, obj, 1); - if (! pic_sym_p(var)) { - pic_errorf(pic, "syntax error"); - } else { - sym = pic_sym_ptr(var); - } + sym = pic_sym_ptr(pic_list_ref(pic, obj, 1)); var = analyze_declare(pic, scope, sym); if (pic_pair_p(pic_list_ref(pic, obj, 2)) && pic_sym_p(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) && pic_sym_ptr(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->uLAMBDA) { - pic_value formals, body_exprs; + pic_value formals, body; + + /* restore (define (foo ...) ...) structure */ formals = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 1); - body_exprs = pic_list_tail(pic, pic_list_ref(pic, obj, 2), 2); + body = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 2); - val = analyze_defer(pic, scope, pic_obj_value(sym), formals, body_exprs); + val = analyze_defer(pic, scope, pic_obj_value(sym), formals, body); } else { - if (pic_length(pic, obj) != 3) { - pic_errorf(pic, "syntax error"); - } val = analyze(pic, scope, pic_list_ref(pic, obj, 2), false); } @@ -594,18 +551,9 @@ analyze_if(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) { pic_value cond, if_true, if_false; - if_false = pic_undef_value(); - switch (pic_length(pic, obj)) { - default: - pic_errorf(pic, "syntax error"); - case 4: - if_false = pic_list_ref(pic, obj, 3); - PIC_FALLTHROUGH; - case 3: - if_true = pic_list_ref(pic, obj, 2); - } + if_true = pic_list_ref(pic, obj, 2); + if_false = pic_list_ref(pic, obj, 3); - /* analyze in order */ cond = analyze(pic, scope, pic_list_ref(pic, obj, 1), false); if_true = analyze(pic, scope, if_true, tailpos); if_false = analyze(pic, scope, if_false, tailpos); @@ -616,26 +564,15 @@ analyze_if(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) static pic_value analyze_begin(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) { - pic_value seq; - bool tail; + pic_value beg1, beg2; - switch (pic_length(pic, obj)) { - case 1: - return analyze(pic, scope, pic_undef_value(), tailpos); - case 2: - return analyze(pic, scope, pic_list_ref(pic, obj, 1), tailpos); - default: - seq = pic_list1(pic, pic_obj_value(pic->sBEGIN)); - for (obj = pic_cdr(pic, obj); ! pic_nil_p(obj); obj = pic_cdr(pic, obj)) { - if (pic_nil_p(pic_cdr(pic, obj))) { - tail = tailpos; - } else { - tail = false; - } - seq = pic_cons(pic, analyze(pic, scope, pic_car(pic, obj), tail), seq); - } - return pic_reverse(pic, seq); - } + beg1 = pic_list_ref(pic, obj, 1); + beg2 = pic_list_ref(pic, obj, 2); + + beg1 = analyze(pic, scope, beg1, false); + beg2 = analyze(pic, scope, beg2, tailpos); + + return pic_list3(pic, pic_obj_value(pic->sBEGIN), beg1, beg2); } static pic_value @@ -643,15 +580,7 @@ analyze_set(pic_state *pic, analyze_scope *scope, pic_value obj) { pic_value var, val; - if (pic_length(pic, obj) != 3) { - pic_errorf(pic, "syntax error"); - } - var = pic_list_ref(pic, obj, 1); - if (! pic_sym_p(var)) { - pic_errorf(pic, "syntax error"); - } - val = pic_list_ref(pic, obj, 2); var = analyze(pic, scope, var, false); @@ -663,9 +592,6 @@ analyze_set(pic_state *pic, analyze_scope *scope, pic_value obj) static pic_value analyze_quote(pic_state *pic, pic_value obj) { - if (pic_length(pic, obj) != 2) { - pic_errorf(pic, "syntax error"); - } return pic_list2(pic, pic_obj_value(pic->sQUOTE), pic_list_ref(pic, obj, 1)); } From ddcf96f6893fae6499962831e6fa2b4ed2f5efac Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 19:02:18 +0900 Subject: [PATCH 7/9] remove pic_proc_name (for a moment) --- contrib/10.callcc/callcc.c | 6 +-- extlib/benz/codegen.c | 71 +++++++++--------------------- extlib/benz/cont.c | 2 +- extlib/benz/debug.c | 2 +- extlib/benz/gc.c | 3 -- extlib/benz/include/picrin/error.h | 2 +- extlib/benz/include/picrin/irep.h | 1 - extlib/benz/include/picrin/proc.h | 4 +- extlib/benz/port.c | 2 +- extlib/benz/proc.c | 20 +-------- extlib/benz/reg.c | 2 +- extlib/benz/var.c | 2 +- extlib/benz/vm.c | 10 ++--- 13 files changed, 36 insertions(+), 91 deletions(-) diff --git a/contrib/10.callcc/callcc.c b/contrib/10.callcc/callcc.c index d4bed2e8..36ac9ed5 100644 --- a/contrib/10.callcc/callcc.c +++ b/contrib/10.callcc/callcc.c @@ -246,7 +246,7 @@ pic_callcc_full(pic_state *pic, struct pic_proc *proc) struct pic_proc *c; struct pic_data *dat; - c = pic_make_proc(pic, cont_call, ""); + c = pic_make_proc(pic, cont_call); dat = pic_data_alloc(pic, &cont_type, cont); @@ -270,7 +270,7 @@ pic_callcc_full_trampoline(pic_state *pic, struct pic_proc *proc) struct pic_proc *c; struct pic_data *dat; - c = pic_make_proc(pic, cont_call, ""); + c = pic_make_proc(pic, cont_call); dat = pic_data_alloc(pic, &cont_type, cont); @@ -292,7 +292,7 @@ pic_callcc_callcc(pic_state *pic) } #define pic_redefun(pic, lib, name, func) \ - pic_set(pic, lib, name, pic_obj_value(pic_make_proc(pic, func, name))) + pic_set(pic, lib, name, pic_obj_value(pic_make_proc(pic, func))) void pic_init_callcc(pic_state *pic) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index d539281e..75371b81 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -379,7 +379,7 @@ define_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) } static pic_value analyze_node(pic_state *, analyze_scope *, pic_value, bool); -static pic_value analyze_procedure(pic_state *, analyze_scope *, pic_value, pic_value, pic_value); +static pic_value analyze_procedure(pic_state *, analyze_scope *, pic_value, pic_value); static pic_value analyze(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) @@ -423,14 +423,14 @@ analyze_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) } static pic_value -analyze_defer(pic_state *pic, analyze_scope *scope, pic_value name, pic_value formal, pic_value body) +analyze_defer(pic_state *pic, analyze_scope *scope, pic_value formal, pic_value body) { pic_sym *sNOWHERE = pic_intern_cstr(pic, "<>"); pic_value skel; skel = pic_list2(pic, pic_obj_value(pic->sGREF), pic_obj_value(sNOWHERE)); - pic_push(pic, pic_list4(pic, name, formal, body, skel), scope->defer); + pic_push(pic, pic_list3(pic, formal, body, skel), scope->defer); return skel; } @@ -438,15 +438,14 @@ analyze_defer(pic_state *pic, analyze_scope *scope, pic_value name, pic_value fo static void analyze_deferred(pic_state *pic, analyze_scope *scope) { - pic_value defer, val, name, formal, body, dst, it; + pic_value defer, val, formal, body, dst, it; pic_for_each (defer, pic_reverse(pic, scope->defer), it) { - name = pic_list_ref(pic, defer, 0); - formal = pic_list_ref(pic, defer, 1); - body = pic_list_ref(pic, defer, 2); - dst = pic_list_ref(pic, defer, 3); + formal = pic_list_ref(pic, defer, 0); + body = pic_list_ref(pic, defer, 1); + dst = pic_list_ref(pic, defer, 2); - val = analyze_procedure(pic, scope, name, formal, body); + val = analyze_procedure(pic, scope, formal, body); /* copy */ pic_pair_ptr(dst)->car = pic_car(pic, val); @@ -457,15 +456,13 @@ analyze_deferred(pic_state *pic, analyze_scope *scope) } static pic_value -analyze_procedure(pic_state *pic, analyze_scope *up, pic_value name, pic_value formals, pic_value body) +analyze_procedure(pic_state *pic, analyze_scope *up, pic_value formals, pic_value body) { analyze_scope s, *scope = &s; pic_value rest = pic_undef_value(); pic_vec *args, *locals, *captures; size_t i, j; - assert(pic_sym_p(name) || pic_false_p(name)); - analyzer_scope_init(pic, scope, formals, up); /* analyze body */ @@ -497,7 +494,7 @@ analyze_procedure(pic_state *pic, analyze_scope *up, pic_value name, pic_value f analyzer_scope_destroy(pic, scope); - return pic_list7(pic, pic_obj_value(pic->sLAMBDA), name, rest, pic_obj_value(args), pic_obj_value(locals), pic_obj_value(captures), body); + return pic_list6(pic, pic_obj_value(pic->sLAMBDA), rest, pic_obj_value(args), pic_obj_value(locals), pic_obj_value(captures), body); } static pic_value @@ -508,7 +505,7 @@ analyze_lambda(pic_state *pic, analyze_scope *scope, pic_value obj) formals = pic_list_ref(pic, obj, 1); body = pic_list_ref(pic, obj, 2); - return analyze_defer(pic, scope, pic_false_value(), formals, body); + return analyze_defer(pic, scope, formals, body); } static pic_value @@ -523,25 +520,9 @@ static pic_value analyze_define(pic_state *pic, analyze_scope *scope, pic_value obj) { pic_value var, val; - pic_sym *sym; - sym = pic_sym_ptr(pic_list_ref(pic, obj, 1)); - var = analyze_declare(pic, scope, sym); - - if (pic_pair_p(pic_list_ref(pic, obj, 2)) - && pic_sym_p(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) - && pic_sym_ptr(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->uLAMBDA) { - pic_value formals, body; - - /* restore (define (foo ...) ...) structure */ - - formals = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 1); - body = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 2); - - val = analyze_defer(pic, scope, pic_obj_value(sym), formals, body); - } else { - val = analyze(pic, scope, pic_list_ref(pic, obj, 2), false); - } + var = analyze_declare(pic, scope, pic_sym_ptr(pic_list_ref(pic, obj, 1))); + val = analyze(pic, scope, pic_list_ref(pic, obj, 2), false); return pic_list3(pic, pic_obj_value(pic->sSETBANG), var, val); } @@ -893,7 +874,6 @@ pic_analyze(pic_state *pic, pic_value obj) } typedef struct codegen_context { - pic_sym *name; /* rest args variable is counted as a local */ pic_sym *rest; pic_vec *args, *locals, *captures; @@ -916,14 +896,9 @@ typedef struct codegen_context { static void create_activation(pic_state *, codegen_context *); static void -codegen_context_init(pic_state *pic, codegen_context *cxt, codegen_context *up, pic_value name, pic_sym *rest, pic_vec *args, pic_vec *locals, pic_vec *captures) +codegen_context_init(pic_state *pic, codegen_context *cxt, codegen_context *up, pic_sym *rest, pic_vec *args, pic_vec *locals, pic_vec *captures) { - assert(pic_sym_p(name) || pic_false_p(name)); - cxt->up = up; - cxt->name = pic_false_p(name) - ? pic_intern_cstr(pic, "(anonymous lambda)") - : pic_sym_ptr(name); cxt->rest = rest; cxt->args = args; @@ -956,7 +931,6 @@ codegen_context_destroy(pic_state *pic, codegen_context *cxt) /* create irep */ irep = (struct pic_irep *)pic_obj_alloc(pic, sizeof(struct pic_irep), PIC_TT_IREP); - irep->name = cxt->name; irep->varg = cxt->rest != NULL; irep->argc = (int)cxt->args->len + 1; irep->localc = (int)cxt->locals->len; @@ -1382,22 +1356,21 @@ static struct pic_irep * codegen_lambda(pic_state *pic, codegen_context *up, pic_value obj) { codegen_context c, *cxt = &c; - pic_value name, rest_opt, body; + pic_value rest_opt, body; pic_sym *rest = NULL; pic_vec *args, *locals, *captures; - name = pic_list_ref(pic, obj, 1); - rest_opt = pic_list_ref(pic, obj, 2); + rest_opt = pic_list_ref(pic, obj, 1); if (pic_sym_p(rest_opt)) { rest = pic_sym_ptr(rest_opt); } - args = pic_vec_ptr(pic_list_ref(pic, obj, 3)); - locals = pic_vec_ptr(pic_list_ref(pic, obj, 4)); - captures = pic_vec_ptr(pic_list_ref(pic, obj, 5)); - body = pic_list_ref(pic, obj, 6); + args = pic_vec_ptr(pic_list_ref(pic, obj, 2)); + locals = pic_vec_ptr(pic_list_ref(pic, obj, 3)); + captures = pic_vec_ptr(pic_list_ref(pic, obj, 4)); + body = pic_list_ref(pic, obj, 5); /* inner environment */ - codegen_context_init(pic, cxt, up, name, rest, args, locals, captures); + codegen_context_init(pic, cxt, up, rest, args, locals, captures); { /* body */ codegen(pic, cxt, body); @@ -1411,7 +1384,7 @@ pic_codegen(pic_state *pic, pic_value obj) pic_vec *empty = pic_make_vec(pic, 0); codegen_context c, *cxt = &c; - codegen_context_init(pic, cxt, NULL, pic_false_value(), NULL, empty, empty, empty); + codegen_context_init(pic, cxt, NULL, NULL, empty, empty, empty); codegen(pic, cxt, obj); diff --git a/extlib/benz/cont.c b/extlib/benz/cont.c index 132ed018..fe9947a3 100644 --- a/extlib/benz/cont.c +++ b/extlib/benz/cont.c @@ -121,7 +121,7 @@ pic_make_cont(pic_state *pic, struct pic_cont *cont) struct pic_proc *c; struct pic_data *e; - c = pic_make_proc(pic, cont_call, ""); + c = pic_make_proc(pic, cont_call); e = pic_data_alloc(pic, &cont_type, cont); diff --git a/extlib/benz/debug.c b/extlib/benz/debug.c index 2e7097cc..040b12a8 100644 --- a/extlib/benz/debug.c +++ b/extlib/benz/debug.c @@ -17,7 +17,7 @@ pic_get_backtrace(pic_state *pic) struct pic_proc *proc = pic_proc_ptr(ci->fp[0]); trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " at ")); - trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, pic_symbol_name(pic, pic_proc_name(proc)))); + trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, "(anonymous lambda)")); if (pic_proc_func_p(proc)) { trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (native function)\n")); diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index 55e1c040..b441d786 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -366,7 +366,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) gc_mark_object(pic, (struct pic_object *)proc->u.i.cxt); } } else { - gc_mark_object(pic, (struct pic_object *)proc->u.f.name); if (proc->u.f.env) { gc_mark_object(pic, (struct pic_object *)proc->u.f.env); } @@ -430,8 +429,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) struct pic_irep *irep = (struct pic_irep *)obj; size_t i; - gc_mark_object(pic, (struct pic_object *)irep->name); - for (i = 0; i < irep->ilen; ++i) { gc_mark_object(pic, (struct pic_object *)irep->irep[i]); } diff --git a/extlib/benz/include/picrin/error.h b/extlib/benz/include/picrin/error.h index 15fd57b4..b8de3442 100644 --- a/extlib/benz/include/picrin/error.h +++ b/extlib/benz/include/picrin/error.h @@ -35,7 +35,7 @@ struct pic_error *pic_make_error(pic_state *, pic_sym *, const char *, pic_list) if (PIC_SETJMP(pic, cont.jmp) == 0) { \ extern pic_value pic_native_exception_handler(pic_state *); \ struct pic_proc *handler; \ - handler = pic_make_proc(pic, pic_native_exception_handler, "(native-exception-handler)"); \ + handler = pic_make_proc(pic, pic_native_exception_handler); \ pic_proc_env_set(pic, handler, "cont", pic_obj_value(pic_make_cont(pic, &cont))); \ do { \ pic_push_handler(pic, handler); diff --git a/extlib/benz/include/picrin/irep.h b/extlib/benz/include/picrin/irep.h index daa639cc..200278ed 100644 --- a/extlib/benz/include/picrin/irep.h +++ b/extlib/benz/include/picrin/irep.h @@ -68,7 +68,6 @@ typedef struct { struct pic_irep { PIC_OBJECT_HEADER - pic_sym *name; pic_code *code; int argc, localc, capturec; bool varg; diff --git a/extlib/benz/include/picrin/proc.h b/extlib/benz/include/picrin/proc.h index bf1a0a4e..e5cc2bdb 100644 --- a/extlib/benz/include/picrin/proc.h +++ b/extlib/benz/include/picrin/proc.h @@ -26,7 +26,6 @@ struct pic_proc { union { struct { pic_func_t func; - pic_sym *name; struct pic_dict *env; } f; struct { @@ -45,10 +44,9 @@ struct pic_proc { #define pic_context_p(o) (pic_type(o) == PIC_TT_CXT) #define pic_context_ptr(o) ((struct pic_context *)pic_ptr(o)) -struct pic_proc *pic_make_proc(pic_state *, pic_func_t, const char *); +struct pic_proc *pic_make_proc(pic_state *, pic_func_t); struct pic_proc *pic_make_proc_irep(pic_state *, struct pic_irep *, struct pic_context *); -pic_sym *pic_proc_name(struct pic_proc *); struct pic_dict *pic_proc_env(pic_state *, struct pic_proc *); bool pic_proc_env_has(pic_state *, struct pic_proc *, const char *); pic_value pic_proc_env_ref(pic_state *, struct pic_proc *, const char *); diff --git a/extlib/benz/port.c b/extlib/benz/port.c index 3ad3702c..bc5ab406 100644 --- a/extlib/benz/port.c +++ b/extlib/benz/port.c @@ -154,7 +154,7 @@ pic_define_standard_port(pic_state *pic, const char *name, xFILE *file, int dir) port->file = file; port->flags = dir | PIC_PORT_TEXT | PIC_PORT_OPEN; - pic_defvar(pic, name, pic_obj_value(port), pic_make_proc(pic, pic_assert_port, "pic_assert_port")); + pic_defvar(pic, name, pic_obj_value(port), pic_make_proc(pic, pic_assert_port)); } #define DEFINE_STANDARD_PORT_ACCESSOR(name, var) \ diff --git a/extlib/benz/proc.c b/extlib/benz/proc.c index 9e5713c1..ea8d71d1 100644 --- a/extlib/benz/proc.c +++ b/extlib/benz/proc.c @@ -5,19 +5,13 @@ #include "picrin.h" struct pic_proc * -pic_make_proc(pic_state *pic, pic_func_t func, const char *name) +pic_make_proc(pic_state *pic, pic_func_t func) { struct pic_proc *proc; - pic_sym *sym; - - assert(name != NULL); - - sym = pic_intern_cstr(pic, name); proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC); proc->tag = PIC_PROC_TAG_FUNC; proc->u.f.func = func; - proc->u.f.name = sym; proc->u.f.env = NULL; return proc; } @@ -34,18 +28,6 @@ pic_make_proc_irep(pic_state *pic, struct pic_irep *irep, struct pic_context *cx return proc; } -pic_sym * -pic_proc_name(struct pic_proc *proc) -{ - switch (proc->tag) { - case PIC_PROC_TAG_FUNC: - return proc->u.f.name; - case PIC_PROC_TAG_IREP: - return proc->u.i.irep->name; - } - PIC_UNREACHABLE(); -} - struct pic_dict * pic_proc_env(pic_state *pic, struct pic_proc *proc) { diff --git a/extlib/benz/reg.c b/extlib/benz/reg.c index c5268b2e..d72aceaf 100644 --- a/extlib/benz/reg.c +++ b/extlib/benz/reg.c @@ -118,7 +118,7 @@ pic_reg_make_register(pic_state *pic) reg = pic_make_reg(pic); - proc = pic_make_proc(pic, reg_call, ""); + proc = pic_make_proc(pic, reg_call); pic_proc_env_set(pic, proc, "reg", pic_obj_value(reg)); diff --git a/extlib/benz/var.c b/extlib/benz/var.c index 5fd44c0b..b1b6f66c 100644 --- a/extlib/benz/var.c +++ b/extlib/benz/var.c @@ -61,7 +61,7 @@ pic_make_var(pic_state *pic, pic_value init, struct pic_proc *conv) { struct pic_proc *var; - var = pic_make_proc(pic, var_call, ""); + var = pic_make_proc(pic, var_call); if (conv != NULL) { pic_proc_env_set(pic, var, "conv", pic_obj_value(conv)); diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index 47044312..0ccec5ba 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -82,11 +82,7 @@ pic_get_args(pic_state *pic, const char *format, ...) /* check argc. */ if (argc < paramc || (paramc + optc < argc && ! rest)) { - pic_errorf(pic, "%s: wrong number of arguments (%d for %s%d)", - pic_symbol_name(pic, pic_proc_name(pic_proc_ptr(GET_OPERAND(pic, 0)))) , - argc, - rest? "at least " : "", - paramc); + pic_errorf(pic, "pic_get_args: wrong number of arguments (%d for %s%d)", argc, rest? "at least " : "", paramc); } /* start dispatching */ @@ -1131,7 +1127,7 @@ pic_defun_vm(pic_state *pic, const char *name, pic_sym *uid, pic_func_t func) struct pic_proc *proc; pic_sym *sym; - proc = pic_make_proc(pic, func, name); + proc = pic_make_proc(pic, func); sym = pic_intern_cstr(pic, name); @@ -1168,7 +1164,7 @@ pic_define(pic_state *pic, const char *name, pic_value val) void pic_defun_(pic_state *pic, const char *name, pic_func_t cfunc) { - pic_define_(pic, name, pic_obj_value(pic_make_proc(pic, cfunc, name))); + pic_define_(pic, name, pic_obj_value(pic_make_proc(pic, cfunc))); } void From 885942b541291f05b414074a1245e225b9ed40e9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 19:10:15 +0900 Subject: [PATCH 8/9] more cleanup --- extlib/benz/codegen.c | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 75371b81..0261105d 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -508,20 +508,14 @@ analyze_lambda(pic_state *pic, analyze_scope *scope, pic_value obj) return analyze_defer(pic, scope, formals, body); } -static pic_value -analyze_declare(pic_state *pic, analyze_scope *scope, pic_sym *var) -{ - define_var(pic, scope, var); - - return analyze_var(pic, scope, var); -} - static pic_value analyze_define(pic_state *pic, analyze_scope *scope, pic_value obj) { pic_value var, val; - var = analyze_declare(pic, scope, pic_sym_ptr(pic_list_ref(pic, obj, 1))); + define_var(pic, scope, pic_sym_ptr(pic_list_ref(pic, obj, 1))); + + var = analyze(pic, scope, pic_list_ref(pic, obj, 1), false); val = analyze(pic, scope, pic_list_ref(pic, obj, 2), false); return pic_list3(pic, pic_obj_value(pic->sSETBANG), var, val); From 3428803bdb7917c00130d3ba095d2039b709e8a6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 27 Jun 2015 19:19:43 +0900 Subject: [PATCH 9/9] less consing --- extlib/benz/codegen.c | 38 +++++++++++++++----------------------- 1 file changed, 15 insertions(+), 23 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index 0261105d..d9be026a 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -379,7 +379,7 @@ define_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) } static pic_value analyze_node(pic_state *, analyze_scope *, pic_value, bool); -static pic_value analyze_procedure(pic_state *, analyze_scope *, pic_value, pic_value); +static pic_value analyze_procedure(pic_state *, analyze_scope *, pic_value); static pic_value analyze(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) @@ -423,14 +423,14 @@ analyze_var(pic_state *pic, analyze_scope *scope, pic_sym *sym) } static pic_value -analyze_defer(pic_state *pic, analyze_scope *scope, pic_value formal, pic_value body) +analyze_defer(pic_state *pic, analyze_scope *scope, pic_value form) { pic_sym *sNOWHERE = pic_intern_cstr(pic, "<>"); pic_value skel; skel = pic_list2(pic, pic_obj_value(pic->sGREF), pic_obj_value(sNOWHERE)); - pic_push(pic, pic_list3(pic, formal, body, skel), scope->defer); + pic_push(pic, pic_cons(pic, skel, form), scope->defer); return skel; } @@ -438,31 +438,34 @@ analyze_defer(pic_state *pic, analyze_scope *scope, pic_value formal, pic_value static void analyze_deferred(pic_state *pic, analyze_scope *scope) { - pic_value defer, val, formal, body, dst, it; + pic_value defer, it, skel, form, val; pic_for_each (defer, pic_reverse(pic, scope->defer), it) { - formal = pic_list_ref(pic, defer, 0); - body = pic_list_ref(pic, defer, 1); - dst = pic_list_ref(pic, defer, 2); + skel = pic_car(pic, defer); + form = pic_cdr(pic, defer); - val = analyze_procedure(pic, scope, formal, body); + val = analyze_procedure(pic, scope, form); /* copy */ - pic_pair_ptr(dst)->car = pic_car(pic, val); - pic_pair_ptr(dst)->cdr = pic_cdr(pic, val); + pic_pair_ptr(skel)->car = pic_car(pic, val); + pic_pair_ptr(skel)->cdr = pic_cdr(pic, val); } scope->defer = pic_nil_value(); } static pic_value -analyze_procedure(pic_state *pic, analyze_scope *up, pic_value formals, pic_value body) +analyze_procedure(pic_state *pic, analyze_scope *up, pic_value form) { analyze_scope s, *scope = &s; + pic_value formals, body; pic_value rest = pic_undef_value(); pic_vec *args, *locals, *captures; size_t i, j; + formals = pic_list_ref(pic, form, 1); + body = pic_list_ref(pic, form, 2); + analyzer_scope_init(pic, scope, formals, up); /* analyze body */ @@ -497,17 +500,6 @@ analyze_procedure(pic_state *pic, analyze_scope *up, pic_value formals, pic_valu return pic_list6(pic, pic_obj_value(pic->sLAMBDA), rest, pic_obj_value(args), pic_obj_value(locals), pic_obj_value(captures), body); } -static pic_value -analyze_lambda(pic_state *pic, analyze_scope *scope, pic_value obj) -{ - pic_value formals, body; - - formals = pic_list_ref(pic, obj, 1); - body = pic_list_ref(pic, obj, 2); - - return analyze_defer(pic, scope, formals, body); -} - static pic_value analyze_define(pic_state *pic, analyze_scope *scope, pic_value obj) { @@ -762,7 +754,7 @@ analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) return analyze_define(pic, scope, obj); } else if (sym == pic->uLAMBDA) { - return analyze_lambda(pic, scope, obj); + return analyze_defer(pic, scope, obj); } else if (sym == pic->uIF) { return analyze_if(pic, scope, obj, tailpos);