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

Merge branch 'core-syntaxes-in-scheme'

This commit is contained in:
Yuichi Nishiwaki 2015-06-27 23:01:36 +09:00
parent 8c6496ef24 3428803bdb
commit a6ec857f98
15 changed files with 515 additions and 558 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
contrib/10.callcc/callcc.c
View File

@ -246,7 +246,7 @@ pic_callcc_full(pic_state *pic, struct pic_proc *proc)
struct pic_proc *c; struct pic_proc *c;
struct pic_data *dat; struct pic_data *dat;
c = pic_make_proc(pic, cont_call, "<continuation-procedure>"); c = pic_make_proc(pic, cont_call);
dat = pic_data_alloc(pic, &cont_type, cont); 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_proc *c;
struct pic_data *dat; struct pic_data *dat;
c = pic_make_proc(pic, cont_call, "<continuation-procedure>"); c = pic_make_proc(pic, cont_call);
dat = pic_data_alloc(pic, &cont_type, cont); 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) \ #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 void
pic_init_callcc(pic_state *pic) pic_init_callcc(pic_state *pic)

652
extlib/benz/boot.c
View File

@ -8,25 +8,118 @@ use strict;
my $src = <<'EOL'; my $src = <<'EOL';
(define-macro call-with-current-environment (builtin:define-macro call-with-current-environment
(lambda (form env) (builtin:lambda (form env)
(list (cadr form) env))) (list (cadr form) env)))
(define here (builtin:define here
(call-with-current-environment (call-with-current-environment
(lambda (env) (builtin:lambda (env)
env))) env)))
(define (the var) ; synonym for #'var (builtin:define the ; synonym for #'var
(make-identifier var here)) (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 "define: binding to non-varaible object" 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 "define-macro: binding to non-variable object" 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 (define-macro syntax-error
(lambda (form _) (lambda (form _)
@ -623,251 +716,294 @@ EOL
#endif #endif
const char pic_boot[][80] = { const char pic_boot[][80] = {
"\n(define-macro call-with-current-environment\n (lambda (form env)\n (list (cad", "\n(builtin:define-macro call-with-current-environment\n (builtin:lambda (form env",
"r form) env)))\n\n(define here\n (call-with-current-environment\n (lambda (env)\n ", ")\n (list (cadr form) env)))\n\n(builtin:define here\n (call-with-current-enviro",
" env)))\n\n(define (the var) ; synonym for #'var\n (make-id", "nment\n (builtin:lambda (env)\n env)))\n\n(builtin:define the ",
"entifier var here))\n\n(define the-define (the 'define))\n(define the-lambda (the '", " ; synonym for #'var\n (builtin:lambda (var)\n (make-identifier var here)))",
"lambda))\n(define the-begin (the 'begin))\n(define the-quote (the 'quote))\n(define", "\n\n\n(builtin:define the-builtin-define (the (builtin:quote builtin:define)))\n(bui",
" the-set! (the 'set!))\n(define the-if (the 'if))\n(define the-define-macro (the '", "ltin:define the-builtin-lambda (the (builtin:quote builtin:lambda)))\n(builtin:de",
"define-macro))\n\n(define-macro syntax-error\n (lambda (form _)\n (apply error (", "fine the-builtin-begin (the (builtin:quote builtin:begin)))\n(builtin:define the-",
"cdr form))))\n\n(define-macro define-auxiliary-syntax\n (lambda (form _)\n (defi", "builtin-quote (the (builtin:quote builtin:quote)))\n(builtin:define the-builtin-s",
"ne message\n (string-append\n \"invalid use of auxiliary syntax: '\" (sym", "et! (the (builtin:quote builtin:set!)))\n(builtin:define the-builtin-if (the (bui",
"bol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (cadr form)\n", "ltin:quote builtin:if)))\n(builtin:define the-builtin-define-macro (the (builtin:",
" (list the-lambda '_\n (list (the 'error) message)))))\n\n(define-aux", "quote builtin:define-macro)))\n\n(builtin:define the-define (the (builtin:quote de",
"iliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-auxiliary-syntax unquot", "fine)))\n(builtin:define the-lambda (the (builtin:quote lambda)))\n(builtin:define",
"e)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxiliary-syntax syntax-un", " the-begin (the (builtin:quote begin)))\n(builtin:define the-quote (the (builtin:",
"quote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(define-macro let\n (l", "quote quote)))\n(builtin:define the-set! (the (builtin:quote set!)))\n(builtin:def",
"ambda (form env)\n (if (variable? (cadr form))\n (list\n (list th", "ine the-if (the (builtin:quote if)))\n(builtin:define the-define-macro (the (buil",
"e-lambda '()\n (list the-define (cadr form)\n (c", "tin:quote define-macro)))\n\n(builtin:define-macro quote\n (builtin:lambda (form e",
"ons the-lambda\n (cons (map car (car (cddr form)))\n ", "nv)\n (builtin:if (= (length form) 2)\n (list the-builtin-quote (cadr form",
" (cdr (cddr form)))))\n (cons (cadr for", "))\n (error \"illegal quote form\" form))))\n\n(builtin:define-macro if\n (built",
"m) (map cadr (car (cddr form))))))\n (cons\n (cons\n the-la", "in:lambda (form env)\n ((builtin:lambda (len)\n (builtin:if (= len 4)\n ",
"mbda\n (cons (map car (cadr form))\n (cddr form)))\n ", " (cons the-builtin-if (cdr form))\n (builtin:if (= len 3)\n ",
" (map cadr (cadr form))))))\n\n(define-macro and\n (lambda (form env)\n (if (nu", " (list the-builtin-if (list-ref form 1) (list-ref form 2) #undefined)\n ",
"ll? (cdr form))\n #t\n (if (null? (cddr form))\n (cadr for", " (error \"illegal if form\" form))))\n (length form))))\n\n(builtin:d",
"m)\n (list the-if\n (cadr form)\n (con", "efine-macro begin\n (builtin:lambda (form env)\n ((builtin:lambda (len)\n ",
"s (the 'and) (cddr form))\n #f)))))\n\n(define-macro or\n (lambda ", " (if (= len 1)\n #undefined\n (if (= len 2)\n (ca",
"(form env)\n (if (null? (cdr form))\n #f\n (let ((tmp (make-identi", "dr form)\n (if (= len 3)\n (cons the-builtin-begin",
"fier 'it env)))\n (list (the 'let)\n (list (list tmp (cadr", " (cdr form))\n (list the-builtin-begin\n ",
" form)))\n (list the-if\n tmp\n ", " (cadr form)\n (cons the-begin (cddr form)))))))\n (le",
" tmp\n (cons (the 'or) (cddr form))))))))\n\n(define-macr", "ngth form))))\n\n(builtin:define-macro set!\n (builtin:lambda (form env)\n (if (",
"o cond\n (lambda (form env)\n (let ((clauses (cdr form)))\n (if (null? cla", "= (length form) 3)\n (if (variable? (cadr form))\n (cons the-bui",
"uses)\n #undefined\n (let ((clause (car clauses)))\n (", "ltin-set! (cdr form))\n (error \"illegal set! form\" form))\n (err",
"if (and (variable? (car clause))\n (variable=? (the 'else) (m", "or \"illegal set! form\" form))))\n\n(builtin:define check-formal\n (builtin:lambda ",
"ake-identifier (car clause) env)))\n (cons the-begin (cdr clause))", "(formal)\n (if (null? formal)\n #t\n (if (variable? formal)\n ",
"\n (if (and (variable? (cadr clause))\n (va", " #t\n (if (pair? formal)\n (if (variable? (car form",
"riable=? (the '=>) (make-identifier (cadr clause) env)))\n (le", "al))\n (check-formal (cdr formal))\n #f)\n ",
"t ((tmp (make-identifier 'tmp here)))\n (list (the 'let) (li", " #f)))))\n\n(builtin:define-macro lambda\n (builtin:lambda (form env)\n",
"st (list tmp (car clause)))\n (list the-if tmp\n ", " (if (= (length form) 1)\n (error \"illegal lambda form\" form)\n (",
" (list (car (cddr clause)) tmp)\n ", "if (check-formal (cadr form))\n (list the-builtin-lambda (cadr form) (",
" (cons (the 'cond) (cdr clauses)))))\n (list the-if", "cons the-begin (cddr form)))\n (error \"illegal lambda form\" form)))))\n",
" (car clause)\n (cons the-begin (cdr clause))\n ", "\n(builtin:define-macro define\n (lambda (form env)\n ((lambda (len)\n (if",
" (cons (the 'cond) (cdr clauses))))))))))\n\n(define-macro quasiquo", " (= len 1)\n (error \"illegal define form\" form)\n (if (variabl",
"te\n (lambda (form env)\n\n (define (quasiquote? form)\n (and (pair? form)\n", "e? (cadr form))\n (if (= len 3)\n (cons the-builti",
" (variable? (car form))\n (variable=? (the 'quasiquote) (make", "n-define (cdr form))\n (error \"illegal define form\" form))\n ",
"-identifier (car form) env))))\n\n (define (unquote? form)\n (and (pair? fo", " (if (pair? (cadr form))\n (list the-define\n ",
"rm)\n (variable? (car form))\n (variable=? (the 'unquote) (mak", " (car (cadr form))\n (cons the-lambda (con",
"e-identifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and", "s (cdr (cadr form)) (cddr form))))\n (error \"define: binding to",
" (pair? form)\n (pair? (car form))\n (variable? (caar form))\n ", " non-varaible object\" form)))))\n (length form))))\n\n(builtin:define-macro def",
" (variable=? (the 'unquote-splicing) (make-identifier (caar form) env))", "ine-macro\n (lambda (form env)\n (if (= (length form) 3)\n (if (variable",
"))\n\n (define (qq depth expr)\n (cond\n ;; unquote\n ((unquote? ", "? (cadr form))\n (cons the-builtin-define-macro (cdr form))\n ",
"expr)\n (if (= depth 1)\n (car (cdr expr))\n (list (th", " (error \"define-macro: binding to non-variable object\" form))\n (error \"i",
"e 'list)\n (list (the 'quote) (the 'unquote))\n ", "llegal define-macro form\" form))))\n\n\n(define-macro syntax-error\n (lambda (form ",
"(qq (- depth 1) (car (cdr expr))))))\n ;; unquote-splicing\n ((unquote", "_)\n (apply error (cdr form))))\n\n(define-macro define-auxiliary-syntax\n (lamb",
"-splicing? expr)\n (if (= depth 1)\n (list (the 'append)\n ", "da (form _)\n (define message\n (string-append\n \"invalid use of auxi",
" (car (cdr (car expr)))\n (qq depth (cdr expr)))\n ", "liary syntax: '\" (symbol->string (cadr form)) \"'\"))\n (list\n the-define-ma",
" (list (the 'cons)\n (list (the 'list)\n ", "cro\n (cadr form)\n (list the-lambda '_\n (list (the 'error) mess",
" (list (the 'quote) (the 'unquote-splicing))\n (qq (- ", "age)))))\n\n(define-auxiliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-au",
"depth 1) (car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ", "xiliary-syntax unquote)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxil",
" ;; quasiquote\n ((quasiquote? expr)\n (list (the 'list)\n ", "iary-syntax syntax-unquote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(",
" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) (car (c", "define-macro let\n (lambda (form env)\n (if (variable? (cadr form))\n (l",
"dr expr)))))\n ;; list\n ((pair? expr)\n (list (the 'cons)\n ", "ist\n (list the-lambda '()\n (list the-define (cadr form)\n ",
" (qq depth (car expr))\n (qq depth (cdr expr))))\n ;; v", " (cons the-lambda\n (cons (map car (c",
"ector\n ((vector? expr)\n (list (the 'list->vector) (qq depth (vector", "ar (cddr form)))\n (cdr (cddr form)))))\n ",
"->list expr))))\n ;; simple datum\n (else\n (list (the 'quote) e", " (cons (cadr form) (map cadr (car (cddr form))))))\n (cons\n (",
"xpr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(define-macro let*\n (lam", "cons\n the-lambda\n (cons (map car (cadr form))\n ",
"bda (form env)\n (let ((bindings (car (cdr form)))\n (body (cdr (c", "(cddr form)))\n (map cadr (cadr form))))))\n\n(define-macro and\n (lambda (",
"dr form))))\n (if (null? bindings)\n `(,(the 'let) () ,@body)\n ", "form env)\n (if (null? (cdr form))\n #t\n (if (null? (cddr form))\n",
" `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n (", " (cadr form)\n (list the-if\n (cadr form)\n ",
",(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n(define-macro letrec\n", " (cons (the 'and) (cddr form))\n #f)))))\n\n(defin",
" (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n\n(define-macro letrec", "e-macro or\n (lambda (form env)\n (if (null? (cdr form))\n #f\n (l",
"*\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ", "et ((tmp (make-identifier 'it env)))\n (list (the 'let)\n ",
" (cdr (cdr form))))\n (let ((variables (map (lambda (v) `(,v #f)) (map car b", "(list (list tmp (cadr form)))\n (list the-if\n ",
"indings)))\n (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings", " tmp\n tmp\n (cons (the 'or) (cddr form)",
")))\n `(,(the 'let) (,@variables)\n ,@initials\n ,@body)))", ")))))))\n\n(define-macro cond\n (lambda (form env)\n (let ((clauses (cdr form)))",
"))\n\n(define-macro let-values\n (lambda (form env)\n `(,(the 'let*-values) ,@(c", "\n (if (null? clauses)\n #undefined\n (let ((clause (car cla",
"dr form))))\n\n(define-macro let*-values\n (lambda (form env)\n (let ((formal (c", "uses)))\n (if (and (variable? (car clause))\n (vari",
"ar (cdr form)))\n (body (cdr (cdr form))))\n (if (null? formal)\n ", "able=? (the 'else) (make-identifier (car clause) env)))\n (cons th",
" `(,(the 'let) () ,@body)\n `(,(the 'call-with-values) (,the-lamb", "e-begin (cdr clause))\n (if (and (variable? (cadr clause))\n ",
"da () ,@(cdr (car formal)))\n (,(the 'lambda) (,@(car (car formal)))\n ", " (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ",
" (,(the 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n(", " (let ((tmp (make-identifier 'tmp here)))\n ",
"define-macro define-values\n (lambda (form env)\n (let ((formal (car (cdr form", " (list (the 'let) (list (list tmp (car clause)))\n (li",
")))\n (body (cdr (cdr form))))\n (let ((arguments (make-identifier", "st the-if tmp\n (list (car (cddr clause)) tmp)\n ",
" 'arguments here)))\n `(,the-begin\n ,@(let loop ((formal formal))", " (cons (the 'cond) (cdr clauses)))))\n ",
"\n (if (pair? formal)\n `((,the-define ,(car formal)", " (list the-if (car clause)\n (cons the-begin (cd",
" #undefined) ,@(loop (cdr formal)))\n (if (variable? formal)\n ", "r clause))\n (cons (the 'cond) (cdr clauses))))))))))\n\n(",
" `((,the-define ,formal #undefined))\n '()", "define-macro quasiquote\n (lambda (form env)\n\n (define (quasiquote? form)\n ",
")))\n (,(the 'call-with-values) (,the-lambda () ,@body)\n (,the", " (and (pair? form)\n (variable? (car form))\n (variable=? (t",
"-lambda\n ,arguments\n ,@(let loop ((formal formal) (args ar", "he 'quasiquote) (make-identifier (car form) env))))\n\n (define (unquote? form)",
"guments))\n (if (pair? formal)\n `((,the-set! ,(", "\n (and (pair? form)\n (variable? (car form))\n (variable=",
"car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))\n ", "? (the 'unquote) (make-identifier (car form) env))))\n\n (define (unquote-splic",
" (if (variable? formal)\n `((,the-set! ,fo", "ing? form)\n (and (pair? form)\n (pair? (car form))\n (var",
"rmal ,args))\n '()))))))))))\n\n(define-macro do\n (lambda (", "iable? (caar form))\n (variable=? (the 'unquote-splicing) (make-identif",
"form env)\n (let ((bindings (car (cdr form)))\n (test (car (car (c", "ier (caar form) env))))\n\n (define (qq depth expr)\n (cond\n ;; unquo",
"dr (cdr form)))))\n (cleanup (cdr (car (cdr (cdr form)))))\n (b", "te\n ((unquote? expr)\n (if (= depth 1)\n (car (cdr expr))\n",
"ody (cdr (cdr (cdr form)))))\n (let ((loop (make-identifier 'loop here))", " (list (the 'list)\n (list (the 'quote) (the 'unquote",
")\n `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings)", "))\n (qq (- depth 1) (car (cdr expr))))))\n ;; unquote-spli",
"\n (,the-if ,test\n (,the-begin\n ,@c", "cing\n ((unquote-splicing? expr)\n (if (= depth 1)\n (list ",
"leanup)\n (,the-begin\n ,@body\n ", "(the 'append)\n (car (cdr (car expr)))\n (qq dep",
" (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car x) (car (cdr (cdr", "th (cdr expr)))\n (list (the 'cons)\n (list (the 'list",
" x))))) bindings)))))))))\n\n(define-macro when\n (lambda (form env)\n (let ((te", ")\n (list (the 'quote) (the 'unquote-splicing))\n ",
"st (car (cdr form)))\n (body (cdr (cdr form))))\n `(,the-if ,test\n ", " (qq (- depth 1) (car (cdr (car expr)))))\n (qq dep",
" (,the-begin ,@body)\n #undefined))))\n\n(define-macro ", "th (cdr expr)))))\n ;; quasiquote\n ((quasiquote? expr)\n (list ",
"unless\n (lambda (form env)\n (let ((test (car (cdr form)))\n (body (c", "(the 'list)\n (list (the 'quote) (the 'quasiquote))\n (q",
"dr (cdr form))))\n `(,the-if ,test\n #undefined\n ", "q (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n (l",
" (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (form env)\n (let ((ke", "ist (the 'cons)\n (qq depth (car expr))\n (qq depth (cdr",
"y (car (cdr form)))\n (clauses (cdr (cdr form))))\n (let ((the-k", " expr))))\n ;; vector\n ((vector? expr)\n (list (the 'list->vect",
"ey (make-identifier 'key here)))\n `(,(the 'let) ((,the-key ,key))\n ", "or) (qq depth (vector->list expr))))\n ;; simple datum\n (else\n ",
" ,(let loop ((clauses clauses))\n (if (null? clauses)\n ", " (list (the 'quote) expr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(def",
" #undefined\n (let ((clause (car clauses)))\n ", "ine-macro let*\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n ",
" `(,the-if ,(if (and (variable? (car clause))\n ", " (body (cdr (cdr form))))\n (if (null? bindings)\n `(,(the 'l",
" (variable=? (the 'else) (make-identifier (car clause) env)))\n ", "et) () ,@body)\n `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindi",
" #t\n `(,(the 'or) ,@(map (la", "ngs))))\n (,(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n",
"mbda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ", "(define-macro letrec\n (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n",
" ,(if (and (variable? (cadr clause))\n ", "\n(define-macro letrec*\n (lambda (form env)\n (let ((bindings (car (cdr form))",
" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ", ")\n (body (cdr (cdr form))))\n (let ((variables (map (lambda (v)",
" `(,(car (cdr (cdr clause))) ,the-key)\n ", " `(,v #f)) (map car bindings)))\n (initials (map (lambda (v) `(,(the ",
" `(,the-begin ,@(cdr clause)))\n ,(lo", "'set!) ,@v)) bindings)))\n `(,(the 'let) (,@variables)\n ,@initial",
"op (cdr clauses)))))))))))\n\n(define-macro parameterize\n (lambda (form env)\n ", "s\n ,@body)))))\n\n(define-macro let-values\n (lambda (form env)\n `(,(t",
"(let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(,(t", "he 'let*-values) ,@(cdr form))))\n\n(define-macro let*-values\n (lambda (form env)",
"he 'with-parameter)\n (,(the 'lambda) ()\n ,@formal\n ,@body", "\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n ",
")))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (let ((renames '()))\n", "(if (null? formal)\n `(,(the 'let) () ,@body)\n `(,(the 'call-wi",
" (letrec\n ((rename (lambda (var)\n (let ((x (as", "th-values) (,the-lambda () ,@(cdr (car formal)))\n (,(the 'lambda) (,@",
"sq var renames)))\n (if x\n (cadr ", "(car (car formal)))\n (,(the 'let*-values) (,@(cdr formal))\n ",
"x)\n (begin\n (set! renames ", " ,@body)))))))\n\n(define-macro define-values\n (lambda (form env)\n (let ((",
"`((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,ren", "formal (car (cdr form)))\n (body (cdr (cdr form))))\n (let ((argum",
"ames))\n (rename var))))))\n (walk (lambda (", "ents (make-identifier 'arguments here)))\n `(,the-begin\n ,@(let l",
"f form)\n (cond\n ((variable? form)\n ", "oop ((formal formal))\n (if (pair? formal)\n `((,the",
" (f form))\n ((pair? form)\n `(,", "-define ,(car formal) #undefined) ,@(loop (cdr formal)))\n (if (",
"(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ((vect", "variable? formal)\n `((,the-define ,formal #undefined))\n ",
"or? form)\n `(,(the 'list->vector) (walk f (vector->list form", " '())))\n (,(the 'call-with-values) (,the-lambda () ,@b",
"))))\n (else\n `(,(the 'quote) ,form))))))\n", "ody)\n (,the-lambda\n ,arguments\n ,@(let loop ((fo",
" (let ((form (walk rename (cadr form))))\n `(,(the 'let)\n ", "rmal formal) (args arguments))\n (if (pair? formal)\n ",
" ,(map cdr renames)\n ,form))))))\n\n(define-macro syntax-quasiquote\n", " `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(t",
" (lambda (form env)\n (let ((renames '()))\n (letrec\n ((rename (", "he 'cdr) ,args)))\n (if (variable? formal)\n ",
"lambda (var)\n (let ((x (assq var renames)))\n ", " `((,the-set! ,formal ,args))\n '()))))))))))\n\n(define",
" (if x\n (cadr x)\n (beg", "-macro do\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (",
"in\n (set! renames `((,var ,(make-identifier var env)", "test (car (car (cdr (cdr form)))))\n (cleanup (cdr (car (cdr (cdr f",
" (,(the 'make-identifier) ',var ',env)) . ,renames))\n ", "orm)))))\n (body (cdr (cdr (cdr form)))))\n (let ((loop (make-id",
" (rename var)))))))\n\n (define (syntax-quasiquote? form)\n (and (", "entifier 'loop here)))\n `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ",
"pair? form)\n (variable? (car form))\n (variable=? (th", ",(cadr x))) bindings)\n (,the-if ,test\n (,the-begin\n ",
"e 'syntax-quasiquote) (make-identifier (car form) env))))\n\n (define (synt", " ,@cleanup)\n (,the-begin\n ",
"ax-unquote? form)\n (and (pair? form)\n (variable? (car for", ",@body\n (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (",
"m))\n (variable=? (the 'syntax-unquote) (make-identifier (car form)", "car x) (car (cdr (cdr x))))) bindings)))))))))\n\n(define-macro when\n (lambda (fo",
" env))))\n\n (define (syntax-unquote-splicing? form)\n (and (pair? ", "rm env)\n (let ((test (car (cdr form)))\n (body (cdr (cdr form))))\n ",
"form)\n (pair? (car form))\n (variable? (caar form))\n ", " `(,the-if ,test\n (,the-begin ,@body)\n #undefine",
" (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar ", "d))))\n\n(define-macro unless\n (lambda (form env)\n (let ((test (car (cdr form)",
"form) env))))\n\n (define (qq depth expr)\n (cond\n ;; syn", "))\n (body (cdr (cdr form))))\n `(,the-if ,test\n #und",
"tax-unquote\n ((syntax-unquote? expr)\n (if (= depth 1)\n ", "efined\n (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (fo",
" (car (cdr expr))\n (list (the 'list)\n ", "rm env)\n (let ((key (car (cdr form)))\n (clauses (cdr (cdr form))",
" (list (the 'quote) (the 'syntax-unquote))\n (qq (- depth", "))\n (let ((the-key (make-identifier 'key here)))\n `(,(the 'let) ((,t",
" 1) (car (cdr expr))))))\n ;; syntax-unquote-splicing\n ((synt", "he-key ,key))\n ,(let loop ((clauses clauses))\n (if (null? c",
"ax-unquote-splicing? expr)\n (if (= depth 1)\n (list (th", "lauses)\n #undefined\n (let ((clause (car clauses)",
"e 'append)\n (car (cdr (car expr)))\n (q", "))\n `(,the-if ,(if (and (variable? (car clause))\n ",
"q depth (cdr expr)))\n (list (the 'cons)\n (li", " (variable=? (the 'else) (make-identifier (car clause) ",
"st (the 'list)\n (list (the 'quote) (the 'syntax-unquo", "env)))\n #t\n `(",
"te-splicing))\n (qq (- depth 1) (car (cdr (car expr)))", ",(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car cla",
"))\n (qq depth (cdr expr)))))\n ;; syntax-quasiquot", "use))))\n ,(if (and (variable? (cadr clause))\n ",
"e\n ((syntax-quasiquote? expr)\n (list (the 'list)\n ", " (variable=? (the '=>) (make-identifier (cadr cla",
" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) ", "use) env)))\n `(,(car (cdr (cdr clause))) ,the-k",
"(car (cdr expr)))))\n ;; list\n ((pair? expr)\n (lis", "ey)\n `(,the-begin ,@(cdr clause)))\n ",
"t (the 'cons)\n (qq depth (car expr))\n (qq dept", " ,(loop (cdr clauses)))))))))))\n\n(define-macro parameterize\n (l",
"h (cdr expr))))\n ;; vector\n ((vector? expr)\n (lis", "ambda (form env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr",
"t (the 'list->vector) (qq depth (vector->list expr))))\n ;; variable\n ", " form))))\n `(,(the 'with-parameter)\n (,(the 'lambda) ()\n ,@f",
" ((variable? expr)\n (rename expr))\n ;; simple datum", "ormal\n ,@body)))))\n\n(define-macro syntax-quote\n (lambda (form env)\n ",
"\n (else\n (list (the 'quote) expr))))\n\n (let ((body (", "(let ((renames '()))\n (letrec\n ((rename (lambda (var)\n ",
"qq 1 (cadr form))))\n `(,(the 'let)\n ,(map cdr renames)\n ", " (let ((x (assq var renames)))\n (if x\n ",
" ,body))))))\n\n(define (transformer f)\n (lambda (form env)\n (let ((regi", " (cadr x)\n (begin\n ",
"ster1 (make-register))\n (register2 (make-register)))\n (letrec\n ", " (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier)",
" ((wrap (lambda (var1)\n (let ((var2 (register1 var1)))\n ", " ',var ',env)) . ,renames))\n (rename var))))))\n ",
" (if (undefined? var2)\n (let ((var2 (m", " (walk (lambda (f form)\n (cond\n ((vari",
"ake-identifier var1 env)))\n (register1 var1 var2)\n ", "able? form)\n (f form))\n ((pair? form)\n ",
" (register2 var2 var1)\n var2)\n ", " `(,(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ",
" var2))))\n (unwrap (lambda (var2)\n ", " ((vector? form)\n `(,(the 'list->vector) (walk",
" (let ((var1 (register2 var2)))\n (if (undefined? var", " f (vector->list form))))\n (else\n `(,(the",
"1)\n var2\n var1))))\n ", " 'quote) ,form))))))\n (let ((form (walk rename (cadr form))))\n `",
" (walk (lambda (f form)\n (cond\n ((variable", "(,(the 'let)\n ,(map cdr renames)\n ,form))))))\n\n(define-mac",
"? form)\n (f form))\n ((pair? form)\n ", "ro syntax-quasiquote\n (lambda (form env)\n (let ((renames '()))\n (letrec",
" (cons (walk f (car form)) (walk f (cdr form))))\n ", "\n ((rename (lambda (var)\n (let ((x (assq var rename",
" ((vector? form)\n (list->vector (walk f (vector->list form)", "s)))\n (if x\n (cadr x)\n ",
")))\n (else\n form)))))\n (let ((form", " (begin\n (set! renames `((,var ,(mak",
" (cdr form)))\n (walk unwrap (apply f (walk wrap form))))))))\n\n(define-m", "e-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ",
"acro define-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", " (rename var)))))))\n\n (define (syntax-quasiquote? f",
" (body (cdr (cdr form))))\n (if (pair? formal)\n `(,(the 'def", "orm)\n (and (pair? form)\n (variable? (car form))\n ",
"ine-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-d", " (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env))))\n\n",
"efine-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(define-macr", " (define (syntax-unquote? form)\n (and (pair? form)\n ",
"o letrec-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", " (variable? (car form))\n (variable=? (the 'syntax-unquote) (make-",
" (body (cdr (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n ", "identifier (car form) env))))\n\n (define (syntax-unquote-splicing? form)\n ",
" `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n", " (and (pair? form)\n (pair? (car form))\n (var",
" ,@body))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the '", "iable? (caar form))\n (variable=? (the 'syntax-unquote-splicing) (m",
"letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro define-li", "ake-identifier (caar form) env))))\n\n (define (qq depth expr)\n (c",
"brary\n (lambda (form _)\n (let ((name (cadr form))\n (body (cddr form", "ond\n ;; syntax-unquote\n ((syntax-unquote? expr)\n ",
")))\n (let ((old-library (current-library))\n (new-library (or (fi", "(if (= depth 1)\n (car (cdr expr))\n (list (the 'lis",
"nd-library name) (make-library name))))\n (let ((env (library-environment ", "t)\n (list (the 'quote) (the 'syntax-unquote))\n ",
"new-library)))\n (current-library new-library)\n (for-each (lamb", " (qq (- depth 1) (car (cdr expr))))))\n ;; syntax-unquote-splic",
"da (expr) (eval expr env)) body)\n (current-library old-library))))))\n\n(", "ing\n ((syntax-unquote-splicing? expr)\n (if (= depth 1)\n ",
"define-macro cond-expand\n (lambda (form _)\n (letrec\n ((test (lambda (", " (list (the 'append)\n (car (cdr (car expr)))\n ",
"form)\n (or\n (eq? form 'else)\n ", " (qq depth (cdr expr)))\n (list (the 'cons)\n ",
"(and (symbol? form)\n (memq form (features)))\n ", " (list (the 'list)\n (list (the 'quot",
" (and (pair? form)\n (case (car form)\n ", "e) (the 'syntax-unquote-splicing))\n (qq (- depth 1) (",
" ((library) (find-library (cadr form)))\n ((not) (", "car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ",
"not (test (cadr form))))\n ((and) (let loop ((form (cdr f", " ;; syntax-quasiquote\n ((syntax-quasiquote? expr)\n (list (",
"orm)))\n (or (null? form)\n ", "the 'list)\n (list (the 'quote) (the 'quasiquote))\n ",
" (and (test (car form)) (loop (cdr form))))))\n ", " (qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? e",
" ((or) (let loop ((form (cdr form)))\n (and ", "xpr)\n (list (the 'cons)\n (qq depth (car expr))\n ",
"(pair? form)\n (or (test (car form)) (loop (", " (qq depth (cdr expr))))\n ;; vector\n ((vector? e",
"cdr form))))))\n (else #f)))))))\n (let loop ((clause", "xpr)\n (list (the 'list->vector) (qq depth (vector->list expr))))\n ",
"s (cdr form)))\n (if (null? clauses)\n #undefined\n (i", " ;; variable\n ((variable? expr)\n (rename expr))\n ",
"f (test (caar clauses))\n `(,the-begin ,@(cdar clauses))\n ", " ;; simple datum\n (else\n (list (the 'quote) expr))))\n\n",
" (loop (cdr clauses))))))))\n\n(define-macro import\n (lambda (form _)\n (", " (let ((body (qq 1 (cadr form))))\n `(,(the 'let)\n ,(m",
"let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n (prefix\n ", "ap cdr renames)\n ,body))))))\n\n(define (transformer f)\n (lambda (form",
" (lambda (prefix symbol)\n (string->symbol\n (string", " env)\n (let ((register1 (make-register))\n (register2 (make-register)",
"-append\n (symbol->string prefix)\n (symbol->string sy", "))\n (letrec\n ((wrap (lambda (var1)\n (let ((var2 ",
"mbol))))))\n (letrec\n ((extract\n (lambda (spec)\n ", "(register1 var1)))\n (if (undefined? var2)\n ",
" (case (car spec)\n ((only rename prefix except)\n ", " (let ((var2 (make-identifier var1 env)))\n (regi",
" (extract (cadr spec)))\n (else\n (or (find-lib", "ster1 var1 var2)\n (register2 var2 var1)\n ",
"rary spec) (error \"library not found\" spec))))))\n (collect\n ", " var2)\n var2))))\n (unwrap (lambda ",
" (lambda (spec)\n (case (car spec)\n ((only)\n ", "(var2)\n (let ((var1 (register2 var2)))\n ",
" (let ((alist (collect (cadr spec))))\n (map (lambda (va", " (if (undefined? var1)\n var2\n ",
"r) (assq var alist)) (cddr spec))))\n ((rename)\n (", " var1))))\n (walk (lambda (f form)\n (cond\n ",
"let ((alist (collect (cadr spec))))\n (map (lambda (s) (or (ass", " ((variable? form)\n (f form))\n ",
"q (car s) (cddr spec)) s)) alist)))\n ((prefix)\n (", "((pair? form)\n (cons (walk f (car form)) (walk f (cdr form))",
"let ((alist (collect (cadr spec))))\n (map (lambda (s) (cons (p", "))\n ((vector? form)\n (list->vector (walk ",
"refix (caddr spec) (car s)) (cdr s))) alist)))\n ((except)\n ", "f (vector->list form))))\n (else\n form))))",
" (let ((alist (collect (cadr spec))))\n (let loop ((al", ")\n (let ((form (cdr form)))\n (walk unwrap (apply f (walk wrap fo",
"ist alist))\n (if (null? alist)\n '()\n", "rm))))))))\n\n(define-macro define-syntax\n (lambda (form env)\n (let ((formal (",
" (if (memq (caar alist) (cddr spec))\n ", "car (cdr form)))\n (body (cdr (cdr form))))\n (if (pair? formal)\n ",
" (loop (cdr alist))\n (cons (car alist) (loo", " `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body",
"p (cdr alist))))))))\n (else\n (let ((lib (or (find", "))\n `(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body",
"-library spec) (error \"library not found\" spec))))\n (map (lamb", ")))))))\n\n(define-macro letrec-syntax\n (lambda (form env)\n (let ((formal (car",
"da (x) (cons x x)) (library-exports lib))))))))\n (letrec\n ((im", " (cdr form)))\n (body (cdr (cdr form))))\n `(let ()\n ,@(ma",
"port\n (lambda (spec)\n (let ((lib (extract spec))\n ", "p (lambda (x)\n `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n ",
" (alist (collect spec)))\n (for-each\n ", " formal)\n ,@body))))\n\n(define-macro let-syntax\n (lambda (fo",
" (lambda (slot)\n (library-import lib (cdr slo", "rm env)\n `(,(the 'letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(d",
"t) (car slot)))\n alist)))))\n (for-each import (cdr f", "efine-macro define-library\n (lambda (form _)\n (let ((name (cadr form))\n ",
"orm)))))))\n\n(define-macro export\n (lambda (form _)\n (letrec\n ((collec", " (body (cddr form)))\n (let ((old-library (current-library))\n ",
"t\n (lambda (spec)\n (cond\n ((symbol? spec)\n ", " (new-library (or (find-library name) (make-library name))))\n (let ((env ",
" `(,spec . ,spec))\n ((and (list? spec) (= (length spec) 3) (e", "(library-environment new-library)))\n (current-library new-library)\n ",
"q? (car spec) 'rename))\n `(,(list-ref spec 1) . ,(list-ref spec 2))", " (for-each (lambda (expr) (eval expr env)) body)\n (current-library",
")\n (else\n (error \"malformed export\")))))\n (expo", " old-library))))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec\n ",
"rt\n (lambda (spec)\n (let ((slot (collect spec)))\n ", " ((test (lambda (form)\n (or\n (eq? form 'els",
" (library-export (car slot) (cdr slot))))))\n (for-each export (cdr for", "e)\n (and (symbol? form)\n (memq form (feat",
"m)))))\n\n(export define-library\n cond-expand\n import\n export", "ures)))\n (and (pair? form)\n (case (car fo",
")\n\n(export let let* letrec letrec*\n let-values let*-values define-values\n", "rm)\n ((library) (find-library (cadr form)))\n ",
" quasiquote unquote unquote-splicing\n and or\n cond case els", " ((not) (not (test (cadr form))))\n ((and) (l",
"e =>\n do when unless\n parameterize\n define-syntax\n s", "et loop ((form (cdr form)))\n (or (null? form)\n ",
"yntax-quote syntax-unquote\n syntax-quasiquote syntax-unquote-splicing\n ", " (and (test (car form)) (loop (cdr form)))))",
" let-syntax letrec-syntax\n syntax-error)\n\n\n", ")\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",
"", "",
"" ""
}; };

336
extlib/benz/codegen.c
View File

@ -13,7 +13,7 @@ lookup(pic_state PIC_UNUSED(*pic), pic_value var, struct pic_env *env)
{ {
khiter_t it; khiter_t it;
assert(pic_var_p(var)); pic_assert_type(pic, var, var);
while (env != NULL) { while (env != NULL) {
it = kh_get(env, &env->map, pic_ptr(var)); 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; pic_sym *uid;
assert(pic_var_p(var));
assert(env != NULL); assert(env != NULL);
pic_assert_type(pic, var, var);
while ((uid = lookup(pic, var, env)) == NULL) { while ((uid = lookup(pic, var, env)) == NULL) {
if (pic_sym_p(var)) { if (pic_sym_p(var)) {
break; break;
@ -145,35 +146,23 @@ expand_lambda(pic_state *pic, pic_value expr, struct pic_env *env)
struct pic_env *in; struct pic_env *in;
pic_value a, deferred; pic_value a, deferred;
if (pic_length(pic, expr) < 2) {
pic_errorf(pic, "syntax error");
}
in = pic_make_env(pic, env); in = pic_make_env(pic, env);
for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) { for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
pic_value var = pic_car(pic, a); pic_add_variable(pic, in, pic_car(pic, a));
if (! pic_var_p(var)) {
pic_errorf(pic, "syntax error");
}
pic_add_variable(pic, in, var);
} }
if (pic_var_p(a)) { if (pic_var_p(a)) {
pic_add_variable(pic, in, 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()); deferred = pic_list1(pic, pic_nil_value());
formal = expand_list(pic, pic_cadr(pic, expr), in, deferred); formal = expand_list(pic, pic_list_ref(pic, expr, 1), in, deferred);
body = expand_list(pic, pic_cddr(pic, expr), in, deferred); body = expand(pic, pic_list_ref(pic, expr, 2), in, deferred);
expand_deferred(pic, deferred, in); 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 static pic_value
@ -182,21 +171,7 @@ expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value def
pic_sym *uid; pic_sym *uid;
pic_value var, val; 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))));
}
if (pic_length(pic, expr) != 3) {
pic_errorf(pic, "syntax error");
}
var = pic_cadr(pic, expr); 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) { if ((uid = pic_find_variable(pic, env, var)) == NULL) {
uid = pic_add_variable(pic, env, var); uid = pic_add_variable(pic, env, var);
} else { } else {
@ -213,20 +188,12 @@ expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env)
pic_value var, val; pic_value var, val;
pic_sym *uid; pic_sym *uid;
if (pic_length(pic, expr) != 3) {
pic_errorf(pic, "syntax error");
}
var = pic_cadr(pic, expr); 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) { if ((uid = pic_find_variable(pic, env, var)) == NULL) {
uid = pic_add_variable(pic, env, var); uid = pic_add_variable(pic, env, var);
} }
val = pic_eval(pic, pic_list_ref(pic, expr, 2), env); val = pic_eval(pic, pic_list_ref(pic, expr, 2), env);
if (! pic_proc_p(val)) { if (! pic_proc_p(val)) {
pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
} }
@ -236,12 +203,6 @@ expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env)
return pic_undef_value(); 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 static pic_value
expand_node(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred) expand_node(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred)
{ {
@ -276,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) { 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); return expand_list(pic, expr, env, deferred);
@ -292,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); size_t ai = pic_gc_arena_preserve(pic);
pic_value v; pic_value v;
#if DEBUG
printf("[expand] expanding... ");
pic_debug(pic, expr);
puts("");
#endif
v = expand_node(pic, expr, env, deferred); v = expand_node(pic, expr, env, deferred);
pic_gc_arena_restore(pic, ai); pic_gc_arena_restore(pic, ai);
@ -342,28 +297,30 @@ typedef struct analyze_scope {
struct analyze_scope *up; struct analyze_scope *up;
} analyze_scope; } analyze_scope;
static bool analyze_args(pic_state *, pic_value, analyze_scope *); static void
analyzer_scope_init(pic_state *pic, analyze_scope *scope, pic_value formal, analyze_scope *up)
static bool
analyzer_scope_init(pic_state *pic, analyze_scope *scope, pic_value formals, analyze_scope *up)
{ {
int ret;
kh_init(a, &scope->args); kh_init(a, &scope->args);
kh_init(a, &scope->locals); kh_init(a, &scope->locals);
kh_init(a, &scope->captures); kh_init(a, &scope->captures);
if (analyze_args(pic, formals, scope)) { /* analyze formal */
scope->up = up; for (; pic_pair_p(formal); formal = pic_cdr(pic, formal)) {
scope->depth = up ? up->depth + 1 : 0; kh_put(a, &scope->args, pic_sym_ptr(pic_car(pic, formal)), &ret);
scope->defer = pic_nil_value(); }
if (pic_nil_p(formal)) {
return true; scope->rest = NULL;
} }
else { else {
kh_destroy(a, &scope->args); scope->rest = pic_sym_ptr(formal);
kh_destroy(a, &scope->locals); kh_put(a, &scope->locals, pic_sym_ptr(formal), &ret);
kh_destroy(a, &scope->captures);
return false;
} }
scope->up = up;
scope->depth = up ? up->depth + 1 : 0;
scope->defer = pic_nil_value();
} }
static void static void
@ -374,33 +331,6 @@ analyzer_scope_destroy(pic_state *pic, analyze_scope *scope)
kh_destroy(a, &scope->captures); 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 static bool
search_scope(analyze_scope *scope, pic_sym *sym) search_scope(analyze_scope *scope, pic_sym *sym)
{ {
@ -449,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_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);
static pic_value static pic_value
analyze(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) analyze(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos)
@ -493,14 +423,14 @@ analyze_var(pic_state *pic, analyze_scope *scope, pic_sym *sym)
} }
static pic_value 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 form)
{ {
pic_sym *sNOWHERE = pic_intern_cstr(pic, "<<nowhere>>"); pic_sym *sNOWHERE = pic_intern_cstr(pic, "<<nowhere>>");
pic_value skel; pic_value skel;
skel = pic_list2(pic, pic_obj_value(pic->sGREF), pic_obj_value(sNOWHERE)); 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_cons(pic, skel, form), scope->defer);
return skel; return skel;
} }
@ -508,128 +438,77 @@ analyze_defer(pic_state *pic, analyze_scope *scope, pic_value name, pic_value fo
static void static void
analyze_deferred(pic_state *pic, analyze_scope *scope) analyze_deferred(pic_state *pic, analyze_scope *scope)
{ {
pic_value defer, val, name, formal, body, dst, it; pic_value defer, it, skel, form, val;
pic_for_each (defer, pic_reverse(pic, scope->defer), it) { pic_for_each (defer, pic_reverse(pic, scope->defer), it) {
name = pic_list_ref(pic, defer, 0); skel = pic_car(pic, defer);
formal = pic_list_ref(pic, defer, 1); form = pic_cdr(pic, defer);
body = pic_list_ref(pic, defer, 2);
dst = pic_list_ref(pic, defer, 3);
val = analyze_procedure(pic, scope, name, formal, body); val = analyze_procedure(pic, scope, form);
/* copy */ /* copy */
pic_pair_ptr(dst)->car = pic_car(pic, val); pic_pair_ptr(skel)->car = pic_car(pic, val);
pic_pair_ptr(dst)->cdr = pic_cdr(pic, val); pic_pair_ptr(skel)->cdr = pic_cdr(pic, val);
} }
scope->defer = pic_nil_value(); scope->defer = pic_nil_value();
} }
static pic_value 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 form)
{ {
analyze_scope s, *scope = &s; analyze_scope s, *scope = &s;
pic_value rest = pic_undef_value(), body; pic_value formals, body;
pic_value rest = pic_undef_value();
pic_vec *args, *locals, *captures; pic_vec *args, *locals, *captures;
size_t i, j;
assert(pic_sym_p(name) || pic_false_p(name)); formals = pic_list_ref(pic, form, 1);
body = pic_list_ref(pic, form, 2);
if (analyzer_scope_init(pic, scope, formals, up)) { analyzer_scope_init(pic, scope, formals, up);
size_t i, j;
/* analyze body */ /* analyze body */
body = analyze(pic, scope, pic_cons(pic, pic_obj_value(pic->uBEGIN), body_exprs), true); body = analyze(pic, scope, body, true);
analyze_deferred(pic, scope); analyze_deferred(pic, scope);
args = pic_make_vec(pic, kh_size(&scope->args)); args = pic_make_vec(pic, kh_size(&scope->args));
for (i = 0; pic_pair_p(formals); formals = pic_cdr(pic, formals), i++) { for (i = 0; pic_pair_p(formals); formals = pic_cdr(pic, formals), i++) {
args->data[i] = pic_car(pic, formals); 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);
}
else {
pic_errorf(pic, "invalid formal syntax: ~s", formals);
} }
return pic_list7(pic, pic_obj_value(pic->sLAMBDA), name, rest, pic_obj_value(args), pic_obj_value(locals), pic_obj_value(captures), body); if (scope->rest != NULL) {
} rest = pic_obj_value(scope->rest);
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");
} }
formals = pic_list_ref(pic, obj, 1); locals = pic_make_vec(pic, kh_size(&scope->locals));
body_exprs = pic_list_tail(pic, obj, 2); 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));
}
}
return analyze_defer(pic, scope, pic_false_value(), formals, body_exprs); 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));
}
}
static pic_value analyzer_scope_destroy(pic, scope);
analyze_declare(pic_state *pic, analyze_scope *scope, pic_sym *var)
{
define_var(pic, scope, var);
return analyze_var(pic, scope, var); 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 static pic_value
analyze_define(pic_state *pic, analyze_scope *scope, pic_value obj) analyze_define(pic_state *pic, analyze_scope *scope, pic_value obj)
{ {
pic_value var, val; pic_value var, val;
pic_sym *sym;
if (pic_length(pic, obj) != 3) { define_var(pic, scope, pic_sym_ptr(pic_list_ref(pic, obj, 1)));
pic_errorf(pic, "syntax error");
}
var = pic_list_ref(pic, obj, 1); var = analyze(pic, scope, pic_list_ref(pic, obj, 1), false);
if (! pic_sym_p(var)) { val = analyze(pic, scope, pic_list_ref(pic, obj, 2), false);
pic_errorf(pic, "syntax error");
} else {
sym = pic_sym_ptr(var);
}
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;
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);
val = analyze_defer(pic, scope, pic_obj_value(sym), formals, body_exprs);
} else {
if (pic_length(pic, obj) != 3) {
pic_errorf(pic, "syntax error");
}
val = analyze(pic, scope, pic_list_ref(pic, obj, 2), false);
}
return pic_list3(pic, pic_obj_value(pic->sSETBANG), var, val); return pic_list3(pic, pic_obj_value(pic->sSETBANG), var, val);
} }
@ -639,18 +518,9 @@ analyze_if(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos)
{ {
pic_value cond, if_true, if_false; pic_value cond, if_true, if_false;
if_false = pic_undef_value(); if_true = pic_list_ref(pic, obj, 2);
switch (pic_length(pic, obj)) { if_false = pic_list_ref(pic, obj, 3);
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);
}
/* analyze in order */
cond = analyze(pic, scope, pic_list_ref(pic, obj, 1), false); cond = analyze(pic, scope, pic_list_ref(pic, obj, 1), false);
if_true = analyze(pic, scope, if_true, tailpos); if_true = analyze(pic, scope, if_true, tailpos);
if_false = analyze(pic, scope, if_false, tailpos); if_false = analyze(pic, scope, if_false, tailpos);
@ -661,26 +531,15 @@ analyze_if(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos)
static pic_value static pic_value
analyze_begin(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos) analyze_begin(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos)
{ {
pic_value seq; pic_value beg1, beg2;
bool tail;
switch (pic_length(pic, obj)) { beg1 = pic_list_ref(pic, obj, 1);
case 1: beg2 = pic_list_ref(pic, obj, 2);
return analyze(pic, scope, pic_undef_value(), tailpos);
case 2: beg1 = analyze(pic, scope, beg1, false);
return analyze(pic, scope, pic_list_ref(pic, obj, 1), tailpos); beg2 = analyze(pic, scope, beg2, tailpos);
default:
seq = pic_list1(pic, pic_obj_value(pic->sBEGIN)); return pic_list3(pic, pic_obj_value(pic->sBEGIN), beg1, beg2);
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);
}
} }
static pic_value static pic_value
@ -688,15 +547,7 @@ analyze_set(pic_state *pic, analyze_scope *scope, pic_value obj)
{ {
pic_value var, val; pic_value var, val;
if (pic_length(pic, obj) != 3) {
pic_errorf(pic, "syntax error");
}
var = pic_list_ref(pic, obj, 1); var = pic_list_ref(pic, obj, 1);
if (! pic_sym_p(var)) {
pic_errorf(pic, "syntax error");
}
val = pic_list_ref(pic, obj, 2); val = pic_list_ref(pic, obj, 2);
var = analyze(pic, scope, var, false); var = analyze(pic, scope, var, false);
@ -708,9 +559,6 @@ analyze_set(pic_state *pic, analyze_scope *scope, pic_value obj)
static pic_value static pic_value
analyze_quote(pic_state *pic, pic_value obj) 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)); return pic_list2(pic, pic_obj_value(pic->sQUOTE), pic_list_ref(pic, obj, 1));
} }
@ -906,7 +754,7 @@ analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj, bool tailpos)
return analyze_define(pic, scope, obj); return analyze_define(pic, scope, obj);
} }
else if (sym == pic->uLAMBDA) { else if (sym == pic->uLAMBDA) {
return analyze_lambda(pic, scope, obj); return analyze_defer(pic, scope, obj);
} }
else if (sym == pic->uIF) { else if (sym == pic->uIF) {
return analyze_if(pic, scope, obj, tailpos); return analyze_if(pic, scope, obj, tailpos);
@ -1012,7 +860,6 @@ pic_analyze(pic_state *pic, pic_value obj)
} }
typedef struct codegen_context { typedef struct codegen_context {
pic_sym *name;
/* rest args variable is counted as a local */ /* rest args variable is counted as a local */
pic_sym *rest; pic_sym *rest;
pic_vec *args, *locals, *captures; pic_vec *args, *locals, *captures;
@ -1035,14 +882,9 @@ typedef struct codegen_context {
static void create_activation(pic_state *, codegen_context *); static void create_activation(pic_state *, codegen_context *);
static void 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->up = up;
cxt->name = pic_false_p(name)
? pic_intern_cstr(pic, "(anonymous lambda)")
: pic_sym_ptr(name);
cxt->rest = rest; cxt->rest = rest;
cxt->args = args; cxt->args = args;
@ -1075,7 +917,6 @@ codegen_context_destroy(pic_state *pic, codegen_context *cxt)
/* create irep */ /* create irep */
irep = (struct pic_irep *)pic_obj_alloc(pic, sizeof(struct pic_irep), PIC_TT_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->varg = cxt->rest != NULL;
irep->argc = (int)cxt->args->len + 1; irep->argc = (int)cxt->args->len + 1;
irep->localc = (int)cxt->locals->len; irep->localc = (int)cxt->locals->len;
@ -1501,22 +1342,21 @@ static struct pic_irep *
codegen_lambda(pic_state *pic, codegen_context *up, pic_value obj) codegen_lambda(pic_state *pic, codegen_context *up, pic_value obj)
{ {
codegen_context c, *cxt = &c; codegen_context c, *cxt = &c;
pic_value name, rest_opt, body; pic_value rest_opt, body;
pic_sym *rest = NULL; pic_sym *rest = NULL;
pic_vec *args, *locals, *captures; pic_vec *args, *locals, *captures;
name = pic_list_ref(pic, obj, 1); rest_opt = pic_list_ref(pic, obj, 1);
rest_opt = pic_list_ref(pic, obj, 2);
if (pic_sym_p(rest_opt)) { if (pic_sym_p(rest_opt)) {
rest = pic_sym_ptr(rest_opt); rest = pic_sym_ptr(rest_opt);
} }
args = pic_vec_ptr(pic_list_ref(pic, obj, 3)); args = pic_vec_ptr(pic_list_ref(pic, obj, 2));
locals = pic_vec_ptr(pic_list_ref(pic, obj, 4)); locals = pic_vec_ptr(pic_list_ref(pic, obj, 3));
captures = pic_vec_ptr(pic_list_ref(pic, obj, 5)); captures = pic_vec_ptr(pic_list_ref(pic, obj, 4));
body = pic_list_ref(pic, obj, 6); body = pic_list_ref(pic, obj, 5);
/* inner environment */ /* inner environment */
codegen_context_init(pic, cxt, up, name, rest, args, locals, captures); codegen_context_init(pic, cxt, up, rest, args, locals, captures);
{ {
/* body */ /* body */
codegen(pic, cxt, body); codegen(pic, cxt, body);
@ -1530,7 +1370,7 @@ pic_codegen(pic_state *pic, pic_value obj)
pic_vec *empty = pic_make_vec(pic, 0); pic_vec *empty = pic_make_vec(pic, 0);
codegen_context c, *cxt = &c; 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); codegen(pic, cxt, obj);
@ -1547,7 +1387,7 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_env *env)
fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
fprintf(stdout, "# input expression\n"); fprintf(stdout, "# input expression\n");
pic_debug(pic, obj); pic_write(pic, obj);
fprintf(stdout, "\n"); fprintf(stdout, "\n");
fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
@ -1557,7 +1397,7 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_env *env)
obj = pic_expand(pic, obj, env); obj = pic_expand(pic, obj, env);
#if DEBUG #if DEBUG
fprintf(stdout, "## expand completed\n"); fprintf(stdout, "## expand completed\n");
pic_debug(pic, obj); pic_write(pic, obj);
fprintf(stdout, "\n"); fprintf(stdout, "\n");
fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
#endif #endif
@ -1566,7 +1406,7 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_env *env)
obj = pic_analyze(pic, obj); obj = pic_analyze(pic, obj);
#if DEBUG #if DEBUG
fprintf(stdout, "## analyzer completed\n"); fprintf(stdout, "## analyzer completed\n");
pic_debug(pic, obj); pic_write(pic, obj);
fprintf(stdout, "\n"); fprintf(stdout, "\n");
fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
#endif #endif

2
extlib/benz/cont.c
View File

@ -121,7 +121,7 @@ pic_make_cont(pic_state *pic, struct pic_cont *cont)
struct pic_proc *c; struct pic_proc *c;
struct pic_data *e; struct pic_data *e;
c = pic_make_proc(pic, cont_call, "<cont-procedure>"); c = pic_make_proc(pic, cont_call);
e = pic_data_alloc(pic, &cont_type, cont); e = pic_data_alloc(pic, &cont_type, cont);

2
extlib/benz/debug.c
View File

@ -17,7 +17,7 @@ pic_get_backtrace(pic_state *pic)
struct pic_proc *proc = pic_proc_ptr(ci->fp[0]); 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, " 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)) { if (pic_proc_func_p(proc)) {
trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (native function)\n")); trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (native function)\n"));

3
extlib/benz/gc.c
View File

@ -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); gc_mark_object(pic, (struct pic_object *)proc->u.i.cxt);
} }
} else { } else {
gc_mark_object(pic, (struct pic_object *)proc->u.f.name);
if (proc->u.f.env) { if (proc->u.f.env) {
gc_mark_object(pic, (struct pic_object *)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; struct pic_irep *irep = (struct pic_irep *)obj;
size_t i; size_t i;
gc_mark_object(pic, (struct pic_object *)irep->name);
for (i = 0; i < irep->ilen; ++i) { for (i = 0; i < irep->ilen; ++i) {
gc_mark_object(pic, (struct pic_object *)irep->irep[i]); gc_mark_object(pic, (struct pic_object *)irep->irep[i]);
} }

2
extlib/benz/include/picrin/error.h
View File

@ -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) { \ if (PIC_SETJMP(pic, cont.jmp) == 0) { \
extern pic_value pic_native_exception_handler(pic_state *); \ extern pic_value pic_native_exception_handler(pic_state *); \
struct pic_proc *handler; \ 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))); \ pic_proc_env_set(pic, handler, "cont", pic_obj_value(pic_make_cont(pic, &cont))); \
do { \ do { \
pic_push_handler(pic, handler); pic_push_handler(pic, handler);

1
extlib/benz/include/picrin/irep.h
View File

@ -68,7 +68,6 @@ typedef struct {
struct pic_irep { struct pic_irep {
PIC_OBJECT_HEADER PIC_OBJECT_HEADER
pic_sym *name;
pic_code *code; pic_code *code;
int argc, localc, capturec; int argc, localc, capturec;
bool varg; bool varg;

4
extlib/benz/include/picrin/proc.h
View File

@ -26,7 +26,6 @@ struct pic_proc {
union { union {
struct { struct {
pic_func_t func; pic_func_t func;
pic_sym *name;
struct pic_dict *env; struct pic_dict *env;
} f; } f;
struct { struct {
@ -45,10 +44,9 @@ struct pic_proc {
#define pic_context_p(o) (pic_type(o) == PIC_TT_CXT) #define pic_context_p(o) (pic_type(o) == PIC_TT_CXT)
#define pic_context_ptr(o) ((struct pic_context *)pic_ptr(o)) #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 *); 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 *); struct pic_dict *pic_proc_env(pic_state *, struct pic_proc *);
bool pic_proc_env_has(pic_state *, struct pic_proc *, const char *); 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 *); pic_value pic_proc_env_ref(pic_state *, struct pic_proc *, const char *);

2
extlib/benz/port.c
View File

@ -154,7 +154,7 @@ pic_define_standard_port(pic_state *pic, const char *name, xFILE *file, int dir)
port->file = file; port->file = file;
port->flags = dir | PIC_PORT_TEXT | PIC_PORT_OPEN; 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) \ #define DEFINE_STANDARD_PORT_ACCESSOR(name, var) \

20
extlib/benz/proc.c
View File

@ -5,19 +5,13 @@
#include "picrin.h" #include "picrin.h"
struct pic_proc * 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; 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 = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC);
proc->tag = PIC_PROC_TAG_FUNC; proc->tag = PIC_PROC_TAG_FUNC;
proc->u.f.func = func; proc->u.f.func = func;
proc->u.f.name = sym;
proc->u.f.env = NULL; proc->u.f.env = NULL;
return proc; return proc;
} }
@ -34,18 +28,6 @@ pic_make_proc_irep(pic_state *pic, struct pic_irep *irep, struct pic_context *cx
return proc; 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 * struct pic_dict *
pic_proc_env(pic_state *pic, struct pic_proc *proc) pic_proc_env(pic_state *pic, struct pic_proc *proc)
{ {

2
extlib/benz/reg.c
View File

@ -118,7 +118,7 @@ pic_reg_make_register(pic_state *pic)
reg = pic_make_reg(pic); reg = pic_make_reg(pic);
proc = pic_make_proc(pic, reg_call, "<reg-call>"); proc = pic_make_proc(pic, reg_call);
pic_proc_env_set(pic, proc, "reg", pic_obj_value(reg)); pic_proc_env_set(pic, proc, "reg", pic_obj_value(reg));

19
extlib/benz/state.c
View File

@ -109,23 +109,26 @@ pic_features(pic_state *pic)
#define DONE pic_gc_arena_restore(pic, ai); #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 static void
pic_init_core(pic_state *pic) 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_init_features(pic);
pic_deflibrary (pic, "(picrin base)") { pic_deflibrary (pic, "(picrin base)") {
size_t ai = pic_gc_arena_preserve(pic); size_t ai = pic_gc_arena_preserve(pic);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->uDEFINE); define_builtin_syntax(pic->uDEFINE, "builtin:define");
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->uSETBANG); define_builtin_syntax(pic->uSETBANG, "builtin:set!");
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->uQUOTE); define_builtin_syntax(pic->uQUOTE, "builtin:quote");
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->uLAMBDA); define_builtin_syntax(pic->uLAMBDA, "builtin:lambda");
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->uIF); define_builtin_syntax(pic->uIF, "builtin:if");
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->uBEGIN); define_builtin_syntax(pic->uBEGIN, "builtin:begin");
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_MACRO, pic->uDEFINE_MACRO); define_builtin_syntax(pic->uDEFINE_MACRO, "builtin:define-macro");
pic_defun(pic, "features", pic_features); pic_defun(pic, "features", pic_features);

2
extlib/benz/var.c
View File

@ -61,7 +61,7 @@ pic_make_var(pic_state *pic, pic_value init, struct pic_proc *conv)
{ {
struct pic_proc *var; struct pic_proc *var;
var = pic_make_proc(pic, var_call, "<var-call>"); var = pic_make_proc(pic, var_call);
if (conv != NULL) { if (conv != NULL) {
pic_proc_env_set(pic, var, "conv", pic_obj_value(conv)); pic_proc_env_set(pic, var, "conv", pic_obj_value(conv));

20
extlib/benz/vm.c
View File

@ -82,11 +82,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
/* check argc. */ /* check argc. */
if (argc < paramc || (paramc + optc < argc && ! rest)) { if (argc < paramc || (paramc + optc < argc && ! rest)) {
pic_errorf(pic, "%s: wrong number of arguments (%d for %s%d)", pic_errorf(pic, "pic_get_args: wrong number of arguments (%d for %s%d)", argc, rest? "at least " : "", paramc);
pic_symbol_name(pic, pic_proc_name(pic_proc_ptr(GET_OPERAND(pic, 0)))) ,
argc,
rest? "at least " : "",
paramc);
} }
/* start dispatching */ /* start dispatching */
@ -633,7 +629,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
sym = irep->syms[c.u.i]; sym = irep->syms[c.u.i];
if (! pic_dict_has(pic, pic->globals, sym)) { if (! pic_dict_has(pic, pic->globals, sym)) {
pic_errorf(pic, "logic flaw; reference to uninitialized global variable: %s", pic_symbol_name(pic, sym)); pic_errorf(pic, "uninitialized global variable: %s", pic_symbol_name(pic, sym));
} }
PUSH(pic_dict_ref(pic, pic->globals, sym)); PUSH(pic_dict_ref(pic, pic->globals, sym));
NEXT; NEXT;
@ -1110,9 +1106,15 @@ pic_apply5(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2
} }
void 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); 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) { if (pic->lib && pic->lib->env == env) {
pic_export(pic, sym); pic_export(pic, sym);
@ -1125,7 +1127,7 @@ pic_defun_vm(pic_state *pic, const char *name, pic_sym *uid, pic_func_t func)
struct pic_proc *proc; struct pic_proc *proc;
pic_sym *sym; pic_sym *sym;
proc = pic_make_proc(pic, func, name); proc = pic_make_proc(pic, func);
sym = pic_intern_cstr(pic, name); sym = pic_intern_cstr(pic, name);
@ -1162,7 +1164,7 @@ pic_define(pic_state *pic, const char *name, pic_value val)
void void
pic_defun_(pic_state *pic, const char *name, pic_func_t cfunc) 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 void