From e51d3db812032af1f553280f6d32980f523de273 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 6 Feb 2016 23:15:53 +0900 Subject: [PATCH] symbol is an identifier --- contrib/10.macro/macro.scm | 17 +- contrib/20.r7rs/scheme/base.scm | 20 +- contrib/50.destructuring-bind/lambda.scm | 2 +- extlib/benz/bool.c | 4 +- extlib/benz/boot.c | 595 ++++++++++++----------- extlib/benz/codegen.c | 38 +- extlib/benz/gc.c | 6 +- extlib/benz/include/picrin.h | 4 - extlib/benz/include/picrin/macro.h | 23 +- extlib/benz/include/picrin/symbol.h | 28 +- extlib/benz/include/picrin/type.h | 1 + extlib/benz/lib.c | 16 +- extlib/benz/macro.c | 170 +------ extlib/benz/state.c | 10 +- extlib/benz/symbol.c | 103 +++- extlib/benz/vm.c | 8 +- extlib/benz/write.c | 2 +- 17 files changed, 511 insertions(+), 536 deletions(-) diff --git a/contrib/10.macro/macro.scm b/contrib/10.macro/macro.scm index 164803eb..5d621946 100644 --- a/contrib/10.macro/macro.scm +++ b/contrib/10.macro/macro.scm @@ -6,10 +6,9 @@ (export define-macro make-identifier identifier? + identifier=? identifier-variable - identifier-environment - variable? - variable=?) + identifier-environment) ;; simple macro @@ -51,7 +50,7 @@ id)))))) (walk (lambda (f form) (cond - ((variable? form) + ((identifier? form) (f form)) ((pair? form) (cons (walk f (car form)) (walk f (cdr form)))) @@ -64,7 +63,7 @@ (let loop ((free free)) (if (null? free) (wrap free) - (if (variable=? var (car free)) + (if (identifier=? var (car free)) var (loop (cdr free)))))))) (walk f form)))) @@ -78,7 +77,7 @@ (identifier-variable var))) (walk (lambda (f form) (cond - ((variable? form) + ((identifier? form) (f form)) ((pair? form) (cons (walk f (car form)) (walk f (cdr form)))) @@ -112,7 +111,7 @@ (register var id) id)))))) (compare (lambda (x y) - (variable=? + (identifier=? (make-identifier x use-env) (make-identifier y use-env))))) (f form rename compare)))) @@ -145,7 +144,7 @@ (rename var2))))) (walk (lambda (f form) (cond - ((variable? form) + ((identifier? form) (f form)) ((pair? form) (cons (walk f (car form)) (walk f (cdr form)))) @@ -154,7 +153,7 @@ (else form)))) (compare (lambda (x y) - (variable=? + (identifier=? (make-identifier x mac-env) (make-identifier y mac-env))))) (walk flip (f (walk inject form) inject compare)))))) diff --git a/contrib/20.r7rs/scheme/base.scm b/contrib/20.r7rs/scheme/base.scm index 736e489d..13546630 100644 --- a/contrib/20.r7rs/scheme/base.scm +++ b/contrib/20.r7rs/scheme/base.scm @@ -208,17 +208,17 @@ (define (constant? obj) (and (not (pair? obj)) - (not (variable? obj)))) + (not (identifier? obj)))) (define (literal? obj) - (and (variable? obj) + (and (identifier? obj) (memq obj literals))) (define (many? pat) (and (pair? pat) (pair? (cdr pat)) - (variable? (cadr pat)) - (variable=? (cadr pat) ellipsis))) + (identifier? (cadr pat)) + (identifier=? (cadr pat) ellipsis))) (define (pattern-validator pat) ; pattern -> validator (letrec @@ -228,8 +228,8 @@ ((constant? pat) #`(equal? '#,pat #,form)) ((literal? pat) - #`(and (variable? #,form) (variable=? #'#,pat #,form))) - ((variable? pat) + #`(and (identifier? #,form) (identifier=? #'#,pat #,form))) + ((identifier? pat) #t) ((many? pat) (let ((head #`(drop-tail #,(length (cddr pat)) #,form)) @@ -252,7 +252,7 @@ '()) ((literal? pat) '()) - ((variable? pat) + ((identifier? pat) `(,pat)) ((many? pat) (append (pattern-variables (car pat)) @@ -267,7 +267,7 @@ '()) ((literal? pat) '()) - ((variable? pat) + ((identifier? pat) `((,pat . 0))) ((many? pat) (append (map-values succ (pattern-levels (car pat))) @@ -285,7 +285,7 @@ '()) ((literal? pat) '()) - ((variable? pat) + ((identifier? pat) `((,pat . ,form))) ((many? pat) (let ((head #`(drop-tail #,(length (cddr pat)) #,form)) @@ -303,7 +303,7 @@ (cond ((constant? pat) pat) - ((variable? pat) + ((identifier? pat) (let ((it (assq pat levels))) (if it (if (= 0 (cdr it)) diff --git a/contrib/50.destructuring-bind/lambda.scm b/contrib/50.destructuring-bind/lambda.scm index c3fc9872..111ee67e 100644 --- a/contrib/50.destructuring-bind/lambda.scm +++ b/contrib/50.destructuring-bind/lambda.scm @@ -4,7 +4,7 @@ (define-syntax (destructuring-bind formal value . body) (cond - ((variable? formal) + ((identifier? formal) #`(let ((#,formal #,value)) #,@body)) ((pair? formal) diff --git a/extlib/benz/bool.c b/extlib/benz/bool.c index c6188388..cdb8656d 100644 --- a/extlib/benz/bool.c +++ b/extlib/benz/bool.c @@ -45,8 +45,8 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m) id1 = pic_id_ptr(x); id2 = pic_id_ptr(y); - s1 = pic_resolve_variable(pic, id1->env, id1->var); - s2 = pic_resolve_variable(pic, id2->env, id2->var); + s1 = pic_lookup_identifier(pic, id1->u.id.id, id1->u.id.env); + s2 = pic_lookup_identifier(pic, id2->u.id.id, id2->u.id.env); return s1 == s2; } diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index 72bb1d54..cf2e6652 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -71,7 +71,7 @@ my $src = <<'EOL'; (builtin:define-macro set! (builtin:lambda (form env) (if (= (length form) 3) - (if (variable? (cadr form)) + (if (identifier? (cadr form)) (cons the-builtin-set! (cdr form)) (error "illegal set! form" form)) (error "illegal set! form" form)))) @@ -80,10 +80,10 @@ my $src = <<'EOL'; (builtin:lambda (formal) (if (null? formal) #t - (if (variable? formal) + (if (identifier? formal) #t (if (pair? formal) - (if (variable? (car formal)) + (if (identifier? (car formal)) (check-formal (cdr formal)) #f) #f))))) @@ -101,7 +101,7 @@ my $src = <<'EOL'; ((lambda (len) (if (= len 1) (error "illegal define form" form) - (if (variable? (cadr form)) + (if (identifier? (cadr form)) (if (= len 3) (cons the-builtin-define (cdr form)) (error "illegal define form" form)) @@ -115,7 +115,7 @@ my $src = <<'EOL'; (builtin:define-macro define-macro (lambda (form env) (if (= (length form) 3) - (if (variable? (cadr form)) + (if (identifier? (cadr form)) (cons the-builtin-define-macro (cdr form)) (error "define-macro: binding to non-variable object" form)) (error "illegal define-macro form" form)))) @@ -145,7 +145,7 @@ my $src = <<'EOL'; (define-macro let (lambda (form env) - (if (variable? (cadr form)) + (if (identifier? (cadr form)) (list (list the-lambda '() (list the-define (cadr form) @@ -189,15 +189,15 @@ my $src = <<'EOL'; (if (null? clauses) #undefined (let ((clause (car clauses))) - (if (and (variable? (car clause)) - (variable=? (the 'else) (make-identifier (car clause) env))) + (if (and (identifier? (car clause)) + (identifier=? (the 'else) (make-identifier (car clause) env))) (cons the-begin (cdr clause)) (if (null? (cdr clause)) (let ((tmp (make-identifier 'tmp here))) (list (the 'let) (list (list tmp (car clause))) (list the-if tmp tmp (cons (the 'cond) (cdr clauses))))) - (if (and (variable? (cadr clause)) - (variable=? (the '=>) (make-identifier (cadr clause) env))) + (if (and (identifier? (cadr clause)) + (identifier=? (the '=>) (make-identifier (cadr clause) env))) (let ((tmp (make-identifier 'tmp here))) (list (the 'let) (list (list tmp (car clause))) (list the-if tmp @@ -212,19 +212,19 @@ my $src = <<'EOL'; (define (quasiquote? form) (and (pair? form) - (variable? (car form)) - (variable=? (the 'quasiquote) (make-identifier (car form) env)))) + (identifier? (car form)) + (identifier=? (the 'quasiquote) (make-identifier (car form) env)))) (define (unquote? form) (and (pair? form) - (variable? (car form)) - (variable=? (the 'unquote) (make-identifier (car form) env)))) + (identifier? (car form)) + (identifier=? (the 'unquote) (make-identifier (car form) env)))) (define (unquote-splicing? form) (and (pair? form) (pair? (car form)) - (variable? (caar form)) - (variable=? (the 'unquote-splicing) (make-identifier (caar form) env)))) + (identifier? (caar form)) + (identifier=? (the 'unquote-splicing) (make-identifier (caar form) env)))) (define (qq depth expr) (cond @@ -314,7 +314,7 @@ my $src = <<'EOL'; ,@(let loop ((formal formal)) (if (pair? formal) `((,the-define ,(car formal) #undefined) ,@(loop (cdr formal))) - (if (variable? formal) + (if (identifier? formal) `((,the-define ,formal #undefined)) '()))) (,(the 'call-with-values) (,the-lambda () ,@body) @@ -323,7 +323,7 @@ my $src = <<'EOL'; ,@(let loop ((formal formal) (args arguments)) (if (pair? formal) `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args))) - (if (variable? formal) + (if (identifier? formal) `((,the-set! ,formal ,args)) '())))))))))) @@ -368,12 +368,12 @@ my $src = <<'EOL'; (if (null? clauses) #undefined (let ((clause (car clauses))) - `(,the-if ,(if (and (variable? (car clause)) - (variable=? (the 'else) (make-identifier (car clause) env))) + `(,the-if ,(if (and (identifier? (car clause)) + (identifier=? (the 'else) (make-identifier (car clause) env))) #t `(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause)))) - ,(if (and (variable? (cadr clause)) - (variable=? (the '=>) (make-identifier (cadr clause) env))) + ,(if (and (identifier? (cadr clause)) + (identifier=? (the '=>) (make-identifier (cadr clause) env))) `(,(car (cdr (cdr clause))) ,the-key) `(,the-begin ,@(cdr clause))) ,(loop (cdr clauses))))))))))) @@ -400,7 +400,7 @@ my $src = <<'EOL'; (rename var)))))) (walk (lambda (f form) (cond - ((variable? form) + ((identifier? form) (f form)) ((pair? form) `(,(the 'cons) (walk f (car form)) (walk f (cdr form)))) @@ -427,19 +427,19 @@ my $src = <<'EOL'; (define (syntax-quasiquote? form) (and (pair? form) - (variable? (car form)) - (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env)))) + (identifier? (car form)) + (identifier=? (the 'syntax-quasiquote) (make-identifier (car form) env)))) (define (syntax-unquote? form) (and (pair? form) - (variable? (car form)) - (variable=? (the 'syntax-unquote) (make-identifier (car form) env)))) + (identifier? (car form)) + (identifier=? (the 'syntax-unquote) (make-identifier (car form) env)))) (define (syntax-unquote-splicing? form) (and (pair? form) (pair? (car form)) - (variable? (caar form)) - (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env)))) + (identifier? (caar form)) + (identifier=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env)))) (define (qq depth expr) (cond @@ -474,8 +474,8 @@ my $src = <<'EOL'; ;; vector ((vector? expr) (list (the 'list->vector) (qq depth (vector->list expr)))) - ;; variable - ((variable? expr) + ;; identifier + ((identifier? expr) (rename expr)) ;; simple datum (else @@ -506,7 +506,7 @@ my $src = <<'EOL'; var2)))) (walk (lambda (f form) (cond - ((variable? form) + ((identifier? form) (f form)) ((pair? form) (cons (walk f (car form)) (walk f (cdr form)))) @@ -745,271 +745,272 @@ const char pic_boot[][80] = { " (cdr form))\n (list the-builtin-begin\n ", " (cadr form)\n (cons the-begin (cddr form)))))))\n (le", "ngth form))))\n\n(builtin:define-macro set!\n (builtin:lambda (form env)\n (if (", -"= (length form) 3)\n (if (variable? (cadr form))\n (cons the-bui", -"ltin-set! (cdr form))\n (error \"illegal set! form\" form))\n (err", -"or \"illegal set! form\" form))))\n\n(builtin:define check-formal\n (builtin:lambda ", -"(formal)\n (if (null? formal)\n #t\n (if (variable? formal)\n ", -" #t\n (if (pair? formal)\n (if (variable? (car form", -"al))\n (check-formal (cdr formal))\n #f)\n ", -" #f)))))\n\n(builtin:define-macro lambda\n (builtin:lambda (form env)\n", -" (if (= (length form) 1)\n (error \"illegal lambda form\" form)\n (", -"if (check-formal (cadr form))\n (list the-builtin-lambda (cadr form) (", -"cons the-begin (cddr form)))\n (error \"illegal lambda form\" form)))))\n", -"\n(builtin:define-macro define\n (lambda (form env)\n ((lambda (len)\n (if", -" (= len 1)\n (error \"illegal define form\" form)\n (if (variabl", -"e? (cadr form))\n (if (= len 3)\n (cons the-builti", -"n-define (cdr form))\n (error \"illegal define form\" form))\n ", -" (if (pair? (cadr form))\n (list the-define\n ", -" (car (cadr form))\n (cons the-lambda (con", -"s (cdr (cadr form)) (cddr form))))\n (error \"define: binding to", -" non-varaible object\" form)))))\n (length form))))\n\n(builtin:define-macro def", -"ine-macro\n (lambda (form env)\n (if (= (length form) 3)\n (if (variable", -"? (cadr form))\n (cons the-builtin-define-macro (cdr form))\n ", -" (error \"define-macro: binding to non-variable object\" form))\n (error \"i", -"llegal define-macro form\" form))))\n\n\n(define-macro syntax-error\n (lambda (form ", -"_)\n (apply error (cdr form))))\n\n(define-macro define-auxiliary-syntax\n (lamb", -"da (form _)\n (define message\n (string-append\n \"invalid use of auxi", -"liary syntax: '\" (symbol->string (cadr form)) \"'\"))\n (list\n the-define-ma", -"cro\n (cadr form)\n (list the-lambda '_\n (list (the 'error) mess", -"age)))))\n\n(define-auxiliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-au", -"xiliary-syntax unquote)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxil", -"iary-syntax syntax-unquote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(", -"define-macro let\n (lambda (form env)\n (if (variable? (cadr form))\n (l", -"ist\n (list the-lambda '()\n (list the-define (cadr form)\n ", -" (cons the-lambda\n (cons (map car (c", -"ar (cddr form)))\n (cdr (cddr form)))))\n ", -" (cons (cadr form) (map cadr (car (cddr form))))))\n (cons\n (", -"cons\n the-lambda\n (cons (map car (cadr form))\n ", -"(cddr form)))\n (map cadr (cadr form))))))\n\n(define-macro and\n (lambda (", -"form env)\n (if (null? (cdr form))\n #t\n (if (null? (cddr form))\n", -" (cadr form)\n (list the-if\n (cadr form)\n ", -" (cons (the 'and) (cddr form))\n #f)))))\n\n(defin", -"e-macro or\n (lambda (form env)\n (if (null? (cdr form))\n #f\n (l", -"et ((tmp (make-identifier 'it env)))\n (list (the 'let)\n ", -"(list (list tmp (cadr form)))\n (list the-if\n ", -" tmp\n tmp\n (cons (the 'or) (cddr form)", -")))))))\n\n(define-macro cond\n (lambda (form env)\n (let ((clauses (cdr form)))", -"\n (if (null? clauses)\n #undefined\n (let ((clause (car cla", -"uses)))\n (if (and (variable? (car clause))\n (vari", -"able=? (the 'else) (make-identifier (car clause) env)))\n (cons th", -"e-begin (cdr clause))\n (if (null? (cdr clause))\n ", -" (let ((tmp (make-identifier 'tmp here)))\n (list (the 'le", -"t) (list (list tmp (car clause)))\n (list the-if tmp t", -"mp (cons (the 'cond) (cdr clauses)))))\n (if (and (variable? (", -"cadr clause))\n (variable=? (the '=>) (make-identifie", -"r (cadr clause) env)))\n (let ((tmp (make-identifier 'tmp ", -"here)))\n (list (the 'let) (list (list tmp (car clause))", -")\n (list the-if tmp\n ", -" (list (car (cddr clause)) tmp)\n (c", -"ons (the 'cond) (cdr clauses)))))\n (list the-if (car clau", -"se)\n (cons the-begin (cdr clause))\n ", -" (cons (the 'cond) (cdr clauses)))))))))))\n\n(define-macro quasiquot", -"e\n (lambda (form env)\n\n (define (quasiquote? form)\n (and (pair? form)\n ", -" (variable? (car form))\n (variable=? (the 'quasiquote) (make-", -"identifier (car form) env))))\n\n (define (unquote? form)\n (and (pair? for", -"m)\n (variable? (car form))\n (variable=? (the 'unquote) (make", -"-identifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and ", -"(pair? form)\n (pair? (car form))\n (variable? (caar form))\n ", -" (variable=? (the 'unquote-splicing) (make-identifier (caar form) env)))", -")\n\n (define (qq depth expr)\n (cond\n ;; unquote\n ((unquote? e", -"xpr)\n (if (= depth 1)\n (car (cdr expr))\n (list (the", -" 'list)\n (list (the 'quote) (the 'unquote))\n (", -"qq (- depth 1) (car (cdr expr))))))\n ;; unquote-splicing\n ((unquote-", -"splicing? expr)\n (if (= depth 1)\n (list (the 'append)\n ", -" (car (cdr (car expr)))\n (qq depth (cdr expr)))\n ", -" (list (the 'cons)\n (list (the 'list)\n ", -" (list (the 'quote) (the 'unquote-splicing))\n (qq (- d", -"epth 1) (car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ", -" ;; quasiquote\n ((quasiquote? expr)\n (list (the 'list)\n ", -" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) (car (cd", -"r expr)))))\n ;; list\n ((pair? expr)\n (list (the 'cons)\n ", -" (qq depth (car expr))\n (qq depth (cdr expr))))\n ;; ve", -"ctor\n ((vector? expr)\n (list (the 'list->vector) (qq depth (vector-", -">list expr))))\n ;; simple datum\n (else\n (list (the 'quote) ex", -"pr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(define-macro let*\n (lamb", -"da (form env)\n (let ((bindings (car (cdr form)))\n (body (cdr (cd", -"r form))))\n (if (null? bindings)\n `(,(the 'let) () ,@body)\n ", -" `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n (,", -"(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n(define-macro letrec\n ", -" (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n\n(define-macro letrec*", -"\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ", -"(cdr (cdr form))))\n (let ((variables (map (lambda (v) `(,v #f)) (map car bi", -"ndings)))\n (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings)", -"))\n `(,(the 'let) (,@variables)\n ,@initials\n ,@body))))", -")\n\n(define-macro let-values\n (lambda (form env)\n `(,(the 'let*-values) ,@(cd", -"r form))))\n\n(define-macro let*-values\n (lambda (form env)\n (let ((formal (ca", -"r (cdr form)))\n (body (cdr (cdr form))))\n (if (null? formal)\n ", -" `(,(the 'let) () ,@body)\n `(,(the 'call-with-values) (,the-lambd", -"a () ,@(cdr (car formal)))\n (,(the 'lambda) (,@(car (car formal)))\n ", -" (,(the 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n(d", -"efine-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 arg", -"uments))\n (if (pair? formal)\n `((,the-set! ,(c", -"ar formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))\n ", -" (if (variable? formal)\n `((,the-set! ,for", -"mal ,args))\n '()))))))))))\n\n(define-macro do\n (lambda (f", -"orm env)\n (let ((bindings (car (cdr form)))\n (test (car (car (cd", -"r (cdr form)))))\n (cleanup (cdr (car (cdr (cdr form)))))\n (bo", -"dy (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 ,@cl", -"eanup)\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 ((tes", -"t (car (cdr form)))\n (body (cdr (cdr form))))\n `(,the-if ,test\n ", -" (,the-begin ,@body)\n #undefined))))\n\n(define-macro u", -"nless\n (lambda (form env)\n (let ((test (car (cdr form)))\n (body (cd", -"r (cdr form))))\n `(,the-if ,test\n #undefined\n ", -" (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (form env)\n (let ((key", -" (car (cdr form)))\n (clauses (cdr (cdr form))))\n (let ((the-ke", -"y (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 (lam", -"bda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ", -" ,(if (and (variable? (cadr clause))\n ", -" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ", -" `(,(car (cdr (cdr clause))) ,the-key)\n ", -" `(,the-begin ,@(cdr clause)))\n ,(loo", -"p (cdr clauses)))))))))))\n\n(define-macro parameterize\n (lambda (form env)\n (", -"let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(,(th", -"e 'with-parameter)\n (,(the 'lambda) ()\n ,@formal\n ,@body)", -"))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (let ((renames '()))\n ", -" (letrec\n ((rename (lambda (var)\n (let ((x (ass", -"q var renames)))\n (if x\n (cadr x", -")\n (begin\n (set! renames `", -"((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,rena", -"mes))\n (rename var))))))\n (walk (lambda (f", -" form)\n (cond\n ((variable? form)\n ", -" (f form))\n ((pair? form)\n `(,(", -"the 'cons) (walk f (car form)) (walk f (cdr form))))\n ((vecto", -"r? form)\n `(,(the 'list->vector) (walk f (vector->list form)", -")))\n (else\n `(,(the 'quote) ,form))))))\n ", -" (let ((form (walk rename (cadr form))))\n `(,(the 'let)\n ", -" ,(map cdr renames)\n ,form))))))\n\n(define-macro syntax-quasiquote\n ", -" (lambda (form env)\n (let ((renames '()))\n (letrec\n ((rename (l", -"ambda (var)\n (let ((x (assq var renames)))\n ", -" (if x\n (cadr x)\n (begi", -"n\n (set! renames `((,var ,(make-identifier var env) ", -"(,(the 'make-identifier) ',var ',env)) . ,renames))\n ", -" (rename var)))))))\n\n (define (syntax-quasiquote? form)\n (and (p", -"air? form)\n (variable? (car form))\n (variable=? (the", -" 'syntax-quasiquote) (make-identifier (car form) env))))\n\n (define (synta", -"x-unquote? form)\n (and (pair? form)\n (variable? (car form", -"))\n (variable=? (the 'syntax-unquote) (make-identifier (car form) ", -"env))))\n\n (define (syntax-unquote-splicing? form)\n (and (pair? f", -"orm)\n (pair? (car form))\n (variable? (caar form))\n ", -" (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar f", -"orm) env))))\n\n (define (qq depth expr)\n (cond\n ;; synt", -"ax-unquote\n ((syntax-unquote? expr)\n (if (= depth 1)\n ", -" (car (cdr expr))\n (list (the 'list)\n ", -" (list (the 'quote) (the 'syntax-unquote))\n (qq (- depth ", -"1) (car (cdr expr))))))\n ;; syntax-unquote-splicing\n ((synta", -"x-unquote-splicing? expr)\n (if (= depth 1)\n (list (the", -" 'append)\n (car (cdr (car expr)))\n (qq", -" depth (cdr expr)))\n (list (the 'cons)\n (lis", -"t (the 'list)\n (list (the 'quote) (the 'syntax-unquot", -"e-splicing))\n (qq (- depth 1) (car (cdr (car expr))))", -")\n (qq depth (cdr expr)))))\n ;; syntax-quasiquote", -"\n ((syntax-quasiquote? expr)\n (list (the 'list)\n ", -" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) (", -"car (cdr expr)))))\n ;; list\n ((pair? expr)\n (list", -" (the 'cons)\n (qq depth (car expr))\n (qq depth", -" (cdr expr))))\n ;; vector\n ((vector? expr)\n (list", -" (the 'list->vector) (qq depth (vector->list expr))))\n ;; variable\n ", -" ((variable? expr)\n (rename expr))\n ;; simple datum\n", -" (else\n (list (the 'quote) expr))))\n\n (let ((body (q", -"q 1 (cadr form))))\n `(,(the 'let)\n ,(map cdr renames)\n ", -" ,body))))))\n\n(define (transformer f)\n (lambda (form env)\n (let ((regis", -"ter1 (make-register))\n (register2 (make-register)))\n (letrec\n ", -" ((wrap (lambda (var1)\n (let ((var2 (register1 var1)))\n ", -" (if var2\n (cdr var2)\n ", -" (let ((var2 (make-identifier var1 env)))\n (reg", -"ister1 var1 var2)\n (register2 var2 var1)\n ", -" var2)))))\n (unwrap (lambda (var2)\n (", -"let ((var1 (register2 var2)))\n (if var1\n ", -" (cdr var1)\n var2))))\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? for", -"m)\n (list->vector (walk f (vector->list form))))\n ", -" (else\n form)))))\n (let ((form (cdr form)))\n ", -" (walk unwrap (apply f (walk wrap form))))))))\n\n(define-macro define-syn", -"tax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n (body (", -"cdr (cdr form))))\n (if (pair? formal)\n `(,(the 'define-syntax) ,(c", -"ar formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-define-macro ,fo", -"rmal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(define-macro letrec-syntax", -"\n (lambda (form env)\n (let ((formal (car (cdr form)))\n (body (cdr", -" (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n `(,(", -"the 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n ,@body", -"))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ", -",@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro define-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 co", -"nd-expand\n (lambda (form _)\n (letrec\n ((test (lambda (form)\n ", -" (or\n (eq? form 'else)\n (and (symbol? f", -"orm)\n (memq form (features)))\n (and (pair", -"? form)\n (case (car form)\n ((libra", -"ry) (find-library (cadr form)))\n ((not) (not (test (cadr", -" form))))\n ((and) (let loop ((form (cdr form)))\n ", -" (or (null? form)\n ", -" (and (test (car form)) (loop (cdr form))))))\n ((or) (le", -"t loop ((form (cdr form)))\n (and (pair? form)\n ", -" (or (test (car form)) (loop (cdr form))))))\n", -" (else #f)))))))\n (let loop ((clauses (cdr form)))\n", -" (if (null? clauses)\n #undefined\n (if (test (caar c", -"lauses))\n `(,the-begin ,@(cdar clauses))\n (loop (c", -"dr 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 (lambda (spec)\n (case (ca", -"r spec)\n ((only rename prefix except)\n (extract (", -"cadr spec)))\n (else\n (or (find-library spec) (err", -"or \"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 al", -"ist)) (cddr spec))))\n ((rename)\n (let ((alist (co", -"llect (cadr spec)))\n (renames (map (lambda (x) `((car x) .", -" (cadr x))) (cddr spec))))\n (map (lambda (s) (or (assq (car s)", -" renames) s)) alist)))\n ((prefix)\n (let ((alist (", -"collect (cadr spec))))\n (map (lambda (s) (cons (prefix (caddr ", -"spec) (car s)) (cdr s))) alist)))\n ((except)\n (le", -"t ((alist (collect (cadr spec))))\n (let loop ((alist alist))\n ", -" (if (null? alist)\n '()\n ", -" (if (memq (caar alist) (cddr spec))\n (lo", -"op (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 (letrec\n ((import\n ", -" (lambda (spec)\n (let ((lib (extract spec))\n ", -" (alist (collect spec)))\n (for-each\n ", -" (lambda (slot)\n (library-import lib (cdr slot) (car slot)", -"))\n alist)))))\n (for-each import (cdr form)))))))\n\n(", -"define-macro export\n (lambda (form _)\n (letrec\n ((collect\n (", -"lambda (spec)\n (cond\n ((symbol? spec)\n `(,sp", -"ec . ,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 (collect spec)))\n (librar", -"y-export (car slot) (cdr slot))))))\n (for-each export (cdr form)))))\n\n(expo", -"rt define lambda quote set! if begin define-macro\n let let* letrec letrec", -"*\n let-values let*-values define-values\n quasiquote unquote unquot", -"e-splicing\n and or\n cond case else =>\n do when unless\n ", -" parameterize\n define-syntax\n syntax-quote syntax-unquote\n ", -" syntax-quasiquote syntax-unquote-splicing\n let-syntax letrec-syntax\n ", -" syntax-error)\n\n\n", +"= (length form) 3)\n (if (identifier? (cadr form))\n (cons the-b", +"uiltin-set! (cdr form))\n (error \"illegal set! form\" form))\n (e", +"rror \"illegal set! form\" form))))\n\n(builtin:define check-formal\n (builtin:lambd", +"a (formal)\n (if (null? formal)\n #t\n (if (identifier? formal)\n ", +" #t\n (if (pair? formal)\n (if (identifier? (ca", +"r formal))\n (check-formal (cdr formal))\n #", +"f)\n #f)))))\n\n(builtin:define-macro lambda\n (builtin:lambda (form", +" env)\n (if (= (length form) 1)\n (error \"illegal lambda form\" form)\n ", +" (if (check-formal (cadr form))\n (list the-builtin-lambda (cadr f", +"orm) (cons the-begin (cddr form)))\n (error \"illegal lambda form\" form", +")))))\n\n(builtin:define-macro define\n (lambda (form env)\n ((lambda (len)\n ", +" (if (= len 1)\n (error \"illegal define form\" form)\n (if (i", +"dentifier? (cadr form))\n (if (= len 3)\n (cons th", +"e-builtin-define (cdr form))\n (error \"illegal define form\" for", +"m))\n (if (pair? (cadr form))\n (list the-define\n ", +" (car (cadr form))\n (cons the-lam", +"bda (cons (cdr (cadr form)) (cddr form))))\n (error \"define: bi", +"nding to non-varaible object\" form)))))\n (length form))))\n\n(builtin:define-m", +"acro define-macro\n (lambda (form env)\n (if (= (length form) 3)\n (if (", +"identifier? (cadr form))\n (cons the-builtin-define-macro (cdr form))\n", +" (error \"define-macro: binding to non-variable object\" form))\n ", +" (error \"illegal define-macro form\" form))))\n\n\n(define-macro syntax-error\n (lam", +"bda (form _)\n (apply error (cdr form))))\n\n(define-macro define-auxiliary-synt", +"ax\n (lambda (form _)\n (define message\n (string-append\n \"invalid u", +"se of auxiliary syntax: '\" (symbol->string (cadr form)) \"'\"))\n (list\n the", +"-define-macro\n (cadr form)\n (list the-lambda '_\n (list (the 'e", +"rror) message)))))\n\n(define-auxiliary-syntax else)\n(define-auxiliary-syntax =>)\n", +"(define-auxiliary-syntax unquote)\n(define-auxiliary-syntax unquote-splicing)\n(de", +"fine-auxiliary-syntax syntax-unquote)\n(define-auxiliary-syntax syntax-unquote-sp", +"licing)\n\n(define-macro let\n (lambda (form env)\n (if (identifier? (cadr form)", +")\n (list\n (list the-lambda '()\n (list the-define (c", +"adr form)\n (cons the-lambda\n (cons", +" (map car (car (cddr form)))\n (cdr (cddr form)))", +"))\n (cons (cadr form) (map cadr (car (cddr form))))))\n (con", +"s\n (cons\n the-lambda\n (cons (map car (cadr form))\n ", +" (cddr form)))\n (map cadr (cadr form))))))\n\n(define-macro and", +"\n (lambda (form env)\n (if (null? (cdr form))\n #t\n (if (null? (", +"cddr form))\n (cadr form)\n (list the-if\n (", +"cadr form)\n (cons (the 'and) (cddr form))\n #f)", +"))))\n\n(define-macro or\n (lambda (form env)\n (if (null? (cdr form))\n #", +"f\n (let ((tmp (make-identifier 'it env)))\n (list (the 'let)\n ", +" (list (list tmp (cadr form)))\n (list the-if\n ", +" tmp\n tmp\n (cons (the 'or)", +" (cddr form))))))))\n\n(define-macro cond\n (lambda (form env)\n (let ((clauses ", +"(cdr form)))\n (if (null? clauses)\n #undefined\n (let ((cla", +"use (car clauses)))\n (if (and (identifier? (car clause))\n ", +" (identifier=? (the 'else) (make-identifier (car clause) env)))\n ", +" (cons the-begin (cdr clause))\n (if (null? (cdr clause))\n ", +" (let ((tmp (make-identifier 'tmp here)))\n ", +" (list (the 'let) (list (list tmp (car clause)))\n (l", +"ist the-if tmp tmp (cons (the 'cond) (cdr clauses)))))\n (if (", +"and (identifier? (cadr clause))\n (identifier=? (the ", +"'=>) (make-identifier (cadr clause) env)))\n (let ((tmp (m", +"ake-identifier 'tmp here)))\n (list (the 'let) (list (li", +"st tmp (car clause)))\n (list the-if tmp\n ", +" (list (car (cddr clause)) tmp)\n ", +" (cons (the 'cond) (cdr clauses)))))\n (l", +"ist the-if (car clause)\n (cons the-begin (cdr claus", +"e))\n (cons (the 'cond) (cdr clauses)))))))))))\n\n(de", +"fine-macro quasiquote\n (lambda (form env)\n\n (define (quasiquote? form)\n ", +" (and (pair? form)\n (identifier? (car form))\n (identifier=? ", +"(the 'quasiquote) (make-identifier (car form) env))))\n\n (define (unquote? for", +"m)\n (and (pair? form)\n (identifier? (car form))\n (ident", +"ifier=? (the 'unquote) (make-identifier (car form) env))))\n\n (define (unquote", +"-splicing? form)\n (and (pair? form)\n (pair? (car form))\n ", +" (identifier? (caar form))\n (identifier=? (the 'unquote-splicing) (ma", +"ke-identifier (caar form) env))))\n\n (define (qq depth expr)\n (cond\n ", +" ;; unquote\n ((unquote? expr)\n (if (= depth 1)\n (car (c", +"dr expr))\n (list (the 'list)\n (list (the 'quote) (th", +"e 'unquote))\n (qq (- depth 1) (car (cdr expr))))))\n ;; un", +"quote-splicing\n ((unquote-splicing? expr)\n (if (= depth 1)\n ", +" (list (the 'append)\n (car (cdr (car expr)))\n ", +" (qq depth (cdr expr)))\n (list (the 'cons)\n (list ", +"(the 'list)\n (list (the 'quote) (the 'unquote-splicing))\n", +" (qq (- depth 1) (car (cdr (car expr)))))\n ", +" (qq depth (cdr expr)))))\n ;; quasiquote\n ((quasiquote? expr)\n ", +" (list (the 'list)\n (list (the 'quote) (the 'quasiquote))\n ", +" (qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n", +" (list (the 'cons)\n (qq depth (car expr))\n (qq ", +"depth (cdr expr))))\n ;; vector\n ((vector? expr)\n (list (the '", +"list->vector) (qq depth (vector->list expr))))\n ;; simple datum\n (el", +"se\n (list (the 'quote) expr))))\n\n (let ((x (cadr form)))\n (qq 1 x", +"))))\n\n(define-macro let*\n (lambda (form env)\n (let ((bindings (car (cdr form", +")))\n (body (cdr (cdr form))))\n (if (null? bindings)\n ", +"`(,(the 'let) () ,@body)\n `(,(the 'let) ((,(car (car bindings)) ,@(cdr ", +"(car bindings))))\n (,(the 'let*) (,@(cdr bindings))\n ,@bo", +"dy))))))\n\n(define-macro letrec\n (lambda (form env)\n `(,(the 'letrec*) ,@(cdr", +" form))))\n\n(define-macro letrec*\n (lambda (form env)\n (let ((bindings (car (", +"cdr form)))\n (body (cdr (cdr form))))\n (let ((variables (map (", +"lambda (v) `(,v #f)) (map car bindings)))\n (initials (map (lambda (v", +") `(,(the 'set!) ,@v)) bindings)))\n `(,(the 'let) (,@variables)\n ", +" ,@initials\n ,@body)))))\n\n(define-macro let-values\n (lambda (form env)", +"\n `(,(the 'let*-values) ,@(cdr form))))\n\n(define-macro let*-values\n (lambda ", +"(form env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form)", +")))\n (if (null? formal)\n `(,(the 'let) () ,@body)\n `(,(th", +"e 'call-with-values) (,the-lambda () ,@(cdr (car formal)))\n (,(the 'l", +"ambda) (,@(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 (l", +"et ((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 (identifier? formal)\n `((,the-define ,formal #unde", +"fined))\n '())))\n (,(the 'call-with-values) (,the-l", +"ambda () ,@body)\n (,the-lambda\n ,arguments\n ,@(l", +"et loop ((formal formal) (args arguments))\n (if (pair? formal)\n ", +" `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr f", +"ormal) `(,(the 'cdr) ,args)))\n (if (identifier? formal)\n ", +" `((,the-set! ,formal ,args))\n '())))))", +")))))\n\n(define-macro do\n (lambda (form env)\n (let ((bindings (car (cdr form)", +"))\n (test (car (car (cdr (cdr form)))))\n (cleanup (cdr (c", +"ar (cdr (cdr form)))))\n (body (cdr (cdr (cdr form)))))\n (let (", +"(loop (make-identifier 'loop here)))\n `(,(the 'let) ,loop ,(map (lambda (", +"x) `(,(car x) ,(cadr x))) bindings)\n (,the-if ,test\n ", +"(,the-begin\n ,@cleanup)\n (,the-begin\n ", +" ,@body\n (,loop ,@(map (lambda (x) (if (null? (c", +"dr (cdr x))) (car x) (car (cdr (cdr x))))) bindings)))))))))\n\n(define-macro when", +"\n (lambda (form env)\n (let ((test (car (cdr form)))\n (body (cdr (cd", +"r 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 (cdr (cdr form))))\n `(,the-if ,test\n ", +" #undefined\n (,the-begin ,@body)))))\n\n(define-macro case", +"\n (lambda (form env)\n (let ((key (car (cdr form)))\n (clauses (c", +"dr (cdr form))))\n (let ((the-key (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 (identifier? (car clause", +"))\n (identifier=? (the 'else) (make-identi", +"fier (car clause) env)))\n #t\n ", +" `(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-qu", +"ote ,x))) (car clause))))\n ,(if (and (identifier? (c", +"adr clause))\n (identifier=? (the '=>) (mak", +"e-identifier (cadr clause) env)))\n `(,(car (cdr", +" (cdr clause))) ,the-key)\n `(,the-begin ,@(cdr ", +"clause)))\n ,(loop (cdr clauses)))))))))))\n\n(define-m", +"acro parameterize\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ", +" (body (cdr (cdr form))))\n `(,(the 'with-parameter)\n (,(the 'l", +"ambda) ()\n ,@formal\n ,@body)))))\n\n(define-macro syntax-quote\n (", +"lambda (form env)\n (let ((renames '()))\n (letrec\n ((rename (lam", +"bda (var)\n (let ((x (assq var renames)))\n ", +" (if x\n (cadr x)\n (begin\n", +" (set! renames `((,var ,(make-identifier var env) (,", +"(the 'make-identifier) ',var ',env)) . ,renames))\n (", +"rename var))))))\n (walk (lambda (f form)\n (cond\n ", +" ((identifier? form)\n (f form))\n ", +" ((pair? form)\n `(,(the 'cons) (walk f (car form)) (wa", +"lk f (cdr form))))\n ((vector? form)\n `(,(", +"the 'list->vector) (walk f (vector->list form))))\n (else\n ", +" `(,(the 'quote) ,form))))))\n (let ((form (walk rename (c", +"adr form))))\n `(,(the 'let)\n ,(map cdr renames)\n ", +",form))))))\n\n(define-macro syntax-quasiquote\n (lambda (form env)\n (let ((ren", +"ames '()))\n (letrec\n ((rename (lambda (var)\n (", +"let ((x (assq var renames)))\n (if x\n ", +" (cadr x)\n (begin\n (se", +"t! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',e", +"nv)) . ,renames))\n (rename var)))))))\n\n (defi", +"ne (syntax-quasiquote? form)\n (and (pair? form)\n (identif", +"ier? (car form))\n (identifier=? (the 'syntax-quasiquote) (make-ide", +"ntifier (car form) env))))\n\n (define (syntax-unquote? form)\n (an", +"d (pair? form)\n (identifier? (car form))\n (identifie", +"r=? (the 'syntax-unquote) (make-identifier (car form) env))))\n\n (define (", +"syntax-unquote-splicing? form)\n (and (pair? form)\n (pair?", +" (car form))\n (identifier? (caar form))\n (identifier", +"=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env))))\n\n ", +"(define (qq depth expr)\n (cond\n ;; syntax-unquote\n ", +"((syntax-unquote? expr)\n (if (= depth 1)\n (car (cdr ex", +"pr))\n (list (the 'list)\n (list (the 'quote) ", +"(the 'syntax-unquote))\n (qq (- depth 1) (car (cdr expr)))))", +")\n ;; syntax-unquote-splicing\n ((syntax-unquote-splicing? ex", +"pr)\n (if (= depth 1)\n (list (the 'append)\n ", +" (car (cdr (car expr)))\n (qq depth (cdr expr)))\n ", +" (list (the 'cons)\n (list (the 'list)\n ", +" (list (the 'quote) (the 'syntax-unquote-splicing))\n ", +" (qq (- depth 1) (car (cdr (car expr)))))\n ", +" (qq depth (cdr expr)))))\n ;; syntax-quasiquote\n ((syntax-q", +"uasiquote? expr)\n (list (the 'list)\n (list (the 'quo", +"te) (the 'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))))\n ", +" ;; list\n ((pair? expr)\n (list (the 'cons)\n ", +" (qq depth (car expr))\n (qq depth (cdr expr))))\n ", +" ;; vector\n ((vector? expr)\n (list (the 'list->vector) (", +"qq depth (vector->list expr))))\n ;; identifier\n ((identifier", +"? expr)\n (rename expr))\n ;; simple datum\n (else\n ", +" (list (the 'quote) expr))))\n\n (let ((body (qq 1 (cadr form))))", +"\n `(,(the 'let)\n ,(map cdr renames)\n ,body))))))\n", +"\n(define (transformer f)\n (lambda (form env)\n (let ((register1 (make-registe", +"r))\n (register2 (make-register)))\n (letrec\n ((wrap (lambd", +"a (var1)\n (let ((var2 (register1 var1)))\n ", +"(if var2\n (cdr var2)\n (let ((var", +"2 (make-identifier var1 env)))\n (register1 var1 var2)\n", +" (register2 var2 var1)\n var2", +")))))\n (unwrap (lambda (var2)\n (let ((var1 (regist", +"er2 var2)))\n (if var1\n (cdr var1", +")\n var2))))\n (walk (lambda (f form)\n ", +" (cond\n ((identifier? form)\n (f", +" form))\n ((pair? form)\n (cons (walk f (ca", +"r 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 u", +"nwrap (apply f (walk wrap form))))))))\n\n(define-macro define-syntax\n (lambda (f", +"orm 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 'tra", +"nsformer) (,the-begin ,@body)))))))\n\n(define-macro letrec-syntax\n (lambda (form", +" env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n ", +" `(let ()\n ,@(map (lambda (x)\n `(,(the 'define-synt", +"ax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n(define-ma", +"cro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(cdr form))))\n", +"\n\n;;; library primitives\n\n(define-macro define-library\n (lambda (form _)\n (l", +"et ((name (cadr form))\n (body (cddr form)))\n (let ((old-library (c", +"urrent-library))\n (new-library (or (find-library name) (make-library ", +"name))))\n (let ((env (library-environment new-library)))\n (curre", +"nt-library new-library)\n (for-each (lambda (expr) (eval expr env)) body", +")\n (current-library old-library))))))\n\n(define-macro cond-expand\n (lam", +"bda (form _)\n (letrec\n ((test (lambda (form)\n (or\n ", +" (eq? form 'else)\n (and (symbol? form)\n ", +" (memq form (features)))\n (and (pair? form)\n ", +" (case (car form)\n ((library) (find-librar", +"y (cadr form)))\n ((not) (not (test (cadr form))))\n ", +" ((and) (let loop ((form (cdr form)))\n ", +" (or (null? form)\n (and (test (car", +" form)) (loop (cdr form))))))\n ((or) (let loop ((form (c", +"dr form)))\n (and (pair? form)\n ", +" (or (test (car form)) (loop (cdr form))))))\n ", +" (else #f)))))))\n (let loop ((clauses (cdr form)))\n (if (nul", +"l? clauses)\n #undefined\n (if (test (caar clauses))\n ", +" `(,the-begin ,@(cdar clauses))\n (loop (cdr clauses))))))", +"))\n\n(define-macro import\n (lambda (form _)\n (let ((caddr\n (lambda ", +"(x) (car (cdr (cdr x)))))\n (prefix\n (lambda (prefix symbol)\n ", +" (string->symbol\n (string-append\n (symbol-", +">string prefix)\n (symbol->string symbol))))))\n (letrec\n ", +" ((extract\n (lambda (spec)\n (case (car spec)\n ", +" ((only rename prefix except)\n (extract (cadr spec)))\n ", +" (else\n (or (find-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 ((rename)\n (let ((alist (collect (cadr spec", +")))\n (renames (map (lambda (x) `((car x) . (cadr x))) (cdd", +"r spec))))\n (map (lambda (s) (or (assq (car s) renames) s)) al", +"ist)))\n ((prefix)\n (let ((alist (collect (cadr sp", +"ec))))\n (map (lambda (s) (cons (prefix (caddr spec) (car s)) (", +"cdr s))) alist)))\n ((except)\n (let ((alist (colle", +"ct (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 \"librar", +"y not found\" spec))))\n (map (lambda (x) (cons x x)) (library-e", +"xports lib))))))))\n (letrec\n ((import\n (lambda (", +"spec)\n (let ((lib (extract spec))\n (alist ", +"(collect spec)))\n (for-each\n (lambda (slot)", +"\n (library-import lib (cdr slot) (car slot)))\n ", +" alist)))))\n (for-each import (cdr form)))))))\n\n(define-macro exp", +"ort\n (lambda (form _)\n (letrec\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 (collect spec)))\n (library-export (car sl", +"ot) (cdr slot))))))\n (for-each export (cdr form)))))\n\n(export define lambda", +" quote set! if begin define-macro\n let let* letrec letrec*\n let-va", +"lues let*-values define-values\n quasiquote unquote unquote-splicing\n ", +" and or\n cond case else =>\n do when unless\n parameterize\n", +" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiqu", +"ote syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-erro", +"r)\n\n\n", "", "" }; diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index cc9222d3..ed08989a 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -39,15 +39,15 @@ static pic_value expand(pic_state *, pic_value, struct pic_env *, pic_value); static pic_value expand_lambda(pic_state *, pic_value, struct pic_env *); static pic_value -expand_var(pic_state *pic, pic_value var, struct pic_env *env, pic_value deferred) +expand_var(pic_state *pic, pic_id *id, struct pic_env *env, pic_value deferred) { struct pic_proc *mac; pic_sym *functor; - functor = pic_resolve_variable(pic, env, var); + functor = pic_lookup_identifier(pic, id, env); if ((mac = find_macro(pic, functor)) != NULL) { - return expand(pic, pic_apply2(pic, mac, var, pic_obj_value(env)), env, deferred); + return expand(pic, pic_apply2(pic, mac, pic_obj_value(id), pic_obj_value(env)), env, deferred); } return pic_obj_value(functor); } @@ -116,10 +116,10 @@ expand_lambda(pic_state *pic, pic_value expr, struct pic_env *env) in = pic_make_env(pic, env); for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) { - pic_add_variable(pic, in, pic_car(pic, a)); + pic_add_identifier(pic, pic_id_ptr(pic_car(pic, a)), in); } - if (pic_var_p(a)) { - pic_add_variable(pic, in, a); + if (pic_id_p(a)) { + pic_add_identifier(pic, pic_id_ptr(a), in); } deferred = pic_list1(pic, pic_nil_value()); @@ -136,11 +136,12 @@ static pic_value expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred) { pic_sym *uid; - pic_value var, val; + pic_id *id; + pic_value val; - var = pic_cadr(pic, expr); - if ((uid = pic_find_variable(pic, env, var)) == NULL) { - uid = pic_add_variable(pic, env, var); + id = pic_id_ptr(pic_cadr(pic, expr)); + if ((uid = pic_find_identifier(pic, id, env)) == NULL) { + uid = pic_add_identifier(pic, id, env); } else { shadow_macro(pic, uid); } @@ -152,17 +153,18 @@ expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value def static pic_value expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) { - pic_value var, val; + pic_id *id; + pic_value val; pic_sym *uid; - var = pic_cadr(pic, expr); - if ((uid = pic_find_variable(pic, env, var)) == NULL) { - uid = pic_add_variable(pic, env, var); + id = pic_id_ptr(pic_cadr(pic, expr)); + if ((uid = pic_find_identifier(pic, id, env)) == NULL) { + uid = pic_add_identifier(pic, id, env); } val = pic_eval(pic, pic_list_ref(pic, expr, 2), env); if (! pic_proc_p(val)) { - pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); + pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", pic_identifier_name(pic, id)); } define_macro(pic, uid, pic_proc_ptr(val)); @@ -176,7 +178,7 @@ expand_node(pic_state *pic, pic_value expr, struct pic_env *env, pic_value defer switch (pic_type(expr)) { case PIC_TT_ID: case PIC_TT_SYMBOL: { - return expand_var(pic, expr, env, deferred); + return expand_var(pic, pic_id_ptr(expr), env, deferred); } case PIC_TT_PAIR: { struct pic_proc *mac; @@ -185,10 +187,10 @@ expand_node(pic_state *pic, pic_value expr, struct pic_env *env, pic_value defer pic_errorf(pic, "cannot expand improper list: ~s", expr); } - if (pic_var_p(pic_car(pic, expr))) { + if (pic_id_p(pic_car(pic, expr))) { pic_sym *functor; - functor = pic_resolve_variable(pic, env, pic_car(pic, expr)); + functor = pic_lookup_identifier(pic, pic_id_ptr(pic_car(pic, expr)), env); if (functor == pic->sDEFINE_MACRO) { return expand_defmacro(pic, expr, env); diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index 3114f772..33d37a9e 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -333,8 +333,8 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) break; } case PIC_TT_ID: { - gc_mark(pic, obj->u.id.var); - LOOP(obj->u.id.env); + gc_mark_object(pic, (struct pic_object *)obj->u.id.u.id.id); + LOOP(obj->u.id.u.id.env); break; } case PIC_TT_ENV: { @@ -343,7 +343,7 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) for (it = kh_begin(h); it != kh_end(h); ++it) { if (kh_exist(h, it)) { - gc_mark_object(pic, kh_key(h, it)); + gc_mark_object(pic, (struct pic_object *)kh_key(h, it)); gc_mark_object(pic, (struct pic_object *)kh_val(h, it)); } } diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index bf015a8b..dad2225d 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -162,10 +162,6 @@ bool pic_eq_p(pic_value, pic_value); bool pic_eqv_p(pic_value, pic_value); bool pic_equal_p(pic_state *, pic_value, pic_value); -pic_sym *pic_intern(pic_state *, const char *); -pic_sym *pic_intern_str(pic_state *, pic_str *); -const char *pic_symbol_name(pic_state *, pic_sym *); - pic_value pic_read(pic_state *, struct pic_port *); pic_value pic_read_cstr(pic_state *, const char *); diff --git a/extlib/benz/include/picrin/macro.h b/extlib/benz/include/picrin/macro.h index db01279f..7680f50e 100644 --- a/extlib/benz/include/picrin/macro.h +++ b/extlib/benz/include/picrin/macro.h @@ -9,13 +9,7 @@ extern "C" { #endif -KHASH_DECLARE(env, void *, pic_sym *) - -struct pic_id { - PIC_OBJECT_HEADER - pic_value var; - struct pic_env *env; -}; +KHASH_DECLARE(env, pic_id *, pic_sym *) struct pic_env { PIC_OBJECT_HEADER @@ -24,23 +18,16 @@ struct pic_env { pic_str *prefix; }; -#define pic_id_p(v) (pic_type(v) == PIC_TT_ID) -#define pic_id_ptr(v) ((struct pic_id *)pic_ptr(v)) - #define pic_env_p(v) (pic_type(v) == PIC_TT_ENV) #define pic_env_ptr(v) ((struct pic_env *)pic_ptr(v)) -struct pic_id *pic_make_id(pic_state *, pic_value, struct pic_env *); struct pic_env *pic_make_topenv(pic_state *, pic_str *); struct pic_env *pic_make_env(pic_state *, struct pic_env *); -pic_sym *pic_add_variable(pic_state *, struct pic_env *, pic_value); -pic_sym *pic_put_variable(pic_state *, struct pic_env *, pic_value, pic_sym *); -pic_sym *pic_find_variable(pic_state *, struct pic_env *, pic_value); -pic_sym *pic_resolve_variable(pic_state *, struct pic_env *, pic_value); - -bool pic_var_p(pic_value); -pic_sym *pic_var_name(pic_state *, pic_value); +pic_sym *pic_add_identifier(pic_state *, pic_id *, struct pic_env *); +pic_sym *pic_put_identifier(pic_state *, pic_id *, pic_sym *, struct pic_env *); +pic_sym *pic_find_identifier(pic_state *, pic_id *, struct pic_env *); +pic_sym *pic_lookup_identifier(pic_state *, pic_id *, struct pic_env *); #if defined(__cplusplus) } diff --git a/extlib/benz/include/picrin/symbol.h b/extlib/benz/include/picrin/symbol.h index 601802c8..1237357d 100644 --- a/extlib/benz/include/picrin/symbol.h +++ b/extlib/benz/include/picrin/symbol.h @@ -9,13 +9,33 @@ extern "C" { #endif -struct pic_symbol { - PIC_OBJECT_HEADER - const char *cstr; +struct pic_id { + union { + struct pic_symbol { + PIC_OBJECT_HEADER + const char *cstr; + } sym; + struct { + PIC_OBJECT_HEADER + struct pic_id *id; + struct pic_env *env; + } id; + } u; }; #define pic_sym_p(v) (pic_type(v) == PIC_TT_SYMBOL) -#define pic_sym_ptr(v) ((struct pic_symbol *)pic_ptr(v)) +#define pic_sym_ptr(v) ((pic_sym *)pic_ptr(v)) + +#define pic_id_p(v) (pic_type(v) == PIC_TT_ID || pic_type(v) == PIC_TT_SYMBOL) +#define pic_id_ptr(v) ((pic_id *)pic_ptr(v)) + +pic_sym *pic_intern(pic_state *, const char *); +pic_sym *pic_intern_str(pic_state *, pic_str *); + +pic_id *pic_make_identifier(pic_state *, pic_id *, struct pic_env *); + +const char *pic_symbol_name(pic_state *, pic_sym *); +const char *pic_identifier_name(pic_state *, pic_id *); #if defined(__cplusplus) } diff --git a/extlib/benz/include/picrin/type.h b/extlib/benz/include/picrin/type.h index b0a27e2e..9293780a 100644 --- a/extlib/benz/include/picrin/type.h +++ b/extlib/benz/include/picrin/type.h @@ -183,6 +183,7 @@ struct pic_env; /* set aliases to basic types */ typedef struct pic_symbol pic_sym; +typedef struct pic_id pic_id; typedef struct pic_pair pic_pair; typedef struct pic_string pic_str; typedef struct pic_vector pic_vec; diff --git a/extlib/benz/lib.c b/extlib/benz/lib.c index 71a18f6a..0faac96b 100644 --- a/extlib/benz/lib.c +++ b/extlib/benz/lib.c @@ -22,10 +22,10 @@ make_library_env(pic_state *pic, pic_value name) env = pic_make_topenv(pic, prefix); /* set up default environment */ - pic_put_variable(pic, env, pic_obj_value(pic->sDEFINE_LIBRARY), pic->sDEFINE_LIBRARY); - pic_put_variable(pic, env, pic_obj_value(pic->sIMPORT), pic->sIMPORT); - pic_put_variable(pic, env, pic_obj_value(pic->sEXPORT), pic->sEXPORT); - pic_put_variable(pic, env, pic_obj_value(pic->sCOND_EXPAND), pic->sCOND_EXPAND); + pic_put_identifier(pic, (pic_id *)pic->sDEFINE_LIBRARY, pic->sDEFINE_LIBRARY, env); + pic_put_identifier(pic, (pic_id *)pic->sIMPORT, pic->sIMPORT, env); + pic_put_identifier(pic, (pic_id *)pic->sEXPORT, pic->sEXPORT, env); + pic_put_identifier(pic, (pic_id *)pic->sCOND_EXPAND, pic->sCOND_EXPAND, env); return env; } @@ -76,10 +76,10 @@ pic_import(pic_state *pic, struct pic_lib *lib) pic_dict_for_each (name, lib->exports, it) { realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name)); - if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(realname))) == NULL) { + if ((uid = pic_find_identifier(pic, (pic_id *)realname, lib->env)) == NULL) { pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname)); } - pic_put_variable(pic, pic->lib->env, pic_obj_value(name), uid); + pic_put_identifier(pic, (pic_id *)name, uid, pic->lib->env); } } @@ -156,10 +156,10 @@ pic_lib_library_import(pic_state *pic) realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name)); } - if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(realname))) == NULL) { + if ((uid = pic_find_identifier(pic, (pic_id *)realname, lib->env)) == NULL) { pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname)); } else { - pic_put_variable(pic, pic->lib->env, pic_obj_value(alias), uid); + pic_put_identifier(pic, (pic_id *)alias, uid, pic->lib->env); } return pic_undef_value(); diff --git a/extlib/benz/macro.c b/extlib/benz/macro.c index 3b052d46..c768427c 100644 --- a/extlib/benz/macro.c +++ b/extlib/benz/macro.c @@ -4,26 +4,7 @@ #include "picrin.h" -KHASH_DEFINE(env, void *, pic_sym *, kh_ptr_hash_func, kh_ptr_hash_equal) - -bool -pic_var_p(pic_value obj) -{ - return pic_sym_p(obj) || pic_id_p(obj); -} - -struct pic_id * -pic_make_id(pic_state *pic, pic_value var, struct pic_env *env) -{ - struct pic_id *id; - - assert(pic_var_p(var)); - - id = (struct pic_id *)pic_obj_alloc(pic, sizeof(struct pic_id), PIC_TT_ID); - id->var = var; - id->env = env; - return id; -} +KHASH_DEFINE(env, pic_id *, pic_sym *, kh_ptr_hash_func, kh_ptr_hash_equal) struct pic_env * pic_make_env(pic_state *pic, struct pic_env *up) @@ -52,59 +33,42 @@ pic_make_topenv(pic_state *pic, pic_str *prefix) } pic_sym * -pic_var_name(pic_state PIC_UNUSED(*pic), pic_value var) -{ - assert(pic_var_p(var)); - - while (pic_id_p(var)) { - var = pic_id_ptr(var)->var; - } - return pic_sym_ptr(var); -} - -pic_sym * -pic_add_variable(pic_state *pic, struct pic_env *env, pic_value var) +pic_add_identifier(pic_state *pic, pic_id *id, struct pic_env *env) { const char *name; pic_sym *uid; pic_str *str; - assert(pic_var_p(var)); + name = pic_identifier_name(pic, id); - name = pic_symbol_name(pic, pic_var_name(pic, var)); - - if (env->up == NULL && pic_sym_p(var)) { /* toplevel & public */ + if (env->up == NULL && pic_sym_p(pic_obj_value(id))) { /* toplevel & public */ str = pic_format(pic, "%s/%s", pic_str_cstr(pic, env->prefix), name); } else { str = pic_format(pic, ".%s.%d", name, pic->ucnt++); } uid = pic_intern_str(pic, str); - return pic_put_variable(pic, env, var, uid); + return pic_put_identifier(pic, id, uid, env); } pic_sym * -pic_put_variable(pic_state *pic, struct pic_env *env, pic_value var, pic_sym *uid) +pic_put_identifier(pic_state *pic, pic_id *id, pic_sym *uid, struct pic_env *env) { khiter_t it; int ret; - assert(pic_var_p(var)); - - it = kh_put(env, &env->map, pic_ptr(var), &ret); + it = kh_put(env, &env->map, id, &ret); kh_val(&env->map, it) = uid; return uid; } pic_sym * -pic_find_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var) +pic_find_identifier(pic_state PIC_UNUSED(*pic), pic_id *id, struct pic_env *env) { khiter_t it; - assert(pic_var_p(var)); - - it = kh_get(env, &env->map, pic_ptr(var)); + it = kh_get(env, &env->map, id); if (it == kh_end(&env->map)) { return NULL; } @@ -112,129 +76,37 @@ pic_find_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var } static pic_sym * -lookup(void *var, struct pic_env *env) +lookup(pic_state *pic, pic_id *id, struct pic_env *env) { - khiter_t it; + pic_sym *uid = NULL; while (env != NULL) { - it = kh_get(env, &env->map, var); - if (it != kh_end(&env->map)) { - return kh_val(&env->map, it); + uid = pic_find_identifier(pic, id, env); + if (uid != NULL) { + break; } env = env->up; } - return NULL; + return uid; } pic_sym * -pic_resolve_variable(pic_state *pic, struct pic_env *env, pic_value var) +pic_lookup_identifier(pic_state *pic, pic_id *id, struct pic_env *env) { pic_sym *uid; - assert(env != NULL); - - pic_assert_type(pic, var, var); - - while ((uid = lookup(pic_ptr(var), env)) == NULL) { - if (pic_sym_p(var)) { + while ((uid = lookup(pic, id, env)) == NULL) { + if (pic_sym_p(pic_obj_value(id))) { break; } - env = pic_id_ptr(var)->env; - var = pic_id_ptr(var)->var; + env = id->u.id.env; /* do not overwrite id first */ + id = id->u.id.id; } if (uid == NULL) { while (env->up != NULL) { env = env->up; } - uid = pic_add_variable(pic, env, var); + uid = pic_add_identifier(pic, id, env); } return uid; } - -static pic_value -pic_macro_identifier_p(pic_state *pic) -{ - pic_value obj; - - pic_get_args(pic, "o", &obj); - - return pic_bool_value(pic_id_p(obj)); -} - -static pic_value -pic_macro_make_identifier(pic_state *pic) -{ - pic_value var, env; - - pic_get_args(pic, "oo", &var, &env); - - pic_assert_type(pic, var, var); - pic_assert_type(pic, env, env); - - return pic_obj_value(pic_make_id(pic, var, pic_env_ptr(env))); -} - -static pic_value -pic_macro_identifier_variable(pic_state *pic) -{ - pic_value id; - - pic_get_args(pic, "o", &id); - - pic_assert_type(pic, id, id); - - return pic_id_ptr(id)->var; -} - -static pic_value -pic_macro_identifier_environment(pic_state *pic) -{ - pic_value id; - - pic_get_args(pic, "o", &id); - - pic_assert_type(pic, id, id); - - return pic_obj_value(pic_id_ptr(id)->env); -} - -static pic_value -pic_macro_variable_p(pic_state *pic) -{ - pic_value obj; - - pic_get_args(pic, "o", &obj); - - return pic_bool_value(pic_var_p(obj)); -} - -static pic_value -pic_macro_variable_eq_p(pic_state *pic) -{ - int argc, i; - pic_value *argv; - - pic_get_args(pic, "*", &argc, &argv); - - for (i = 0; i < argc; ++i) { - if (! pic_var_p(argv[i])) { - return pic_false_value(); - } - if (! pic_equal_p(pic, argv[i], argv[0])) { - return pic_false_value(); - } - } - return pic_true_value(); -} - -void -pic_init_macro(pic_state *pic) -{ - pic_defun(pic, "make-identifier", pic_macro_make_identifier); - pic_defun(pic, "identifier?", pic_macro_identifier_p); - pic_defun(pic, "identifier-variable", pic_macro_identifier_variable); - pic_defun(pic, "identifier-environment", pic_macro_identifier_environment); - - pic_defun(pic, "variable?", pic_macro_variable_p); - pic_defun(pic, "variable=?", pic_macro_variable_eq_p); -} diff --git a/extlib/benz/state.c b/extlib/benz/state.c index ba398418..44e0cb66 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -30,7 +30,6 @@ void pic_init_cont(pic_state *); void pic_init_char(pic_state *); void pic_init_error(pic_state *); void pic_init_str(pic_state *); -void pic_init_macro(pic_state *); void pic_init_var(pic_state *); void pic_init_write(pic_state *); void pic_init_read(pic_state *); @@ -112,13 +111,13 @@ pic_features(pic_state *pic) pic_sym *nick, *real; \ nick = pic_intern(pic, "builtin:" name); \ real = pic_intern(pic, name); \ - pic_put_variable(pic, pic->lib->env, pic_obj_value(nick), real); \ + pic_put_identifier(pic, (pic_id *)nick, real, pic->lib->env); \ } while (0) #define declare_vm_procedure(name) do { \ - pic_sym *id; \ - id = pic_intern(pic, name); \ - pic_put_variable(pic, pic->lib->env, pic_obj_value(id), id); \ + pic_sym *sym; \ + sym = pic_intern(pic, name); \ + pic_put_identifier(pic, (pic_id *)sym, sym, pic->lib->env); \ } while (0) static void @@ -172,7 +171,6 @@ pic_init_core(pic_state *pic) pic_init_char(pic); DONE; pic_init_error(pic); DONE; pic_init_str(pic); DONE; - pic_init_macro(pic); DONE; pic_init_var(pic); DONE; pic_init_write(pic); DONE; pic_init_read(pic); DONE; diff --git a/extlib/benz/symbol.c b/extlib/benz/symbol.c index 3525e44d..f42c31cf 100644 --- a/extlib/benz/symbol.c +++ b/extlib/benz/symbol.c @@ -41,12 +41,33 @@ pic_intern(pic_state *pic, const char *cstr) return sym; } +pic_id * +pic_make_identifier(pic_state *pic, pic_id *id, struct pic_env *env) +{ + pic_id *nid; + + nid = (pic_id *)pic_obj_alloc(pic, sizeof(pic_id), PIC_TT_ID); + nid->u.id.id = id; + nid->u.id.env = env; + return nid; +} + const char * pic_symbol_name(pic_state PIC_UNUSED(*pic), pic_sym *sym) { return sym->cstr; } +const char * +pic_identifier_name(pic_state *pic, pic_id *id) +{ + while (! pic_sym_p(pic_obj_value(id))) { + id = id->u.id.id; + } + + return pic_symbol_name(pic, (pic_sym *)id); +} + static pic_value pic_symbol_symbol_p(pic_state *pic) { @@ -96,13 +117,91 @@ pic_symbol_string_to_symbol(pic_state *pic) return pic_obj_value(pic_intern_str(pic, str)); } +static pic_value +pic_symbol_identifier_p(pic_state *pic) +{ + pic_value obj; + + pic_get_args(pic, "o", &obj); + + return pic_bool_value(pic_id_p(obj)); +} + +static pic_value +pic_symbol_make_identifier(pic_state *pic) +{ + pic_value id, env; + + pic_get_args(pic, "oo", &id, &env); + + pic_assert_type(pic, id, id); + pic_assert_type(pic, env, env); + + return pic_obj_value(pic_make_identifier(pic, pic_id_ptr(id), pic_env_ptr(env))); +} + +static pic_value +pic_symbol_identifier_variable(pic_state *pic) +{ + pic_value id; + + pic_get_args(pic, "o", &id); + + pic_assert_type(pic, id, id); + + if (pic_sym_p(id)) { + pic_errorf(pic, "expected non-symbol identifier, but got symbol ~s", id); + } + + return pic_obj_value(pic_id_ptr(id)->u.id.id); +} + +static pic_value +pic_symbol_identifier_environment(pic_state *pic) +{ + pic_value id; + + pic_get_args(pic, "o", &id); + + pic_assert_type(pic, id, id); + + if (pic_sym_p(id)) { + pic_errorf(pic, "expected non-symbol identifier, but got symbol ~s", id); + } + + return pic_obj_value(pic_id_ptr(id)->u.id.env); +} + +static pic_value +pic_symbol_identifier_eq_p(pic_state *pic) +{ + int argc, i; + pic_value *argv; + + pic_get_args(pic, "*", &argc, &argv); + + for (i = 0; i < argc; ++i) { + if (! pic_id_p(argv[i])) { + return pic_false_value(); + } + if (! pic_equal_p(pic, argv[i], argv[0])) { + return pic_false_value(); + } + } + return pic_true_value(); +} + void pic_init_symbol(pic_state *pic) { pic_defun(pic, "symbol?", pic_symbol_symbol_p); - + pic_defun(pic, "symbol=?", pic_symbol_symbol_eq_p); pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string); pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol); - pic_defun(pic, "symbol=?", pic_symbol_symbol_eq_p); + pic_defun(pic, "make-identifier", pic_symbol_make_identifier); + pic_defun(pic, "identifier?", pic_symbol_identifier_p); + pic_defun(pic, "identifier=?", pic_symbol_identifier_eq_p); + pic_defun(pic, "identifier-variable", pic_symbol_identifier_variable); + pic_defun(pic, "identifier-environment", pic_symbol_identifier_environment); } diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index a75d9fa9..180fcbaf 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -922,8 +922,8 @@ pic_define_(pic_state *pic, const char *name, pic_value val) sym = pic_intern(pic, name); - if ((uid = pic_find_variable(pic, pic->lib->env, pic_obj_value(sym))) == NULL) { - uid = pic_add_variable(pic, pic->lib->env, pic_obj_value(sym)); + if ((uid = pic_find_identifier(pic, (pic_id *)sym, pic->lib->env)) == NULL) { + uid = pic_add_identifier(pic, (pic_id *)sym, pic->lib->env); } else { if (pic_reg_has(pic, pic->globals, uid)) { pic_warnf(pic, "redefining variable: ~s", pic_obj_value(uid)); @@ -973,7 +973,7 @@ pic_ref(pic_state *pic, struct pic_lib *lib, const char *name) sym = pic_intern(pic, name); - if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(sym))) == NULL) { + if ((uid = pic_find_identifier(pic, (pic_id *)sym, lib->env)) == NULL) { pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); } @@ -987,7 +987,7 @@ pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val) sym = pic_intern(pic, name); - if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(sym))) == NULL) { + if ((uid = pic_find_identifier(pic, (pic_id *)sym, lib->env)) == NULL) { pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); } diff --git a/extlib/benz/write.c b/extlib/benz/write.c index d75c4d37..0092da02 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -283,7 +283,7 @@ write_core(struct writer_control *p, pic_value obj) xfprintf(pic, file, pic_true_p(obj) ? "#t" : "#f"); break; case PIC_TT_ID: - xfprintf(pic, file, "#", pic_symbol_name(pic, pic_var_name(pic, obj))); + xfprintf(pic, file, "#", pic_identifier_name(pic, pic_id_ptr(obj))); break; case PIC_TT_EOF: xfprintf(pic, file, "#.(eof-object)");