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

symbol is an identifier

This commit is contained in:
Yuichi Nishiwaki 2016-02-06 23:15:53 +09:00
parent bf68695707
commit e51d3db812
17 changed files with 511 additions and 536 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
contrib/10.macro/macro.scm
View File

@ -6,10 +6,9 @@
(export define-macro (export define-macro
make-identifier make-identifier
identifier? identifier?
identifier=?
identifier-variable identifier-variable
identifier-environment identifier-environment)
variable?
variable=?)
;; simple macro ;; simple macro
@ -51,7 +50,7 @@
id)))))) id))))))
(walk (lambda (f form) (walk (lambda (f form)
(cond (cond
((variable? form) ((identifier? form)
(f form)) (f form))
((pair? form) ((pair? form)
(cons (walk f (car form)) (walk f (cdr form)))) (cons (walk f (car form)) (walk f (cdr form))))
@ -64,7 +63,7 @@
(let loop ((free free)) (let loop ((free free))
(if (null? free) (if (null? free)
(wrap free) (wrap free)
(if (variable=? var (car free)) (if (identifier=? var (car free))
var var
(loop (cdr free)))))))) (loop (cdr free))))))))
(walk f form)))) (walk f form))))
@ -78,7 +77,7 @@
(identifier-variable var))) (identifier-variable var)))
(walk (lambda (f form) (walk (lambda (f form)
(cond (cond
((variable? form) ((identifier? form)
(f form)) (f form))
((pair? form) ((pair? form)
(cons (walk f (car form)) (walk f (cdr form)))) (cons (walk f (car form)) (walk f (cdr form))))
@ -112,7 +111,7 @@
(register var id) (register var id)
id)))))) id))))))
(compare (lambda (x y) (compare (lambda (x y)
(variable=? (identifier=?
(make-identifier x use-env) (make-identifier x use-env)
(make-identifier y use-env))))) (make-identifier y use-env)))))
(f form rename compare)))) (f form rename compare))))
@ -145,7 +144,7 @@
(rename var2))))) (rename var2)))))
(walk (lambda (f form) (walk (lambda (f form)
(cond (cond
((variable? form) ((identifier? form)
(f form)) (f form))
((pair? form) ((pair? form)
(cons (walk f (car form)) (walk f (cdr form)))) (cons (walk f (car form)) (walk f (cdr form))))
@ -154,7 +153,7 @@
(else (else
form)))) form))))
(compare (lambda (x y) (compare (lambda (x y)
(variable=? (identifier=?
(make-identifier x mac-env) (make-identifier x mac-env)
(make-identifier y mac-env))))) (make-identifier y mac-env)))))
(walk flip (f (walk inject form) inject compare)))))) (walk flip (f (walk inject form) inject compare))))))

20
contrib/20.r7rs/scheme/base.scm
View File

@ -208,17 +208,17 @@
(define (constant? obj) (define (constant? obj)
(and (not (pair? obj)) (and (not (pair? obj))
(not (variable? obj)))) (not (identifier? obj))))
(define (literal? obj) (define (literal? obj)
(and (variable? obj) (and (identifier? obj)
(memq obj literals))) (memq obj literals)))
(define (many? pat) (define (many? pat)
(and (pair? pat) (and (pair? pat)
(pair? (cdr pat)) (pair? (cdr pat))
(variable? (cadr pat)) (identifier? (cadr pat))
(variable=? (cadr pat) ellipsis))) (identifier=? (cadr pat) ellipsis)))
(define (pattern-validator pat) ; pattern -> validator (define (pattern-validator pat) ; pattern -> validator
(letrec (letrec
@ -228,8 +228,8 @@
((constant? pat) ((constant? pat)
#`(equal? '#,pat #,form)) #`(equal? '#,pat #,form))
((literal? pat) ((literal? pat)
#`(and (variable? #,form) (variable=? #'#,pat #,form))) #`(and (identifier? #,form) (identifier=? #'#,pat #,form)))
((variable? pat) ((identifier? pat)
#t) #t)
((many? pat) ((many? pat)
(let ((head #`(drop-tail #,(length (cddr pat)) #,form)) (let ((head #`(drop-tail #,(length (cddr pat)) #,form))
@ -252,7 +252,7 @@
'()) '())
((literal? pat) ((literal? pat)
'()) '())
((variable? pat) ((identifier? pat)
`(,pat)) `(,pat))
((many? pat) ((many? pat)
(append (pattern-variables (car pat)) (append (pattern-variables (car pat))
@ -267,7 +267,7 @@
'()) '())
((literal? pat) ((literal? pat)
'()) '())
((variable? pat) ((identifier? pat)
`((,pat . 0))) `((,pat . 0)))
((many? pat) ((many? pat)
(append (map-values succ (pattern-levels (car pat))) (append (map-values succ (pattern-levels (car pat)))
@ -285,7 +285,7 @@
'()) '())
((literal? pat) ((literal? pat)
'()) '())
((variable? pat) ((identifier? pat)
`((,pat . ,form))) `((,pat . ,form)))
((many? pat) ((many? pat)
(let ((head #`(drop-tail #,(length (cddr pat)) #,form)) (let ((head #`(drop-tail #,(length (cddr pat)) #,form))
@ -303,7 +303,7 @@
(cond (cond
((constant? pat) ((constant? pat)
pat) pat)
((variable? pat) ((identifier? pat)
(let ((it (assq pat levels))) (let ((it (assq pat levels)))
(if it (if it
(if (= 0 (cdr it)) (if (= 0 (cdr it))

2
contrib/50.destructuring-bind/lambda.scm
View File

@ -4,7 +4,7 @@
(define-syntax (destructuring-bind formal value . body) (define-syntax (destructuring-bind formal value . body)
(cond (cond
((variable? formal) ((identifier? formal)
#`(let ((#,formal #,value)) #`(let ((#,formal #,value))
#,@body)) #,@body))
((pair? formal) ((pair? formal)

4
extlib/benz/bool.c
View File

@ -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); id1 = pic_id_ptr(x);
id2 = pic_id_ptr(y); id2 = pic_id_ptr(y);
s1 = pic_resolve_variable(pic, id1->env, id1->var); s1 = pic_lookup_identifier(pic, id1->u.id.id, id1->u.id.env);
s2 = pic_resolve_variable(pic, id2->env, id2->var); s2 = pic_lookup_identifier(pic, id2->u.id.id, id2->u.id.env);
return s1 == s2; return s1 == s2;
} }

587
extlib/benz/boot.c
View File

@ -71,7 +71,7 @@ my $src = <<'EOL';
(builtin:define-macro set! (builtin:define-macro set!
(builtin:lambda (form env) (builtin:lambda (form env)
(if (= (length form) 3) (if (= (length form) 3)
(if (variable? (cadr form)) (if (identifier? (cadr form))
(cons the-builtin-set! (cdr form)) (cons the-builtin-set! (cdr form))
(error "illegal set! form" form)) (error "illegal set! form" form))
(error "illegal set! form" form)))) (error "illegal set! form" form))))
@ -80,10 +80,10 @@ my $src = <<'EOL';
(builtin:lambda (formal) (builtin:lambda (formal)
(if (null? formal) (if (null? formal)
#t #t
(if (variable? formal) (if (identifier? formal)
#t #t
(if (pair? formal) (if (pair? formal)
(if (variable? (car formal)) (if (identifier? (car formal))
(check-formal (cdr formal)) (check-formal (cdr formal))
#f) #f)
#f))))) #f)))))
@ -101,7 +101,7 @@ my $src = <<'EOL';
((lambda (len) ((lambda (len)
(if (= len 1) (if (= len 1)
(error "illegal define form" form) (error "illegal define form" form)
(if (variable? (cadr form)) (if (identifier? (cadr form))
(if (= len 3) (if (= len 3)
(cons the-builtin-define (cdr form)) (cons the-builtin-define (cdr form))
(error "illegal define form" form)) (error "illegal define form" form))
@ -115,7 +115,7 @@ my $src = <<'EOL';
(builtin:define-macro define-macro (builtin:define-macro define-macro
(lambda (form env) (lambda (form env)
(if (= (length form) 3) (if (= (length form) 3)
(if (variable? (cadr form)) (if (identifier? (cadr form))
(cons the-builtin-define-macro (cdr form)) (cons the-builtin-define-macro (cdr form))
(error "define-macro: binding to non-variable object" form)) (error "define-macro: binding to non-variable object" form))
(error "illegal define-macro form" form)))) (error "illegal define-macro form" form))))
@ -145,7 +145,7 @@ my $src = <<'EOL';
(define-macro let (define-macro let
(lambda (form env) (lambda (form env)
(if (variable? (cadr form)) (if (identifier? (cadr form))
(list (list
(list the-lambda '() (list the-lambda '()
(list the-define (cadr form) (list the-define (cadr form)
@ -189,15 +189,15 @@ my $src = <<'EOL';
(if (null? clauses) (if (null? clauses)
#undefined #undefined
(let ((clause (car clauses))) (let ((clause (car clauses)))
(if (and (variable? (car clause)) (if (and (identifier? (car clause))
(variable=? (the 'else) (make-identifier (car clause) env))) (identifier=? (the 'else) (make-identifier (car clause) env)))
(cons the-begin (cdr clause)) (cons the-begin (cdr clause))
(if (null? (cdr clause)) (if (null? (cdr clause))
(let ((tmp (make-identifier 'tmp here))) (let ((tmp (make-identifier 'tmp here)))
(list (the 'let) (list (list tmp (car clause))) (list (the 'let) (list (list tmp (car clause)))
(list the-if tmp tmp (cons (the 'cond) (cdr clauses))))) (list the-if tmp tmp (cons (the 'cond) (cdr clauses)))))
(if (and (variable? (cadr clause)) (if (and (identifier? (cadr clause))
(variable=? (the '=>) (make-identifier (cadr clause) env))) (identifier=? (the '=>) (make-identifier (cadr clause) env)))
(let ((tmp (make-identifier 'tmp here))) (let ((tmp (make-identifier 'tmp here)))
(list (the 'let) (list (list tmp (car clause))) (list (the 'let) (list (list tmp (car clause)))
(list the-if tmp (list the-if tmp
@ -212,19 +212,19 @@ my $src = <<'EOL';
(define (quasiquote? form) (define (quasiquote? form)
(and (pair? form) (and (pair? form)
(variable? (car form)) (identifier? (car form))
(variable=? (the 'quasiquote) (make-identifier (car form) env)))) (identifier=? (the 'quasiquote) (make-identifier (car form) env))))
(define (unquote? form) (define (unquote? form)
(and (pair? form) (and (pair? form)
(variable? (car form)) (identifier? (car form))
(variable=? (the 'unquote) (make-identifier (car form) env)))) (identifier=? (the 'unquote) (make-identifier (car form) env))))
(define (unquote-splicing? form) (define (unquote-splicing? form)
(and (pair? form) (and (pair? form)
(pair? (car form)) (pair? (car form))
(variable? (caar form)) (identifier? (caar form))
(variable=? (the 'unquote-splicing) (make-identifier (caar form) env)))) (identifier=? (the 'unquote-splicing) (make-identifier (caar form) env))))
(define (qq depth expr) (define (qq depth expr)
(cond (cond
@ -314,7 +314,7 @@ my $src = <<'EOL';
,@(let loop ((formal formal)) ,@(let loop ((formal formal))
(if (pair? formal) (if (pair? formal)
`((,the-define ,(car formal) #undefined) ,@(loop (cdr formal))) `((,the-define ,(car formal) #undefined) ,@(loop (cdr formal)))
(if (variable? formal) (if (identifier? formal)
`((,the-define ,formal #undefined)) `((,the-define ,formal #undefined))
'()))) '())))
(,(the 'call-with-values) (,the-lambda () ,@body) (,(the 'call-with-values) (,the-lambda () ,@body)
@ -323,7 +323,7 @@ my $src = <<'EOL';
,@(let loop ((formal formal) (args arguments)) ,@(let loop ((formal formal) (args arguments))
(if (pair? formal) (if (pair? formal)
`((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args))) `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))
(if (variable? formal) (if (identifier? formal)
`((,the-set! ,formal ,args)) `((,the-set! ,formal ,args))
'())))))))))) '()))))))))))
@ -368,12 +368,12 @@ my $src = <<'EOL';
(if (null? clauses) (if (null? clauses)
#undefined #undefined
(let ((clause (car clauses))) (let ((clause (car clauses)))
`(,the-if ,(if (and (variable? (car clause)) `(,the-if ,(if (and (identifier? (car clause))
(variable=? (the 'else) (make-identifier (car clause) env))) (identifier=? (the 'else) (make-identifier (car clause) env)))
#t #t
`(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause)))) `(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))
,(if (and (variable? (cadr clause)) ,(if (and (identifier? (cadr clause))
(variable=? (the '=>) (make-identifier (cadr clause) env))) (identifier=? (the '=>) (make-identifier (cadr clause) env)))
`(,(car (cdr (cdr clause))) ,the-key) `(,(car (cdr (cdr clause))) ,the-key)
`(,the-begin ,@(cdr clause))) `(,the-begin ,@(cdr clause)))
,(loop (cdr clauses))))))))))) ,(loop (cdr clauses)))))))))))
@ -400,7 +400,7 @@ my $src = <<'EOL';
(rename var)))))) (rename var))))))
(walk (lambda (f form) (walk (lambda (f form)
(cond (cond
((variable? form) ((identifier? form)
(f form)) (f form))
((pair? form) ((pair? form)
`(,(the 'cons) (walk f (car form)) (walk f (cdr form)))) `(,(the 'cons) (walk f (car form)) (walk f (cdr form))))
@ -427,19 +427,19 @@ my $src = <<'EOL';
(define (syntax-quasiquote? form) (define (syntax-quasiquote? form)
(and (pair? form) (and (pair? form)
(variable? (car form)) (identifier? (car form))
(variable=? (the 'syntax-quasiquote) (make-identifier (car form) env)))) (identifier=? (the 'syntax-quasiquote) (make-identifier (car form) env))))
(define (syntax-unquote? form) (define (syntax-unquote? form)
(and (pair? form) (and (pair? form)
(variable? (car form)) (identifier? (car form))
(variable=? (the 'syntax-unquote) (make-identifier (car form) env)))) (identifier=? (the 'syntax-unquote) (make-identifier (car form) env))))
(define (syntax-unquote-splicing? form) (define (syntax-unquote-splicing? form)
(and (pair? form) (and (pair? form)
(pair? (car form)) (pair? (car form))
(variable? (caar form)) (identifier? (caar form))
(variable=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env)))) (identifier=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env))))
(define (qq depth expr) (define (qq depth expr)
(cond (cond
@ -474,8 +474,8 @@ my $src = <<'EOL';
;; vector ;; vector
((vector? expr) ((vector? expr)
(list (the 'list->vector) (qq depth (vector->list expr)))) (list (the 'list->vector) (qq depth (vector->list expr))))
;; variable ;; identifier
((variable? expr) ((identifier? expr)
(rename expr)) (rename expr))
;; simple datum ;; simple datum
(else (else
@ -506,7 +506,7 @@ my $src = <<'EOL';
var2)))) var2))))
(walk (lambda (f form) (walk (lambda (f form)
(cond (cond
((variable? form) ((identifier? form)
(f form)) (f form))
((pair? form) ((pair? form)
(cons (walk f (car form)) (walk f (cdr 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 ", " (cdr form))\n (list the-builtin-begin\n ",
" (cadr form)\n (cons the-begin (cddr form)))))))\n (le", " (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 (", "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", "= (length form) 3)\n (if (identifier? (cadr form))\n (cons the-b",
"ltin-set! (cdr form))\n (error \"illegal set! form\" form))\n (err", "uiltin-set! (cdr form))\n (error \"illegal set! form\" form))\n (e",
"or \"illegal set! form\" form))))\n\n(builtin:define check-formal\n (builtin:lambda ", "rror \"illegal set! form\" form))))\n\n(builtin:define check-formal\n (builtin:lambd",
"(formal)\n (if (null? formal)\n #t\n (if (variable? formal)\n ", "a (formal)\n (if (null? formal)\n #t\n (if (identifier? formal)\n ",
" #t\n (if (pair? formal)\n (if (variable? (car form", " #t\n (if (pair? formal)\n (if (identifier? (ca",
"al))\n (check-formal (cdr formal))\n #f)\n ", "r formal))\n (check-formal (cdr formal))\n #",
" #f)))))\n\n(builtin:define-macro lambda\n (builtin:lambda (form env)\n", "f)\n #f)))))\n\n(builtin:define-macro lambda\n (builtin:lambda (form",
" (if (= (length form) 1)\n (error \"illegal lambda form\" form)\n (", " 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) (", " (if (check-formal (cadr form))\n (list the-builtin-lambda (cadr f",
"cons the-begin (cddr form)))\n (error \"illegal lambda form\" form)))))\n", "orm) (cons the-begin (cddr form)))\n (error \"illegal lambda form\" form",
"\n(builtin:define-macro define\n (lambda (form env)\n ((lambda (len)\n (if", ")))))\n\n(builtin:define-macro define\n (lambda (form env)\n ((lambda (len)\n ",
" (= len 1)\n (error \"illegal define form\" form)\n (if (variabl", " (if (= len 1)\n (error \"illegal define form\" form)\n (if (i",
"e? (cadr form))\n (if (= len 3)\n (cons the-builti", "dentifier? (cadr form))\n (if (= len 3)\n (cons th",
"n-define (cdr form))\n (error \"illegal define form\" form))\n ", "e-builtin-define (cdr form))\n (error \"illegal define form\" for",
" (if (pair? (cadr form))\n (list the-define\n ", "m))\n (if (pair? (cadr form))\n (list the-define\n ",
" (car (cadr form))\n (cons the-lambda (con", " (car (cadr form))\n (cons the-lam",
"s (cdr (cadr form)) (cddr form))))\n (error \"define: binding to", "bda (cons (cdr (cadr form)) (cddr form))))\n (error \"define: bi",
" non-varaible object\" form)))))\n (length form))))\n\n(builtin:define-macro def", "nding to non-varaible object\" form)))))\n (length form))))\n\n(builtin:define-m",
"ine-macro\n (lambda (form env)\n (if (= (length form) 3)\n (if (variable", "acro define-macro\n (lambda (form env)\n (if (= (length form) 3)\n (if (",
"? (cadr form))\n (cons the-builtin-define-macro (cdr form))\n ", "identifier? (cadr form))\n (cons the-builtin-define-macro (cdr form))\n",
" (error \"define-macro: binding to non-variable object\" form))\n (error \"i", " (error \"define-macro: binding to non-variable object\" form))\n ",
"llegal define-macro form\" form))))\n\n\n(define-macro syntax-error\n (lambda (form ", " (error \"illegal define-macro form\" form))))\n\n\n(define-macro syntax-error\n (lam",
"_)\n (apply error (cdr form))))\n\n(define-macro define-auxiliary-syntax\n (lamb", "bda (form _)\n (apply error (cdr form))))\n\n(define-macro define-auxiliary-synt",
"da (form _)\n (define message\n (string-append\n \"invalid use of auxi", "ax\n (lambda (form _)\n (define message\n (string-append\n \"invalid u",
"liary syntax: '\" (symbol->string (cadr form)) \"'\"))\n (list\n the-define-ma", "se of auxiliary syntax: '\" (symbol->string (cadr form)) \"'\"))\n (list\n the",
"cro\n (cadr form)\n (list the-lambda '_\n (list (the 'error) mess", "-define-macro\n (cadr form)\n (list the-lambda '_\n (list (the 'e",
"age)))))\n\n(define-auxiliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-au", "rror) message)))))\n\n(define-auxiliary-syntax else)\n(define-auxiliary-syntax =>)\n",
"xiliary-syntax unquote)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxil", "(define-auxiliary-syntax unquote)\n(define-auxiliary-syntax unquote-splicing)\n(de",
"iary-syntax syntax-unquote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(", "fine-auxiliary-syntax syntax-unquote)\n(define-auxiliary-syntax syntax-unquote-sp",
"define-macro let\n (lambda (form env)\n (if (variable? (cadr form))\n (l", "licing)\n\n(define-macro let\n (lambda (form env)\n (if (identifier? (cadr form)",
"ist\n (list the-lambda '()\n (list the-define (cadr form)\n ", ")\n (list\n (list the-lambda '()\n (list the-define (c",
" (cons the-lambda\n (cons (map car (c", "adr form)\n (cons the-lambda\n (cons",
"ar (cddr form)))\n (cdr (cddr form)))))\n ", " (map car (car (cddr form)))\n (cdr (cddr form)))",
" (cons (cadr form) (map cadr (car (cddr form))))))\n (cons\n (", "))\n (cons (cadr form) (map cadr (car (cddr form))))))\n (con",
"cons\n the-lambda\n (cons (map car (cadr form))\n ", "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 (", " (cddr form)))\n (map cadr (cadr form))))))\n\n(define-macro and",
"form env)\n (if (null? (cdr form))\n #t\n (if (null? (cddr form))\n", "\n (lambda (form env)\n (if (null? (cdr form))\n #t\n (if (null? (",
" (cadr form)\n (list the-if\n (cadr form)\n ", "cddr form))\n (cadr form)\n (list the-if\n (",
" (cons (the 'and) (cddr form))\n #f)))))\n\n(defin", "cadr form)\n (cons (the 'and) (cddr form))\n #f)",
"e-macro or\n (lambda (form env)\n (if (null? (cdr form))\n #f\n (l", "))))\n\n(define-macro or\n (lambda (form env)\n (if (null? (cdr form))\n #",
"et ((tmp (make-identifier 'it env)))\n (list (the 'let)\n ", "f\n (let ((tmp (make-identifier 'it env)))\n (list (the 'let)\n ",
" (list (list tmp (cadr form)))\n (list the-if\n ", " (list (list tmp (cadr form)))\n (list the-if\n ",
" tmp\n tmp\n (cons (the 'or) (cddr form)", " tmp\n tmp\n (cons (the 'or)",
")))))))\n\n(define-macro cond\n (lambda (form env)\n (let ((clauses (cdr form)))", " (cddr form))))))))\n\n(define-macro cond\n (lambda (form env)\n (let ((clauses ",
"\n (if (null? clauses)\n #undefined\n (let ((clause (car cla", "(cdr form)))\n (if (null? clauses)\n #undefined\n (let ((cla",
"uses)))\n (if (and (variable? (car clause))\n (vari", "use (car clauses)))\n (if (and (identifier? (car clause))\n ",
"able=? (the 'else) (make-identifier (car clause) env)))\n (cons th", " (identifier=? (the 'else) (make-identifier (car clause) env)))\n ",
"e-begin (cdr clause))\n (if (null? (cdr clause))\n ", " (cons the-begin (cdr clause))\n (if (null? (cdr clause))\n ",
" (let ((tmp (make-identifier 'tmp here)))\n (list (the 'le", " (let ((tmp (make-identifier 'tmp here)))\n ",
"t) (list (list tmp (car clause)))\n (list the-if tmp t", " (list (the 'let) (list (list tmp (car clause)))\n (l",
"mp (cons (the 'cond) (cdr clauses)))))\n (if (and (variable? (", "ist the-if tmp tmp (cons (the 'cond) (cdr clauses)))))\n (if (",
"cadr clause))\n (variable=? (the '=>) (make-identifie", "and (identifier? (cadr clause))\n (identifier=? (the ",
"r (cadr clause) env)))\n (let ((tmp (make-identifier 'tmp ", "'=>) (make-identifier (cadr clause) env)))\n (let ((tmp (m",
"here)))\n (list (the 'let) (list (list tmp (car clause))", "ake-identifier 'tmp here)))\n (list (the 'let) (list (li",
")\n (list the-if tmp\n ", "st tmp (car clause)))\n (list the-if tmp\n ",
" (list (car (cddr clause)) tmp)\n (c", " (list (car (cddr clause)) tmp)\n ",
"ons (the 'cond) (cdr clauses)))))\n (list the-if (car clau", " (cons (the 'cond) (cdr clauses)))))\n (l",
"se)\n (cons the-begin (cdr clause))\n ", "ist the-if (car clause)\n (cons the-begin (cdr claus",
" (cons (the 'cond) (cdr clauses)))))))))))\n\n(define-macro quasiquot", "e))\n (cons (the 'cond) (cdr clauses)))))))))))\n\n(de",
"e\n (lambda (form env)\n\n (define (quasiquote? form)\n (and (pair? form)\n ", "fine-macro quasiquote\n (lambda (form env)\n\n (define (quasiquote? form)\n ",
" (variable? (car form))\n (variable=? (the 'quasiquote) (make-", " (and (pair? form)\n (identifier? (car form))\n (identifier=? ",
"identifier (car form) env))))\n\n (define (unquote? form)\n (and (pair? for", "(the 'quasiquote) (make-identifier (car form) env))))\n\n (define (unquote? for",
"m)\n (variable? (car form))\n (variable=? (the 'unquote) (make", "m)\n (and (pair? form)\n (identifier? (car form))\n (ident",
"-identifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and ", "ifier=? (the 'unquote) (make-identifier (car form) env))))\n\n (define (unquote",
"(pair? form)\n (pair? (car form))\n (variable? (caar form))\n ", "-splicing? form)\n (and (pair? form)\n (pair? (car form))\n ",
" (variable=? (the 'unquote-splicing) (make-identifier (caar form) env)))", " (identifier? (caar form))\n (identifier=? (the 'unquote-splicing) (ma",
")\n\n (define (qq depth expr)\n (cond\n ;; unquote\n ((unquote? e", "ke-identifier (caar form) env))))\n\n (define (qq depth expr)\n (cond\n ",
"xpr)\n (if (= depth 1)\n (car (cdr expr))\n (list (the", " ;; unquote\n ((unquote? expr)\n (if (= depth 1)\n (car (c",
" 'list)\n (list (the 'quote) (the 'unquote))\n (", "dr expr))\n (list (the 'list)\n (list (the 'quote) (th",
"qq (- depth 1) (car (cdr expr))))))\n ;; unquote-splicing\n ((unquote-", "e 'unquote))\n (qq (- depth 1) (car (cdr expr))))))\n ;; un",
"splicing? expr)\n (if (= depth 1)\n (list (the 'append)\n ", "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 ", " (car (cdr (car expr)))\n (qq depth (cdr expr)))\n ",
" (list (the 'cons)\n (list (the 'list)\n ", " (list (the 'cons)\n (list (the 'list)\n ",
" (list (the 'quote) (the 'unquote-splicing))\n (qq (- d", " (list (the 'quote) (the 'syntax-unquote-splicing))\n ",
"epth 1) (car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ", " (qq (- depth 1) (car (cdr (car expr)))))\n ",
" ;; quasiquote\n ((quasiquote? expr)\n (list (the 'list)\n ", " (qq depth (cdr expr)))))\n ;; syntax-quasiquote\n ((syntax-q",
" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) (car (cd", "uasiquote? expr)\n (list (the 'list)\n (list (the 'quo",
"r expr)))))\n ;; list\n ((pair? expr)\n (list (the 'cons)\n ", "te) (the 'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))))\n ",
" (qq depth (car expr))\n (qq depth (cdr expr))))\n ;; ve", " ;; list\n ((pair? expr)\n (list (the 'cons)\n ",
"ctor\n ((vector? expr)\n (list (the 'list->vector) (qq depth (vector-", " (qq depth (car expr))\n (qq depth (cdr expr))))\n ",
">list expr))))\n ;; simple datum\n (else\n (list (the 'quote) ex", " ;; vector\n ((vector? expr)\n (list (the 'list->vector) (",
"pr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(define-macro let*\n (lamb", "qq depth (vector->list expr))))\n ;; identifier\n ((identifier",
"da (form env)\n (let ((bindings (car (cdr form)))\n (body (cdr (cd", "? expr)\n (rename expr))\n ;; simple datum\n (else\n ",
"r form))))\n (if (null? bindings)\n `(,(the 'let) () ,@body)\n ", " (list (the 'quote) expr))))\n\n (let ((body (qq 1 (cadr form))))",
" `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n (,", "\n `(,(the 'let)\n ,(map cdr renames)\n ,body))))))\n",
"(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n(define-macro letrec\n ", "\n(define (transformer f)\n (lambda (form env)\n (let ((register1 (make-registe",
" (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n\n(define-macro letrec*", "r))\n (register2 (make-register)))\n (letrec\n ((wrap (lambd",
"\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ", "a (var1)\n (let ((var2 (register1 var1)))\n ",
"(cdr (cdr form))))\n (let ((variables (map (lambda (v) `(,v #f)) (map car bi", "(if var2\n (cdr var2)\n (let ((var",
"ndings)))\n (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings)", "2 (make-identifier var1 env)))\n (register1 var1 var2)\n",
"))\n `(,(the 'let) (,@variables)\n ,@initials\n ,@body))))", " (register2 var2 var1)\n var2",
")\n\n(define-macro let-values\n (lambda (form env)\n `(,(the 'let*-values) ,@(cd", ")))))\n (unwrap (lambda (var2)\n (let ((var1 (regist",
"r form))))\n\n(define-macro let*-values\n (lambda (form env)\n (let ((formal (ca", "er2 var2)))\n (if var1\n (cdr var1",
"r (cdr form)))\n (body (cdr (cdr form))))\n (if (null? formal)\n ", ")\n var2))))\n (walk (lambda (f form)\n ",
" `(,(the 'let) () ,@body)\n `(,(the 'call-with-values) (,the-lambd", " (cond\n ((identifier? form)\n (f",
"a () ,@(cdr (car formal)))\n (,(the 'lambda) (,@(car (car formal)))\n ", " form))\n ((pair? form)\n (cons (walk f (ca",
" (,(the 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n(d", "r form)) (walk f (cdr form))))\n ((vector? form)\n ",
"efine-macro define-values\n (lambda (form env)\n (let ((formal (car (cdr form)", " (list->vector (walk f (vector->list form))))\n (else\n ",
"))\n (body (cdr (cdr form))))\n (let ((arguments (make-identifier ", " form)))))\n (let ((form (cdr form)))\n (walk u",
"'arguments here)))\n `(,the-begin\n ,@(let loop ((formal formal))\n", "nwrap (apply f (walk wrap form))))))))\n\n(define-macro define-syntax\n (lambda (f",
" (if (pair? formal)\n `((,the-define ,(car formal) ", "orm env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form)))",
"#undefined) ,@(loop (cdr formal)))\n (if (variable? formal)\n ", ")\n (if (pair? formal)\n `(,(the 'define-syntax) ,(car formal) (,the",
" `((,the-define ,formal #undefined))\n '())", "-lambda ,(cdr formal) ,@body))\n `(,the-define-macro ,formal (,(the 'tra",
"))\n (,(the 'call-with-values) (,the-lambda () ,@body)\n (,the-", "nsformer) (,the-begin ,@body)))))))\n\n(define-macro letrec-syntax\n (lambda (form",
"lambda\n ,arguments\n ,@(let loop ((formal formal) (args arg", " env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n ",
"uments))\n (if (pair? formal)\n `((,the-set! ,(c", " `(let ()\n ,@(map (lambda (x)\n `(,(the 'define-synt",
"ar formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))\n ", "ax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n(define-ma",
" (if (variable? formal)\n `((,the-set! ,for", "cro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(cdr form))))\n",
"mal ,args))\n '()))))))))))\n\n(define-macro do\n (lambda (f", "\n\n;;; library primitives\n\n(define-macro define-library\n (lambda (form _)\n (l",
"orm env)\n (let ((bindings (car (cdr form)))\n (test (car (car (cd", "et ((name (cadr form))\n (body (cddr form)))\n (let ((old-library (c",
"r (cdr form)))))\n (cleanup (cdr (car (cdr (cdr form)))))\n (bo", "urrent-library))\n (new-library (or (find-library name) (make-library ",
"dy (cdr (cdr (cdr form)))))\n (let ((loop (make-identifier 'loop here)))", "name))))\n (let ((env (library-environment new-library)))\n (curre",
"\n `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings)\n", "nt-library new-library)\n (for-each (lambda (expr) (eval expr env)) body",
" (,the-if ,test\n (,the-begin\n ,@cl", ")\n (current-library old-library))))))\n\n(define-macro cond-expand\n (lam",
"eanup)\n (,the-begin\n ,@body\n ", "bda (form _)\n (letrec\n ((test (lambda (form)\n (or\n ",
" (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car x) (car (cdr (cdr ", " (eq? form 'else)\n (and (symbol? form)\n ",
"x))))) bindings)))))))))\n\n(define-macro when\n (lambda (form env)\n (let ((tes", " (memq form (features)))\n (and (pair? form)\n ",
"t (car (cdr form)))\n (body (cdr (cdr form))))\n `(,the-if ,test\n ", " (case (car form)\n ((library) (find-librar",
" (,the-begin ,@body)\n #undefined))))\n\n(define-macro u", "y (cadr form)))\n ((not) (not (test (cadr form))))\n ",
"nless\n (lambda (form env)\n (let ((test (car (cdr form)))\n (body (cd", " ((and) (let loop ((form (cdr form)))\n ",
"r (cdr form))))\n `(,the-if ,test\n #undefined\n ", " (or (null? form)\n (and (test (car",
" (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (form env)\n (let ((key", " form)) (loop (cdr form))))))\n ((or) (let loop ((form (c",
" (car (cdr form)))\n (clauses (cdr (cdr form))))\n (let ((the-ke", "dr form)))\n (and (pair? form)\n ",
"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 ", " (or (test (car form)) (loop (cdr form))))))\n ",
" (else #f)))))))\n (let loop ((clauses (cdr form)))\n", " (else #f)))))))\n (let loop ((clauses (cdr form)))\n (if (nul",
" (if (null? clauses)\n #undefined\n (if (test (caar c", "l? clauses)\n #undefined\n (if (test (caar clauses))\n ",
"lauses))\n `(,the-begin ,@(cdar clauses))\n (loop (c", " `(,the-begin ,@(cdar clauses))\n (loop (cdr clauses))))))",
"dr clauses))))))))\n\n(define-macro import\n (lambda (form _)\n (let ((caddr\n ", "))\n\n(define-macro import\n (lambda (form _)\n (let ((caddr\n (lambda ",
" (lambda (x) (car (cdr (cdr x)))))\n (prefix\n (lambda (", "(x) (car (cdr (cdr x)))))\n (prefix\n (lambda (prefix symbol)\n ",
"prefix symbol)\n (string->symbol\n (string-append\n ", " (string->symbol\n (string-append\n (symbol-",
" (symbol->string prefix)\n (symbol->string symbol))))))\n ", ">string prefix)\n (symbol->string symbol))))))\n (letrec\n ",
" (letrec\n ((extract\n (lambda (spec)\n (case (ca", " ((extract\n (lambda (spec)\n (case (car spec)\n ",
"r spec)\n ((only rename prefix except)\n (extract (", " ((only rename prefix except)\n (extract (cadr spec)))\n ",
"cadr spec)))\n (else\n (or (find-library spec) (err", " (else\n (or (find-library spec) (error \"library not ",
"or \"library not found\" spec))))))\n (collect\n (lambda (spec)", "found\" spec))))))\n (collect\n (lambda (spec)\n (",
"\n (case (car spec)\n ((only)\n (let ((", "case (car spec)\n ((only)\n (let ((alist (collect (",
"alist (collect (cadr spec))))\n (map (lambda (var) (assq var al", "cadr spec))))\n (map (lambda (var) (assq var alist)) (cddr spec",
"ist)) (cddr spec))))\n ((rename)\n (let ((alist (co", "))))\n ((rename)\n (let ((alist (collect (cadr spec",
"llect (cadr spec)))\n (renames (map (lambda (x) `((car x) .", ")))\n (renames (map (lambda (x) `((car x) . (cadr x))) (cdd",
" (cadr x))) (cddr spec))))\n (map (lambda (s) (or (assq (car s)", "r spec))))\n (map (lambda (s) (or (assq (car s) renames) s)) al",
" renames) s)) alist)))\n ((prefix)\n (let ((alist (", "ist)))\n ((prefix)\n (let ((alist (collect (cadr sp",
"collect (cadr spec))))\n (map (lambda (s) (cons (prefix (caddr ", "ec))))\n (map (lambda (s) (cons (prefix (caddr spec) (car s)) (",
"spec) (car s)) (cdr s))) alist)))\n ((except)\n (le", "cdr s))) alist)))\n ((except)\n (let ((alist (colle",
"t ((alist (collect (cadr spec))))\n (let loop ((alist alist))\n ", "ct (cadr spec))))\n (let loop ((alist alist))\n ",
" (if (null? alist)\n '()\n ", " (if (null? alist)\n '()\n (if ",
" (if (memq (caar alist) (cddr spec))\n (lo", "(memq (caar alist) (cddr spec))\n (loop (cdr alist))\n",
"op (cdr alist))\n (cons (car alist) (loop (cdr alist)", " (cons (car alist) (loop (cdr alist))))))))\n ",
")))))))\n (else\n (let ((lib (or (find-library spec", " (else\n (let ((lib (or (find-library spec) (error \"librar",
") (error \"library not found\" spec))))\n (map (lambda (x) (cons ", "y not found\" spec))))\n (map (lambda (x) (cons x x)) (library-e",
"x x)) (library-exports lib))))))))\n (letrec\n ((import\n ", "xports lib))))))))\n (letrec\n ((import\n (lambda (",
" (lambda (spec)\n (let ((lib (extract spec))\n ", "spec)\n (let ((lib (extract spec))\n (alist ",
" (alist (collect spec)))\n (for-each\n ", "(collect spec)))\n (for-each\n (lambda (slot)",
" (lambda (slot)\n (library-import lib (cdr slot) (car slot)", "\n (library-import lib (cdr slot) (car slot)))\n ",
"))\n alist)))))\n (for-each import (cdr form)))))))\n\n(", " alist)))))\n (for-each import (cdr form)))))))\n\n(define-macro exp",
"define-macro export\n (lambda (form _)\n (letrec\n ((collect\n (", "ort\n (lambda (form _)\n (letrec\n ((collect\n (lambda (spec)\n ",
"lambda (spec)\n (cond\n ((symbol? spec)\n `(,sp", " (cond\n ((symbol? spec)\n `(,spec . ,spec))\n ",
"ec . ,spec))\n ((and (list? spec) (= (length spec) 3) (eq? (car spec)", " ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n ",
" 'rename))\n `(,(list-ref spec 1) . ,(list-ref spec 2)))\n ", " `(,(list-ref spec 1) . ,(list-ref spec 2)))\n (else\n ",
" (else\n (error \"malformed export\")))))\n (export\n ", " (error \"malformed export\")))))\n (export\n (lambda (spec)\n",
" (lambda (spec)\n (let ((slot (collect spec)))\n (librar", " (let ((slot (collect spec)))\n (library-export (car sl",
"y-export (car slot) (cdr slot))))))\n (for-each export (cdr form)))))\n\n(expo", "ot) (cdr slot))))))\n (for-each export (cdr form)))))\n\n(export define lambda",
"rt define lambda quote set! if begin define-macro\n let let* letrec letrec", " quote set! if begin define-macro\n let let* letrec letrec*\n let-va",
"*\n let-values let*-values define-values\n quasiquote unquote unquot", "lues let*-values define-values\n quasiquote unquote unquote-splicing\n ",
"e-splicing\n and or\n cond case else =>\n do when unless\n ", " and or\n cond case else =>\n do when unless\n parameterize\n",
" parameterize\n define-syntax\n syntax-quote syntax-unquote\n ", " define-syntax\n syntax-quote syntax-unquote\n syntax-quasiqu",
" syntax-quasiquote syntax-unquote-splicing\n let-syntax letrec-syntax\n ", "ote syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-erro",
" syntax-error)\n\n\n", "r)\n\n\n",
"", "",
"" ""
}; };

38
extlib/benz/codegen.c
View File

@ -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_lambda(pic_state *, pic_value, struct pic_env *);
static pic_value 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; struct pic_proc *mac;
pic_sym *functor; pic_sym *functor;
functor = pic_resolve_variable(pic, env, var); functor = pic_lookup_identifier(pic, id, env);
if ((mac = find_macro(pic, functor)) != NULL) { 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); 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); 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_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)) { if (pic_id_p(a)) {
pic_add_variable(pic, in, a); pic_add_identifier(pic, pic_id_ptr(a), in);
} }
deferred = pic_list1(pic, pic_nil_value()); 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) expand_define(pic_state *pic, pic_value expr, struct pic_env *env, pic_value deferred)
{ {
pic_sym *uid; pic_sym *uid;
pic_value var, val; pic_id *id;
pic_value val;
var = pic_cadr(pic, expr); id = pic_id_ptr(pic_cadr(pic, expr));
if ((uid = pic_find_variable(pic, env, var)) == NULL) { if ((uid = pic_find_identifier(pic, id, env)) == NULL) {
uid = pic_add_variable(pic, env, var); uid = pic_add_identifier(pic, id, env);
} else { } else {
shadow_macro(pic, uid); 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 static pic_value
expand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env) 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; pic_sym *uid;
var = pic_cadr(pic, expr); id = pic_id_ptr(pic_cadr(pic, expr));
if ((uid = pic_find_variable(pic, env, var)) == NULL) { if ((uid = pic_find_identifier(pic, id, env)) == NULL) {
uid = pic_add_variable(pic, env, var); uid = pic_add_identifier(pic, id, env);
} }
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", pic_identifier_name(pic, id));
} }
define_macro(pic, uid, pic_proc_ptr(val)); 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)) { switch (pic_type(expr)) {
case PIC_TT_ID: case PIC_TT_ID:
case PIC_TT_SYMBOL: { 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: { case PIC_TT_PAIR: {
struct pic_proc *mac; 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); 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; 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) { if (functor == pic->sDEFINE_MACRO) {
return expand_defmacro(pic, expr, env); return expand_defmacro(pic, expr, env);

6
extlib/benz/gc.c
View File

@ -333,8 +333,8 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
break; break;
} }
case PIC_TT_ID: { case PIC_TT_ID: {
gc_mark(pic, obj->u.id.var); gc_mark_object(pic, (struct pic_object *)obj->u.id.u.id.id);
LOOP(obj->u.id.env); LOOP(obj->u.id.u.id.env);
break; break;
} }
case PIC_TT_ENV: { 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) { for (it = kh_begin(h); it != kh_end(h); ++it) {
if (kh_exist(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)); gc_mark_object(pic, (struct pic_object *)kh_val(h, it));
} }
} }

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

@ -162,10 +162,6 @@ bool pic_eq_p(pic_value, pic_value);
bool pic_eqv_p(pic_value, pic_value); bool pic_eqv_p(pic_value, pic_value);
bool pic_equal_p(pic_state *, 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(pic_state *, struct pic_port *);
pic_value pic_read_cstr(pic_state *, const char *); pic_value pic_read_cstr(pic_state *, const char *);

23
extlib/benz/include/picrin/macro.h
View File

@ -9,13 +9,7 @@
extern "C" { extern "C" {
#endif #endif
KHASH_DECLARE(env, void *, pic_sym *) KHASH_DECLARE(env, pic_id *, pic_sym *)
struct pic_id {
PIC_OBJECT_HEADER
pic_value var;
struct pic_env *env;
};
struct pic_env { struct pic_env {
PIC_OBJECT_HEADER PIC_OBJECT_HEADER
@ -24,23 +18,16 @@ struct pic_env {
pic_str *prefix; 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_p(v) (pic_type(v) == PIC_TT_ENV)
#define pic_env_ptr(v) ((struct pic_env *)pic_ptr(v)) #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_topenv(pic_state *, pic_str *);
struct pic_env *pic_make_env(pic_state *, struct pic_env *); 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_add_identifier(pic_state *, pic_id *, struct pic_env *);
pic_sym *pic_put_variable(pic_state *, struct pic_env *, pic_value, pic_sym *); pic_sym *pic_put_identifier(pic_state *, pic_id *, pic_sym *, struct pic_env *);
pic_sym *pic_find_variable(pic_state *, struct pic_env *, pic_value); pic_sym *pic_find_identifier(pic_state *, pic_id *, struct pic_env *);
pic_sym *pic_resolve_variable(pic_state *, struct pic_env *, pic_value); pic_sym *pic_lookup_identifier(pic_state *, pic_id *, struct pic_env *);
bool pic_var_p(pic_value);
pic_sym *pic_var_name(pic_state *, pic_value);
#if defined(__cplusplus) #if defined(__cplusplus)
} }

22
extlib/benz/include/picrin/symbol.h
View File

@ -9,13 +9,33 @@
extern "C" { extern "C" {
#endif #endif
struct pic_id {
union {
struct pic_symbol { struct pic_symbol {
PIC_OBJECT_HEADER PIC_OBJECT_HEADER
const char *cstr; 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_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) #if defined(__cplusplus)
} }

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

@ -183,6 +183,7 @@ struct pic_env;
/* set aliases to basic types */ /* set aliases to basic types */
typedef struct pic_symbol pic_sym; typedef struct pic_symbol pic_sym;
typedef struct pic_id pic_id;
typedef struct pic_pair pic_pair; typedef struct pic_pair pic_pair;
typedef struct pic_string pic_str; typedef struct pic_string pic_str;
typedef struct pic_vector pic_vec; typedef struct pic_vector pic_vec;

16
extlib/benz/lib.c
View File

@ -22,10 +22,10 @@ make_library_env(pic_state *pic, pic_value name)
env = pic_make_topenv(pic, prefix); env = pic_make_topenv(pic, prefix);
/* set up default environment */ /* set up default environment */
pic_put_variable(pic, env, pic_obj_value(pic->sDEFINE_LIBRARY), pic->sDEFINE_LIBRARY); pic_put_identifier(pic, (pic_id *)pic->sDEFINE_LIBRARY, pic->sDEFINE_LIBRARY, env);
pic_put_variable(pic, env, pic_obj_value(pic->sIMPORT), pic->sIMPORT); pic_put_identifier(pic, (pic_id *)pic->sIMPORT, pic->sIMPORT, env);
pic_put_variable(pic, env, pic_obj_value(pic->sEXPORT), pic->sEXPORT); pic_put_identifier(pic, (pic_id *)pic->sEXPORT, pic->sEXPORT, env);
pic_put_variable(pic, env, pic_obj_value(pic->sCOND_EXPAND), pic->sCOND_EXPAND); pic_put_identifier(pic, (pic_id *)pic->sCOND_EXPAND, pic->sCOND_EXPAND, env);
return env; return env;
} }
@ -76,10 +76,10 @@ pic_import(pic_state *pic, struct pic_lib *lib)
pic_dict_for_each (name, lib->exports, it) { pic_dict_for_each (name, lib->exports, it) {
realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, name)); 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_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)); 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_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname));
} else { } 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(); return pic_undef_value();

170
extlib/benz/macro.c
View File

@ -4,26 +4,7 @@
#include "picrin.h" #include "picrin.h"
KHASH_DEFINE(env, void *, pic_sym *, kh_ptr_hash_func, kh_ptr_hash_equal) KHASH_DEFINE(env, pic_id *, 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;
}
struct pic_env * struct pic_env *
pic_make_env(pic_state *pic, struct pic_env *up) 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_sym *
pic_var_name(pic_state PIC_UNUSED(*pic), pic_value var) pic_add_identifier(pic_state *pic, pic_id *id, struct pic_env *env)
{
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)
{ {
const char *name; const char *name;
pic_sym *uid; pic_sym *uid;
pic_str *str; 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(pic_obj_value(id))) { /* toplevel & public */
if (env->up == NULL && pic_sym_p(var)) { /* toplevel & public */
str = pic_format(pic, "%s/%s", pic_str_cstr(pic, env->prefix), name); str = pic_format(pic, "%s/%s", pic_str_cstr(pic, env->prefix), name);
} else { } else {
str = pic_format(pic, ".%s.%d", name, pic->ucnt++); str = pic_format(pic, ".%s.%d", name, pic->ucnt++);
} }
uid = pic_intern_str(pic, str); 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_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; khiter_t it;
int ret; int ret;
assert(pic_var_p(var)); it = kh_put(env, &env->map, id, &ret);
it = kh_put(env, &env->map, pic_ptr(var), &ret);
kh_val(&env->map, it) = uid; kh_val(&env->map, it) = uid;
return uid; return uid;
} }
pic_sym * 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; khiter_t it;
assert(pic_var_p(var)); it = kh_get(env, &env->map, id);
it = kh_get(env, &env->map, pic_ptr(var));
if (it == kh_end(&env->map)) { if (it == kh_end(&env->map)) {
return NULL; return NULL;
} }
@ -112,129 +76,37 @@ pic_find_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var
} }
static pic_sym * 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) { while (env != NULL) {
it = kh_get(env, &env->map, var); uid = pic_find_identifier(pic, id, env);
if (it != kh_end(&env->map)) { if (uid != NULL) {
return kh_val(&env->map, it); break;
} }
env = env->up; env = env->up;
} }
return NULL; return uid;
} }
pic_sym * 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; pic_sym *uid;
assert(env != NULL); while ((uid = lookup(pic, id, env)) == NULL) {
if (pic_sym_p(pic_obj_value(id))) {
pic_assert_type(pic, var, var);
while ((uid = lookup(pic_ptr(var), env)) == NULL) {
if (pic_sym_p(var)) {
break; break;
} }
env = pic_id_ptr(var)->env; env = id->u.id.env; /* do not overwrite id first */
var = pic_id_ptr(var)->var; id = id->u.id.id;
} }
if (uid == NULL) { if (uid == NULL) {
while (env->up != NULL) { while (env->up != NULL) {
env = env->up; env = env->up;
} }
uid = pic_add_variable(pic, env, var); uid = pic_add_identifier(pic, id, env);
} }
return uid; 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);
}

10
extlib/benz/state.c
View File

@ -30,7 +30,6 @@ void pic_init_cont(pic_state *);
void pic_init_char(pic_state *); void pic_init_char(pic_state *);
void pic_init_error(pic_state *); void pic_init_error(pic_state *);
void pic_init_str(pic_state *); void pic_init_str(pic_state *);
void pic_init_macro(pic_state *);
void pic_init_var(pic_state *); void pic_init_var(pic_state *);
void pic_init_write(pic_state *); void pic_init_write(pic_state *);
void pic_init_read(pic_state *); void pic_init_read(pic_state *);
@ -112,13 +111,13 @@ pic_features(pic_state *pic)
pic_sym *nick, *real; \ pic_sym *nick, *real; \
nick = pic_intern(pic, "builtin:" name); \ nick = pic_intern(pic, "builtin:" name); \
real = pic_intern(pic, 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) } while (0)
#define declare_vm_procedure(name) do { \ #define declare_vm_procedure(name) do { \
pic_sym *id; \ pic_sym *sym; \
id = pic_intern(pic, name); \ sym = pic_intern(pic, name); \
pic_put_variable(pic, pic->lib->env, pic_obj_value(id), id); \ pic_put_identifier(pic, (pic_id *)sym, sym, pic->lib->env); \
} while (0) } while (0)
static void static void
@ -172,7 +171,6 @@ pic_init_core(pic_state *pic)
pic_init_char(pic); DONE; pic_init_char(pic); DONE;
pic_init_error(pic); DONE; pic_init_error(pic); DONE;
pic_init_str(pic); DONE; pic_init_str(pic); DONE;
pic_init_macro(pic); DONE;
pic_init_var(pic); DONE; pic_init_var(pic); DONE;
pic_init_write(pic); DONE; pic_init_write(pic); DONE;
pic_init_read(pic); DONE; pic_init_read(pic); DONE;

103
extlib/benz/symbol.c
View File

@ -41,12 +41,33 @@ pic_intern(pic_state *pic, const char *cstr)
return sym; 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 * const char *
pic_symbol_name(pic_state PIC_UNUSED(*pic), pic_sym *sym) pic_symbol_name(pic_state PIC_UNUSED(*pic), pic_sym *sym)
{ {
return sym->cstr; 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 static pic_value
pic_symbol_symbol_p(pic_state *pic) 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)); 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 void
pic_init_symbol(pic_state *pic) pic_init_symbol(pic_state *pic)
{ {
pic_defun(pic, "symbol?", pic_symbol_symbol_p); 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, "symbol->string", pic_symbol_symbol_to_string);
pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol); 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);
} }

8
extlib/benz/vm.c
View File

@ -922,8 +922,8 @@ pic_define_(pic_state *pic, const char *name, pic_value val)
sym = pic_intern(pic, name); sym = pic_intern(pic, name);
if ((uid = pic_find_variable(pic, pic->lib->env, pic_obj_value(sym))) == NULL) { if ((uid = pic_find_identifier(pic, (pic_id *)sym, pic->lib->env)) == NULL) {
uid = pic_add_variable(pic, pic->lib->env, pic_obj_value(sym)); uid = pic_add_identifier(pic, (pic_id *)sym, pic->lib->env);
} else { } else {
if (pic_reg_has(pic, pic->globals, uid)) { if (pic_reg_has(pic, pic->globals, uid)) {
pic_warnf(pic, "redefining variable: ~s", pic_obj_value(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); 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); 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); 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); pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name);
} }

2
extlib/benz/write.c
View File

@ -283,7 +283,7 @@ write_core(struct writer_control *p, pic_value obj)
xfprintf(pic, file, pic_true_p(obj) ? "#t" : "#f"); xfprintf(pic, file, pic_true_p(obj) ? "#t" : "#f");
break; break;
case PIC_TT_ID: case PIC_TT_ID:
xfprintf(pic, file, "#<identifier %s>", pic_symbol_name(pic, pic_var_name(pic, obj))); xfprintf(pic, file, "#<identifier %s>", pic_identifier_name(pic, pic_id_ptr(obj)));
break; break;
case PIC_TT_EOF: case PIC_TT_EOF:
xfprintf(pic, file, "#.(eof-object)"); xfprintf(pic, file, "#.(eof-object)");