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)

650
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 ",
" (,(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 ", " (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ",
" `(,(car (cdr (cdr clause))) ,the-key)\n ", " (let ((tmp (make-identifier 'tmp here)))\n ",
" `(,the-begin ,@(cdr clause)))\n ,(lo", " (list (the 'let) (list (list tmp (car clause)))\n (li",
"op (cdr clauses)))))))))))\n\n(define-macro parameterize\n (lambda (form env)\n ", "st the-if tmp\n (list (car (cddr clause)) tmp)\n ",
"(let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(,(t", " (cons (the 'cond) (cdr clauses)))))\n ",
"he 'with-parameter)\n (,(the 'lambda) ()\n ,@formal\n ,@body", " (list the-if (car clause)\n (cons the-begin (cd",
")))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (let ((renames '()))\n", "r clause))\n (cons (the 'cond) (cdr clauses))))))))))\n\n(",
" (letrec\n ((rename (lambda (var)\n (let ((x (as", "define-macro quasiquote\n (lambda (form env)\n\n (define (quasiquote? form)\n ",
"sq var renames)))\n (if x\n (cadr ", " (and (pair? form)\n (variable? (car form))\n (variable=? (t",
"x)\n (begin\n (set! renames ", "he 'quasiquote) (make-identifier (car form) env))))\n\n (define (unquote? form)",
"`((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,ren", "\n (and (pair? form)\n (variable? (car form))\n (variable=",
"ames))\n (rename var))))))\n (walk (lambda (", "? (the 'unquote) (make-identifier (car form) env))))\n\n (define (unquote-splic",
"f form)\n (cond\n ((variable? form)\n ", "ing? form)\n (and (pair? form)\n (pair? (car form))\n (var",
" (f form))\n ((pair? form)\n `(,", "iable? (caar form))\n (variable=? (the 'unquote-splicing) (make-identif",
"(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ((vect", "ier (caar form) env))))\n\n (define (qq depth expr)\n (cond\n ;; unquo",
"or? form)\n `(,(the 'list->vector) (walk f (vector->list form", "te\n ((unquote? expr)\n (if (= depth 1)\n (car (cdr expr))\n",
"))))\n (else\n `(,(the 'quote) ,form))))))\n", " (list (the 'list)\n (list (the 'quote) (the 'unquote",
" (let ((form (walk rename (cadr form))))\n `(,(the 'let)\n ", "))\n (qq (- depth 1) (car (cdr expr))))))\n ;; unquote-spli",
" ,(map cdr renames)\n ,form))))))\n\n(define-macro syntax-quasiquote\n", "cing\n ((unquote-splicing? expr)\n (if (= depth 1)\n (list ",
" (lambda (form env)\n (let ((renames '()))\n (letrec\n ((rename (", "(the 'append)\n (car (cdr (car expr)))\n (qq dep",
"lambda (var)\n (let ((x (assq var renames)))\n ", "th (cdr expr)))\n (list (the 'cons)\n (list (the 'list",
" (if x\n (cadr x)\n (beg", ")\n (list (the 'quote) (the 'unquote-splicing))\n ",
"in\n (set! renames `((,var ,(make-identifier var env)", " (qq (- depth 1) (car (cdr (car expr)))))\n (qq dep",
" (,(the 'make-identifier) ',var ',env)) . ,renames))\n ", "th (cdr expr)))))\n ;; quasiquote\n ((quasiquote? expr)\n (list ",
" (rename var)))))))\n\n (define (syntax-quasiquote? form)\n (and (", "(the 'list)\n (list (the 'quote) (the 'quasiquote))\n (q",
"pair? form)\n (variable? (car form))\n (variable=? (th", "q (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n (l",
"e 'syntax-quasiquote) (make-identifier (car form) env))))\n\n (define (synt", "ist (the 'cons)\n (qq depth (car expr))\n (qq depth (cdr",
"ax-unquote? form)\n (and (pair? form)\n (variable? (car for", " expr))))\n ;; vector\n ((vector? expr)\n (list (the 'list->vect",
"m))\n (variable=? (the 'syntax-unquote) (make-identifier (car form)", "or) (qq depth (vector->list expr))))\n ;; simple datum\n (else\n ",
" env))))\n\n (define (syntax-unquote-splicing? form)\n (and (pair? ", " (list (the 'quote) expr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(def",
"form)\n (pair? (car form))\n (variable? (caar form))\n ", "ine-macro let*\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n ",
" (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar ", " (body (cdr (cdr form))))\n (if (null? bindings)\n `(,(the 'l",
"form) env))))\n\n (define (qq depth expr)\n (cond\n ;; syn", "et) () ,@body)\n `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindi",
"tax-unquote\n ((syntax-unquote? expr)\n (if (= depth 1)\n ", "ngs))))\n (,(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n",
" (car (cdr expr))\n (list (the 'list)\n ", "(define-macro letrec\n (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n",
" (list (the 'quote) (the 'syntax-unquote))\n (qq (- depth", "\n(define-macro letrec*\n (lambda (form env)\n (let ((bindings (car (cdr form))",
" 1) (car (cdr expr))))))\n ;; syntax-unquote-splicing\n ((synt", ")\n (body (cdr (cdr form))))\n (let ((variables (map (lambda (v)",
"ax-unquote-splicing? expr)\n (if (= depth 1)\n (list (th", " `(,v #f)) (map car bindings)))\n (initials (map (lambda (v) `(,(the ",
"e 'append)\n (car (cdr (car expr)))\n (q", "'set!) ,@v)) bindings)))\n `(,(the 'let) (,@variables)\n ,@initial",
"q depth (cdr expr)))\n (list (the 'cons)\n (li", "s\n ,@body)))))\n\n(define-macro let-values\n (lambda (form env)\n `(,(t",
"st (the 'list)\n (list (the 'quote) (the 'syntax-unquo", "he 'let*-values) ,@(cdr form))))\n\n(define-macro let*-values\n (lambda (form env)",
"te-splicing))\n (qq (- depth 1) (car (cdr (car expr)))", "\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n ",
"))\n (qq depth (cdr expr)))))\n ;; syntax-quasiquot", "(if (null? formal)\n `(,(the 'let) () ,@body)\n `(,(the 'call-wi",
"e\n ((syntax-quasiquote? expr)\n (list (the 'list)\n ", "th-values) (,the-lambda () ,@(cdr (car formal)))\n (,(the 'lambda) (,@",
" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) ", "(car (car formal)))\n (,(the 'let*-values) (,@(cdr formal))\n ",
"(car (cdr expr)))))\n ;; list\n ((pair? expr)\n (lis", " ,@body)))))))\n\n(define-macro define-values\n (lambda (form env)\n (let ((",
"t (the 'cons)\n (qq depth (car expr))\n (qq dept", "formal (car (cdr form)))\n (body (cdr (cdr form))))\n (let ((argum",
"h (cdr expr))))\n ;; vector\n ((vector? expr)\n (lis", "ents (make-identifier 'arguments here)))\n `(,the-begin\n ,@(let l",
"t (the 'list->vector) (qq depth (vector->list expr))))\n ;; variable\n ", "oop ((formal formal))\n (if (pair? formal)\n `((,the",
" ((variable? expr)\n (rename expr))\n ;; simple datum", "-define ,(car formal) #undefined) ,@(loop (cdr formal)))\n (if (",
"\n (else\n (list (the 'quote) expr))))\n\n (let ((body (", "variable? formal)\n `((,the-define ,formal #undefined))\n ",
"qq 1 (cadr form))))\n `(,(the 'let)\n ,(map cdr renames)\n ", " '())))\n (,(the 'call-with-values) (,the-lambda () ,@b",
" ,body))))))\n\n(define (transformer f)\n (lambda (form env)\n (let ((regi", "ody)\n (,the-lambda\n ,arguments\n ,@(let loop ((fo",
"ster1 (make-register))\n (register2 (make-register)))\n (letrec\n ", "rmal formal) (args arguments))\n (if (pair? formal)\n ",
" ((wrap (lambda (var1)\n (let ((var2 (register1 var1)))\n ", " `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(t",
" (if (undefined? var2)\n (let ((var2 (m", "he 'cdr) ,args)))\n (if (variable? formal)\n ",
"ake-identifier var1 env)))\n (register1 var1 var2)\n ", " `((,the-set! ,formal ,args))\n '()))))))))))\n\n(define",
" (register2 var2 var1)\n var2)\n ", "-macro do\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (",
" var2))))\n (unwrap (lambda (var2)\n ", "test (car (car (cdr (cdr form)))))\n (cleanup (cdr (car (cdr (cdr f",
" (let ((var1 (register2 var2)))\n (if (undefined? var", "orm)))))\n (body (cdr (cdr (cdr form)))))\n (let ((loop (make-id",
"1)\n var2\n var1))))\n ", "entifier 'loop here)))\n `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ",
" (walk (lambda (f form)\n (cond\n ((variable", ",(cadr x))) bindings)\n (,the-if ,test\n (,the-begin\n ",
"? form)\n (f form))\n ((pair? form)\n ", " ,@cleanup)\n (,the-begin\n ",
" (cons (walk f (car form)) (walk f (cdr form))))\n ", ",@body\n (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (",
" ((vector? form)\n (list->vector (walk f (vector->list form)", "car x) (car (cdr (cdr x))))) bindings)))))))))\n\n(define-macro when\n (lambda (fo",
")))\n (else\n form)))))\n (let ((form", "rm env)\n (let ((test (car (cdr form)))\n (body (cdr (cdr form))))\n ",
" (cdr form)))\n (walk unwrap (apply f (walk wrap form))))))))\n\n(define-m", " `(,the-if ,test\n (,the-begin ,@body)\n #undefine",
"acro define-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", "d))))\n\n(define-macro unless\n (lambda (form env)\n (let ((test (car (cdr form)",
" (body (cdr (cdr form))))\n (if (pair? formal)\n `(,(the 'def", "))\n (body (cdr (cdr form))))\n `(,the-if ,test\n #und",
"ine-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-d", "efined\n (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (fo",
"efine-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(define-macr", "rm env)\n (let ((key (car (cdr form)))\n (clauses (cdr (cdr form))",
"o letrec-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", "))\n (let ((the-key (make-identifier 'key here)))\n `(,(the 'let) ((,t",
" (body (cdr (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n ", "he-key ,key))\n ,(let loop ((clauses clauses))\n (if (null? c",
" `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n", "lauses)\n #undefined\n (let ((clause (car clauses)",
" ,@body))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the '", "))\n `(,the-if ,(if (and (variable? (car clause))\n ",
"letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro define-li", " (variable=? (the 'else) (make-identifier (car clause) ",
"brary\n (lambda (form _)\n (let ((name (cadr form))\n (body (cddr form", "env)))\n #t\n `(",
")))\n (let ((old-library (current-library))\n (new-library (or (fi", ",(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car cla",
"nd-library name) (make-library name))))\n (let ((env (library-environment ", "use))))\n ,(if (and (variable? (cadr clause))\n ",
"new-library)))\n (current-library new-library)\n (for-each (lamb", " (variable=? (the '=>) (make-identifier (cadr cla",
"da (expr) (eval expr env)) body)\n (current-library old-library))))))\n\n(", "use) env)))\n `(,(car (cdr (cdr clause))) ,the-k",
"define-macro cond-expand\n (lambda (form _)\n (letrec\n ((test (lambda (", "ey)\n `(,the-begin ,@(cdr clause)))\n ",
"form)\n (or\n (eq? form 'else)\n ", " ,(loop (cdr clauses)))))))))))\n\n(define-macro parameterize\n (l",
"(and (symbol? form)\n (memq form (features)))\n ", "ambda (form env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr",
" (and (pair? form)\n (case (car form)\n ", " form))))\n `(,(the 'with-parameter)\n (,(the 'lambda) ()\n ,@f",
" ((library) (find-library (cadr form)))\n ((not) (", "ormal\n ,@body)))))\n\n(define-macro syntax-quote\n (lambda (form env)\n ",
"not (test (cadr form))))\n ((and) (let loop ((form (cdr f", "(let ((renames '()))\n (letrec\n ((rename (lambda (var)\n ",
"orm)))\n (or (null? form)\n ", " (let ((x (assq var renames)))\n (if x\n ",
" (and (test (car form)) (loop (cdr form))))))\n ", " (cadr x)\n (begin\n ",
" ((or) (let loop ((form (cdr form)))\n (and ", " (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier)",
"(pair? form)\n (or (test (car form)) (loop (", " ',var ',env)) . ,renames))\n (rename var))))))\n ",
"cdr form))))))\n (else #f)))))))\n (let loop ((clause", " (walk (lambda (f form)\n (cond\n ((vari",
"s (cdr form)))\n (if (null? clauses)\n #undefined\n (i", "able? form)\n (f form))\n ((pair? form)\n ",
"f (test (caar clauses))\n `(,the-begin ,@(cdar clauses))\n ", " `(,(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ",
" (loop (cdr clauses))))))))\n\n(define-macro import\n (lambda (form _)\n (", " ((vector? form)\n `(,(the 'list->vector) (walk",
"let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n (prefix\n ", " f (vector->list form))))\n (else\n `(,(the",
" (lambda (prefix symbol)\n (string->symbol\n (string", " 'quote) ,form))))))\n (let ((form (walk rename (cadr form))))\n `",
"-append\n (symbol->string prefix)\n (symbol->string sy", "(,(the 'let)\n ,(map cdr renames)\n ,form))))))\n\n(define-mac",
"mbol))))))\n (letrec\n ((extract\n (lambda (spec)\n ", "ro syntax-quasiquote\n (lambda (form env)\n (let ((renames '()))\n (letrec",
" (case (car spec)\n ((only rename prefix except)\n ", "\n ((rename (lambda (var)\n (let ((x (assq var rename",
" (extract (cadr spec)))\n (else\n (or (find-lib", "s)))\n (if x\n (cadr x)\n ",
"rary spec) (error \"library not found\" spec))))))\n (collect\n ", " (begin\n (set! renames `((,var ,(mak",
" (lambda (spec)\n (case (car spec)\n ((only)\n ", "e-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ",
" (let ((alist (collect (cadr spec))))\n (map (lambda (va", " (rename var)))))))\n\n (define (syntax-quasiquote? f",
"r) (assq var alist)) (cddr spec))))\n ((rename)\n (", "orm)\n (and (pair? form)\n (variable? (car form))\n ",
"let ((alist (collect (cadr spec))))\n (map (lambda (s) (or (ass", " (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env))))\n\n",
"q (car s) (cddr spec)) s)) alist)))\n ((prefix)\n (", " (define (syntax-unquote? form)\n (and (pair? form)\n ",
"let ((alist (collect (cadr spec))))\n (map (lambda (s) (cons (p", " (variable? (car form))\n (variable=? (the 'syntax-unquote) (make-",
"refix (caddr spec) (car s)) (cdr s))) alist)))\n ((except)\n ", "identifier (car form) env))))\n\n (define (syntax-unquote-splicing? form)\n ",
" (let ((alist (collect (cadr spec))))\n (let loop ((al", " (and (pair? form)\n (pair? (car form))\n (var",
"ist alist))\n (if (null? alist)\n '()\n", "iable? (caar form))\n (variable=? (the 'syntax-unquote-splicing) (m",
" (if (memq (caar alist) (cddr spec))\n ", "ake-identifier (caar form) env))))\n\n (define (qq depth expr)\n (c",
" (loop (cdr alist))\n (cons (car alist) (loo", "ond\n ;; syntax-unquote\n ((syntax-unquote? expr)\n ",
"p (cdr alist))))))))\n (else\n (let ((lib (or (find", "(if (= depth 1)\n (car (cdr expr))\n (list (the 'lis",
"-library spec) (error \"library not found\" spec))))\n (map (lamb", "t)\n (list (the 'quote) (the 'syntax-unquote))\n ",
"da (x) (cons x x)) (library-exports lib))))))))\n (letrec\n ((im", " (qq (- depth 1) (car (cdr expr))))))\n ;; syntax-unquote-splic",
"port\n (lambda (spec)\n (let ((lib (extract spec))\n ", "ing\n ((syntax-unquote-splicing? expr)\n (if (= depth 1)\n ",
" (alist (collect spec)))\n (for-each\n ", " (list (the 'append)\n (car (cdr (car expr)))\n ",
" (lambda (slot)\n (library-import lib (cdr slo", " (qq depth (cdr expr)))\n (list (the 'cons)\n ",
"t) (car slot)))\n alist)))))\n (for-each import (cdr f", " (list (the 'list)\n (list (the 'quot",
"orm)))))))\n\n(define-macro export\n (lambda (form _)\n (letrec\n ((collec", "e) (the 'syntax-unquote-splicing))\n (qq (- depth 1) (",
"t\n (lambda (spec)\n (cond\n ((symbol? spec)\n ", "car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ",
" `(,spec . ,spec))\n ((and (list? spec) (= (length spec) 3) (e", " ;; syntax-quasiquote\n ((syntax-quasiquote? expr)\n (list (",
"q? (car spec) 'rename))\n `(,(list-ref spec 1) . ,(list-ref spec 2))", "the 'list)\n (list (the 'quote) (the 'quasiquote))\n ",
")\n (else\n (error \"malformed export\")))))\n (expo", " (qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? e",
"rt\n (lambda (spec)\n (let ((slot (collect spec)))\n ", "xpr)\n (list (the 'cons)\n (qq depth (car expr))\n ",
" (library-export (car slot) (cdr slot))))))\n (for-each export (cdr for", " (qq depth (cdr expr))))\n ;; vector\n ((vector? e",
"m)))))\n\n(export define-library\n cond-expand\n import\n export", "xpr)\n (list (the 'list->vector) (qq depth (vector->list expr))))\n ",
")\n\n(export let let* letrec letrec*\n let-values let*-values define-values\n", " ;; variable\n ((variable? expr)\n (rename expr))\n ",
" quasiquote unquote unquote-splicing\n and or\n cond case els", " ;; simple datum\n (else\n (list (the 'quote) expr))))\n\n",
"e =>\n do when unless\n parameterize\n define-syntax\n s", " (let ((body (qq 1 (cadr form))))\n `(,(the 'let)\n ,(m",
"yntax-quote syntax-unquote\n syntax-quasiquote syntax-unquote-splicing\n ", "ap cdr renames)\n ,body))))))\n\n(define (transformer f)\n (lambda (form",
" let-syntax letrec-syntax\n syntax-error)\n\n\n", " 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",
"", "",
"" ""
}; };

294
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 */
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 {
scope->rest = pic_sym_ptr(formal);
kh_put(a, &scope->locals, pic_sym_ptr(formal), &ret);
}
scope->up = up; scope->up = up;
scope->depth = up ? up->depth + 1 : 0; scope->depth = up ? up->depth + 1 : 0;
scope->defer = pic_nil_value(); scope->defer = pic_nil_value();
return true;
}
else {
kh_destroy(a, &scope->args);
kh_destroy(a, &scope->locals);
kh_destroy(a, &scope->captures);
return false;
}
} }
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,38 +438,38 @@ 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;
assert(pic_sym_p(name) || pic_false_p(name));
if (analyzer_scope_init(pic, scope, formals, up)) {
size_t i, j; 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 */ /* 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));
@ -566,70 +496,19 @@ analyze_procedure(pic_state *pic, analyze_scope *up, pic_value name, pic_value f
} }
analyzer_scope_destroy(pic, scope); 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); 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_exprs;
if (pic_length(pic, obj) < 2) {
pic_errorf(pic, "syntax error");
}
formals = pic_list_ref(pic, obj, 1);
body_exprs = pic_list_tail(pic, obj, 2);
return analyze_defer(pic, scope, pic_false_value(), formals, body_exprs);
}
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 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)) {
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); 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();
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); 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