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

syntax-quote and syntax-quasiquote should create identifiers at runtime, 

not at compile time
This commit is contained in:
Yuichi Nishiwaki 2015-06-16 19:10:24 +09:00
parent dbba29a5a8
commit 2c269b4f0e
1 changed files with 166 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

192
extlib/benz/boot.c
View File

@ -294,38 +294,41 @@ my $src = <<'EOL';
(define-macro syntax-quote (define-macro syntax-quote
(lambda (form env) (lambda (form env)
(let ((renames '()))
(letrec (letrec
((wrap (let ((register (make-register))) ((rename (lambda (var)
(lambda (var) (let ((x (assq var renames)))
(let ((id (register var))) (if x
(if (undefined? id) (cadr x)
(let ((id (make-identifier var env))) (begin
(register var id) (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))
id) (rename var))))))
id)))))
(walk (lambda (f form) (walk (lambda (f form)
(cond (cond
((variable? form) ((variable? form)
(f form)) (f form))
((pair? form) ((pair? form)
(cons (walk f (car form)) (walk f (cdr form)))) `(,(the 'cons) (walk f (car form)) (walk f (cdr form))))
((vector? form) ((vector? form)
(list->vector (walk f (vector->list form)))) `(,(the 'list->vector) (walk f (vector->list form))))
(else (else
form))))) `(,(the 'quote) ,form))))))
(list the-quote (walk wrap (cadr form)))))) (let ((form (walk rename (cadr form))))
`(,(the 'let)
,(map cdr renames)
,form))))))
(define-macro syntax-quasiquote (define-macro syntax-quasiquote
(lambda (form env) (lambda (form env)
(let ((renames '()))
(letrec (letrec
((wrap (let ((register (make-register))) ((rename (lambda (var)
(lambda (var) (let ((x (assq var renames)))
(let ((id (register var))) (if x
(if (undefined? id) (cadr x)
(let ((id (make-identifier var env))) (begin
(register var id) (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))
id) (rename var)))))))
id))))))
(define (syntax-quasiquote? form) (define (syntax-quasiquote? form)
(and (pair? form) (and (pair? form)
@ -378,13 +381,15 @@ my $src = <<'EOL';
(list (the 'list->vector) (qq depth (vector->list expr)))) (list (the 'list->vector) (qq depth (vector->list expr))))
;; variable ;; variable
((variable? expr) ((variable? expr)
(list (the 'quote) (wrap expr))) (rename expr))
;; simple datum ;; simple datum
(else (else
(list (the 'quote) expr)))) (list (the 'quote) expr))))
(let ((x (cadr form))) (let ((body (qq 1 (cadr form))))
(qq 1 x))))) `(,(the 'let)
,(map cdr renames)
,body))))))
(define (transformer f) (define (transformer f)
(lambda (form env) (lambda (form env)
@ -629,79 +634,84 @@ const char pic_boot[][80] = {
"v)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n", "v)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n",
" `(,(the 'with-parameter)\n (,(the 'lambda) ()\n ,@forma", " `(,(the 'with-parameter)\n (,(the 'lambda) ()\n ,@forma",
"l\n ,@body)))))\n\n (define-macro syntax-quote\n (lambda (form env)\n ", "l\n ,@body)))))\n\n (define-macro syntax-quote\n (lambda (form env)\n ",
" (letrec\n ((wrap (let ((register (make-register)))\n ", " (let ((renames '()))\n (letrec\n ((rename (lambda (var)\n ",
" (lambda (var)\n (let ((id (register var)))\n ", " (let ((x (assq var renames)))\n (if x\n",
" (if (undefined? id)\n (let ((id (make-identifier", " (cadr x)\n (begin\n ",
" var env)))\n (register var id)\n ", " (set! renames `((,var ,(make-identifier var env) (,(the",
" id)\n id)))))\n (walk (lambda (f form)", " 'make-identifier) ',var ',env)) . ,renames))\n (re",
"\n (cond\n ((variable? form)\n ", "name var))))))\n (walk (lambda (f form)\n (cond\n ",
" (f form))\n ((pair? form)\n (cons (wal", " ((variable? form)\n (f form))\n ",
"k f (car form)) (walk f (cdr form))))\n ((vector? form)\n ", " ((pair? form)\n `(,(the 'cons) (walk f (car fo",
" (list->vector (walk f (vector->list form))))\n ", "rm)) (walk f (cdr form))))\n ((vector? form)\n ",
"(else\n form)))))\n (list the-quote (walk wrap (cadr fo", " `(,(the 'list->vector) (walk f (vector->list form))))\n ",
"rm))))))\n\n (define-macro syntax-quasiquote\n (lambda (form env)\n (letrec", " (else\n `(,(the 'quote) ,form))))))\n (let ((fo",
"\n ((wrap (let ((register (make-register)))\n (lambda (", "rm (walk rename (cadr form))))\n `(,(the 'let)\n ,(map cdr",
"var)\n (let ((id (register var)))\n (if ", " renames)\n ,form))))))\n\n (define-macro syntax-quasiquote\n (lamb",
"(undefined? id)\n (let ((id (make-identifier var env)))", "da (form env)\n (let ((renames '()))\n (letrec\n ((rename (l",
"\n (register var id)\n id)", "ambda (var)\n (let ((x (assq var renames)))\n ",
"\n id))))))\n\n (define (syntax-quasiquote? form)\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\n (define (syntax-quasiquote? form)\n ",
" (and (pair? form)\n (variable? (car form))\n ", " (and (pair? form)\n (variable? (car form))\n ",
" (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env))))\n\n ", " (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env))))\n\n ",
" (define (syntax-unquote? form)\n (and (pair? form)\n (va", " (define (syntax-unquote? form)\n (and (pair? form)\n ",
"riable? (car form))\n (variable=? (the 'syntax-unquote) (make-ident", " (variable? (car form))\n (variable=? (the 'syntax-unquote) ",
"ifier (car form) env))))\n\n (define (syntax-unquote-splicing? form)\n ", "(make-identifier (car form) env))))\n\n (define (syntax-unquote-splicing?",
" (and (pair? form)\n (pair? (car form))\n (variable", " form)\n (and (pair? form)\n (pair? (car form))\n ",
"? (caar form))\n (variable=? (the 'syntax-unquote-splicing) (make-i", " (variable? (caar form))\n (variable=? (the 'syntax-unqu",
"dentifier (caar form) env))))\n\n (define (qq depth expr)\n (cond\n ", "ote-splicing) (make-identifier (caar form) env))))\n\n (define (qq depth ",
" ;; syntax-unquote\n ((syntax-unquote? expr)\n (if (", "expr)\n (cond\n ;; syntax-unquote\n ((syntax-unq",
"= depth 1)\n (car (cdr expr))\n (list (the 'list)\n ", "uote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ",
" (list (the 'quote) (the 'syntax-unquote))\n ", " (list (the 'list)\n (list (the 'quote) (the",
" (qq (- depth 1) (car (cdr expr))))))\n ;; syntax-unquote-splicing\n ", " 'syntax-unquote))\n (qq (- depth 1) (car (cdr expr))))))\n",
" ((syntax-unquote-splicing? expr)\n (if (= depth 1)\n ", " ;; syntax-unquote-splicing\n ((syntax-unquote-splicing? ",
" (list (the 'append)\n (car (cdr (car expr)))\n ", "expr)\n (if (= depth 1)\n (list (the 'append)\n ",
" (qq depth (cdr expr)))\n (list (the 'cons)\n ", " (car (cdr (car expr)))\n (qq depth (cdr ",
" (list (the 'list)\n (list (the 'quote) (t", "expr)))\n (list (the 'cons)\n (list (the '",
"he 'syntax-unquote-splicing))\n (qq (- depth 1) (car (", "list)\n (list (the 'quote) (the 'syntax-unquote-spli",
"cdr (car expr)))))\n (qq depth (cdr expr)))))\n ;; ", "cing))\n (qq (- depth 1) (car (cdr (car expr)))))\n ",
"syntax-quasiquote\n ((syntax-quasiquote? expr)\n (list (the '", " (qq depth (cdr expr)))))\n ;; syntax-quasiquote",
"list)\n (list (the 'quote) (the 'quasiquote))\n ", "\n ((syntax-quasiquote? expr)\n (list (the 'list)\n ",
"(qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n", " (list (the 'quote) (the 'quasiquote))\n (qq (+ de",
"pth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n ",
" (list (the 'cons)\n (qq depth (car expr))\n ", " (list (the 'cons)\n (qq depth (car expr))\n ",
" (qq depth (cdr expr))))\n ;; vector\n ((vector? expr)\n", " (qq depth (cdr expr))))\n ;; vector\n ((vector? e",
" (list (the 'list->vector) (qq depth (vector->list expr))))\n ", "xpr)\n (list (the 'list->vector) (qq depth (vector->list expr))))\n ",
" ;; variable\n ((variable? expr)\n (list (the 'quote) (wrap ", " ;; variable\n ((variable? expr)\n (rename expr",
"expr)))\n ;; simple datum\n (else\n (list (the 'quot", "))\n ;; simple datum\n (else\n (list (the 'quo",
"e) expr))))\n\n (let ((x (cadr form)))\n (qq 1 x)))))\n\n (define (t", "te) expr))))\n\n (let ((body (qq 1 (cadr form))))\n `(,(the 'le",
"ransformer f)\n (lambda (form env)\n (let ((register1 (make-register))\n ", "t)\n ,(map cdr renames)\n ,body))))))\n\n (define (transf",
" (register2 (make-register)))\n (letrec\n ((wrap (lambda", "ormer f)\n (lambda (form env)\n (let ((register1 (make-register))\n ",
" (var1)\n (let ((var2 (register1 var1)))\n ", " (register2 (make-register)))\n (letrec\n ((wrap (lambda (var",
" (if (undefined? var2)\n (let ((var2 (make-identifier", "1)\n (let ((var2 (register1 var1)))\n (i",
" var1 env)))\n (register1 var1 var2)\n ", "f (undefined? var2)\n (let ((var2 (make-identifier var1",
" env)))\n (register1 var1 var2)\n ",
" (register2 var2 var1)\n var2)\n ", " (register2 var2 var1)\n var2)\n ",
" var2))))\n (unwrap (lambda (var2)\n ", " var2))))\n (unwrap (lambda (var2)\n ",
" (let ((var1 (register2 var2)))\n (if (undefined? var", "(let ((var1 (register2 var2)))\n (if (undefined? var1)\n ",
"1)\n var2\n var1))))\n ", " var2\n var1))))\n ",
" (walk (lambda (f form)\n (cond\n ", " (walk (lambda (f form)\n (cond\n ((var",
"((variable? form)\n (f form))\n ((pair?", "iable? form)\n (f form))\n ((pair? form",
" form)\n (cons (walk f (car form)) (walk f (cdr form))))\n ", ")\n (cons (walk f (car form)) (walk f (cdr form))))\n ",
" ((vector? form)\n (list->vector (walk f", " ((vector? form)\n (list->vector (walk f (vec",
" (vector->list form))))\n (else\n form)", "tor->list form))))\n (else\n form)))))\n",
"))))\n (let ((form (cdr form)))\n (walk unwrap (apply f (walk ", " (let ((form (cdr form)))\n (walk unwrap (apply f (walk wrap ",
"wrap form))))))))\n\n (define-macro define-syntax\n (lambda (form env)\n (l", "form))))))))\n\n (define-macro define-syntax\n (lambda (form env)\n (let ((",
"et ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n (if", "formal (car (cdr form)))\n (body (cdr (cdr form))))\n (if (pai",
" (pair? formal)\n `(,(the 'define-syntax) ,(car formal) (,the-lambda ,", "r? formal)\n `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr ",
"(cdr formal) ,@body))\n `(,the-define-macro ,formal (,(the 'transforme", "formal) ,@body))\n `(,the-define-macro ,formal (,(the 'transformer) (,",
"r) (,the-begin ,@body)))))))\n\n (define-macro letrec-syntax\n (lambda (form en", "the-begin ,@body)))))))\n\n (define-macro letrec-syntax\n (lambda (form env)\n ",
"v)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n", " (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n ",
" `(let ()\n ,@(map (lambda (x)\n `(,(the 'defi", " `(let ()\n ,@(map (lambda (x)\n `(,(the 'define-sy",
"ne-syntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n", "ntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n (d",
"\n (define-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax)", "efine-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(c",
" ,@(cdr form))))\n\n (export let let* letrec letrec*\n let-values let*-va", "dr form))))\n\n (export let let* letrec letrec*\n let-values let*-values ",
"lues define-values\n quasiquote unquote unquote-splicing\n and o", "define-values\n quasiquote unquote unquote-splicing\n and or\n ",
"r\n cond case else =>\n do when unless\n parameterize\n ", " cond case else =>\n do when unless\n parameterize\n ",
" define-syntax\n syntax-quote syntax-unquote\n syntax-qua", " define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquo",
"siquote syntax-unquote-splicing\n let-syntax letrec-syntax\n syn", "te syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-e",
"tax-error))\n\n", "rror))\n\n",
"", "",
"" ""
}; };