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

Merge branch 'symbol-is-a-identifier'

This commit is contained in:
Yuichi Nishiwaki 2016-02-06 23:19:13 +09:00
parent bb5b15790d e51d3db812
commit fa8446110a
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
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))))))

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

@ -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))

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

@ -4,7 +4,7 @@
(define-syntax (destructuring-bind formal value . body)
(cond
((variable? formal)
((identifier? formal)
#`(let ((#,formal #,value))
#,@body))
((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);
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;
}

595
extlib/benz/boot.c
View File

@ -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",
"",
""
};

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_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);

6
extlib/benz/gc.c
View File

@ -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));
}
}

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_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 *);

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

@ -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)
}

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

@ -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)
}

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

@ -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;

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);
/* 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();

170
extlib/benz/macro.c
View File

@ -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);
}

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_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;

103
extlib/benz/symbol.c
View File

@ -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);
}

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);
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);
}

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");
break;
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;
case PIC_TT_EOF:
xfprintf(pic, file, "#.(eof-object)");