syntax-quote and syntax-quasiquote should create identifiers at runtime,
not at compile time
This commit is contained in:
Yuichi Nishiwaki
parent
dbba29a5a8
commit
2c269b4f0e
|
|
@ -294,97 +294,102 @@ my $src = <<'EOL';
|
||||||
|
|
||||||
(define-macro syntax-quote
|
(define-macro syntax-quote
|
||||||
(lambda (form env)
|
(lambda (form env)
|
||||||
(letrec
|
(let ((renames '()))
|
||||||
((wrap (let ((register (make-register)))
|
(letrec
|
||||||
(lambda (var)
|
((rename (lambda (var)
|
||||||
(let ((id (register var)))
|
(let ((x (assq var renames)))
|
||||||
(if (undefined? id)
|
(if x
|
||||||
(let ((id (make-identifier var env)))
|
(cadr x)
|
||||||
(register var id)
|
(begin
|
||||||
id)
|
(set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))
|
||||||
id)))))
|
(rename var))))))
|
||||||
(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)
|
||||||
(letrec
|
(let ((renames '()))
|
||||||
((wrap (let ((register (make-register)))
|
(letrec
|
||||||
(lambda (var)
|
((rename (lambda (var)
|
||||||
(let ((id (register var)))
|
(let ((x (assq var renames)))
|
||||||
(if (undefined? id)
|
(if x
|
||||||
(let ((id (make-identifier var env)))
|
(cadr x)
|
||||||
(register var id)
|
(begin
|
||||||
id)
|
(set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))
|
||||||
id))))))
|
(rename var)))))))
|
||||||
|
|
||||||
(define (syntax-quasiquote? form)
|
(define (syntax-quasiquote? form)
|
||||||
(and (pair? form)
|
(and (pair? form)
|
||||||
(variable? (car form))
|
(variable? (car form))
|
||||||
(variable=? (the 'syntax-quasiquote) (make-identifier (car form) env))))
|
(variable=? (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))
|
(variable? (car form))
|
||||||
(variable=? (the 'syntax-unquote) (make-identifier (car form) env))))
|
(variable=? (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))
|
(variable? (caar form))
|
||||||
(variable=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env))))
|
(variable=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env))))
|
||||||
|
|
||||||
(define (qq depth expr)
|
(define (qq depth expr)
|
||||||
(cond
|
(cond
|
||||||
;; syntax-unquote
|
;; syntax-unquote
|
||||||
((syntax-unquote? expr)
|
((syntax-unquote? expr)
|
||||||
(if (= depth 1)
|
(if (= depth 1)
|
||||||
(car (cdr expr))
|
(car (cdr expr))
|
||||||
(list (the 'list)
|
(list (the 'list)
|
||||||
(list (the 'quote) (the 'syntax-unquote))
|
(list (the 'quote) (the 'syntax-unquote))
|
||||||
(qq (- depth 1) (car (cdr expr))))))
|
(qq (- depth 1) (car (cdr expr))))))
|
||||||
;; syntax-unquote-splicing
|
;; syntax-unquote-splicing
|
||||||
((syntax-unquote-splicing? expr)
|
((syntax-unquote-splicing? expr)
|
||||||
(if (= depth 1)
|
(if (= depth 1)
|
||||||
(list (the 'append)
|
(list (the 'append)
|
||||||
(car (cdr (car expr)))
|
(car (cdr (car expr)))
|
||||||
(qq depth (cdr expr)))
|
(qq depth (cdr expr)))
|
||||||
(list (the 'cons)
|
(list (the 'cons)
|
||||||
(list (the 'list)
|
(list (the 'list)
|
||||||
(list (the 'quote) (the 'syntax-unquote-splicing))
|
(list (the 'quote) (the 'syntax-unquote-splicing))
|
||||||
(qq (- depth 1) (car (cdr (car expr)))))
|
(qq (- depth 1) (car (cdr (car expr)))))
|
||||||
(qq depth (cdr expr)))))
|
(qq depth (cdr expr)))))
|
||||||
;; syntax-quasiquote
|
;; syntax-quasiquote
|
||||||
((syntax-quasiquote? expr)
|
((syntax-quasiquote? expr)
|
||||||
(list (the 'list)
|
(list (the 'list)
|
||||||
(list (the 'quote) (the 'quasiquote))
|
(list (the 'quote) (the 'quasiquote))
|
||||||
(qq (+ depth 1) (car (cdr expr)))))
|
(qq (+ depth 1) (car (cdr expr)))))
|
||||||
;; list
|
;; list
|
||||||
((pair? expr)
|
((pair? expr)
|
||||||
(list (the 'cons)
|
(list (the 'cons)
|
||||||
(qq depth (car expr))
|
(qq depth (car expr))
|
||||||
(qq depth (cdr expr))))
|
(qq depth (cdr expr))))
|
||||||
;; 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
|
;; 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 ",
|
||||||
" (and (pair? form)\n (variable? (car form))\n ",
|
" (begin\n (set! renames `((,var ,(make-identifier",
|
||||||
" (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env))))\n\n ",
|
" var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ",
|
||||||
" (define (syntax-unquote? form)\n (and (pair? form)\n (va",
|
" (rename var)))))))\n\n (define (syntax-quasiquote? form)\n ",
|
||||||
"riable? (car form))\n (variable=? (the 'syntax-unquote) (make-ident",
|
" (and (pair? form)\n (variable? (car form))\n ",
|
||||||
"ifier (car form) env))))\n\n (define (syntax-unquote-splicing? form)\n ",
|
" (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env))))\n\n ",
|
||||||
" (and (pair? form)\n (pair? (car form))\n (variable",
|
" (define (syntax-unquote? form)\n (and (pair? form)\n ",
|
||||||
"? (caar form))\n (variable=? (the 'syntax-unquote-splicing) (make-i",
|
" (variable? (car form))\n (variable=? (the 'syntax-unquote) ",
|
||||||
"dentifier (caar form) env))))\n\n (define (qq depth expr)\n (cond\n ",
|
"(make-identifier (car form) env))))\n\n (define (syntax-unquote-splicing?",
|
||||||
" ;; syntax-unquote\n ((syntax-unquote? expr)\n (if (",
|
" form)\n (and (pair? form)\n (pair? (car form))\n ",
|
||||||
"= depth 1)\n (car (cdr expr))\n (list (the 'list)\n ",
|
" (variable? (caar form))\n (variable=? (the 'syntax-unqu",
|
||||||
" (list (the 'quote) (the 'syntax-unquote))\n ",
|
"ote-splicing) (make-identifier (caar form) env))))\n\n (define (qq depth ",
|
||||||
" (qq (- depth 1) (car (cdr expr))))))\n ;; syntax-unquote-splicing\n ",
|
"expr)\n (cond\n ;; syntax-unquote\n ((syntax-unq",
|
||||||
" ((syntax-unquote-splicing? expr)\n (if (= depth 1)\n ",
|
"uote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ",
|
||||||
" (list (the 'append)\n (car (cdr (car expr)))\n ",
|
" (list (the 'list)\n (list (the 'quote) (the",
|
||||||
" (qq depth (cdr expr)))\n (list (the 'cons)\n ",
|
" 'syntax-unquote))\n (qq (- depth 1) (car (cdr expr))))))\n",
|
||||||
" (list (the 'list)\n (list (the 'quote) (t",
|
" ;; syntax-unquote-splicing\n ((syntax-unquote-splicing? ",
|
||||||
"he 'syntax-unquote-splicing))\n (qq (- depth 1) (car (",
|
"expr)\n (if (= depth 1)\n (list (the 'append)\n ",
|
||||||
"cdr (car expr)))))\n (qq depth (cdr expr)))))\n ;; ",
|
" (car (cdr (car expr)))\n (qq depth (cdr ",
|
||||||
"syntax-quasiquote\n ((syntax-quasiquote? expr)\n (list (the '",
|
"expr)))\n (list (the 'cons)\n (list (the '",
|
||||||
"list)\n (list (the 'quote) (the 'quasiquote))\n ",
|
"list)\n (list (the 'quote) (the 'syntax-unquote-spli",
|
||||||
"(qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n",
|
"cing))\n (qq (- depth 1) (car (cdr (car expr)))))\n ",
|
||||||
" (list (the 'cons)\n (qq depth (car expr))\n ",
|
" (qq depth (cdr expr)))))\n ;; syntax-quasiquote",
|
||||||
" (qq depth (cdr expr))))\n ;; vector\n ((vector? expr)\n",
|
"\n ((syntax-quasiquote? expr)\n (list (the 'list)\n ",
|
||||||
" (list (the 'list->vector) (qq depth (vector->list expr))))\n ",
|
" (list (the 'quote) (the 'quasiquote))\n (qq (+ de",
|
||||||
" ;; variable\n ((variable? expr)\n (list (the 'quote) (wrap ",
|
"pth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n ",
|
||||||
"expr)))\n ;; simple datum\n (else\n (list (the 'quot",
|
" (list (the 'cons)\n (qq depth (car expr))\n ",
|
||||||
"e) expr))))\n\n (let ((x (cadr form)))\n (qq 1 x)))))\n\n (define (t",
|
" (qq depth (cdr expr))))\n ;; vector\n ((vector? e",
|
||||||
"ransformer f)\n (lambda (form env)\n (let ((register1 (make-register))\n ",
|
"xpr)\n (list (the 'list->vector) (qq depth (vector->list expr))))\n ",
|
||||||
" (register2 (make-register)))\n (letrec\n ((wrap (lambda",
|
" ;; variable\n ((variable? expr)\n (rename expr",
|
||||||
" (var1)\n (let ((var2 (register1 var1)))\n ",
|
"))\n ;; simple datum\n (else\n (list (the 'quo",
|
||||||
" (if (undefined? var2)\n (let ((var2 (make-identifier",
|
"te) expr))))\n\n (let ((body (qq 1 (cadr form))))\n `(,(the 'le",
|
||||||
" var1 env)))\n (register1 var1 var2)\n ",
|
"t)\n ,(map cdr renames)\n ,body))))))\n\n (define (transf",
|
||||||
" (register2 var2 var1)\n var2)\n ",
|
"ormer f)\n (lambda (form env)\n (let ((register1 (make-register))\n ",
|
||||||
" var2))))\n (unwrap (lambda (var2)\n ",
|
" (register2 (make-register)))\n (letrec\n ((wrap (lambda (var",
|
||||||
" (let ((var1 (register2 var2)))\n (if (undefined? var",
|
"1)\n (let ((var2 (register1 var1)))\n (i",
|
||||||
"1)\n var2\n var1))))\n ",
|
"f (undefined? var2)\n (let ((var2 (make-identifier var1",
|
||||||
" (walk (lambda (f form)\n (cond\n ",
|
" env)))\n (register1 var1 var2)\n ",
|
||||||
"((variable? form)\n (f form))\n ((pair?",
|
" (register2 var2 var1)\n var2)\n ",
|
||||||
" form)\n (cons (walk f (car form)) (walk f (cdr form))))\n ",
|
" var2))))\n (unwrap (lambda (var2)\n ",
|
||||||
" ((vector? form)\n (list->vector (walk f",
|
"(let ((var1 (register2 var2)))\n (if (undefined? var1)\n ",
|
||||||
" (vector->list form))))\n (else\n form)",
|
" var2\n var1))))\n ",
|
||||||
"))))\n (let ((form (cdr form)))\n (walk unwrap (apply f (walk ",
|
" (walk (lambda (f form)\n (cond\n ((var",
|
||||||
"wrap form))))))))\n\n (define-macro define-syntax\n (lambda (form env)\n (l",
|
"iable? form)\n (f form))\n ((pair? form",
|
||||||
"et ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n (if",
|
")\n (cons (walk f (car form)) (walk f (cdr form))))\n ",
|
||||||
" (pair? formal)\n `(,(the 'define-syntax) ,(car formal) (,the-lambda ,",
|
" ((vector? form)\n (list->vector (walk f (vec",
|
||||||
"(cdr formal) ,@body))\n `(,the-define-macro ,formal (,(the 'transforme",
|
"tor->list form))))\n (else\n form)))))\n",
|
||||||
"r) (,the-begin ,@body)))))))\n\n (define-macro letrec-syntax\n (lambda (form en",
|
" (let ((form (cdr form)))\n (walk unwrap (apply f (walk wrap ",
|
||||||
"v)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n",
|
"form))))))))\n\n (define-macro define-syntax\n (lambda (form env)\n (let ((",
|
||||||
" `(let ()\n ,@(map (lambda (x)\n `(,(the 'defi",
|
"formal (car (cdr form)))\n (body (cdr (cdr form))))\n (if (pai",
|
||||||
"ne-syntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n",
|
"r? formal)\n `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr ",
|
||||||
"\n (define-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax)",
|
"formal) ,@body))\n `(,the-define-macro ,formal (,(the 'transformer) (,",
|
||||||
" ,@(cdr form))))\n\n (export let let* letrec letrec*\n let-values let*-va",
|
"the-begin ,@body)))))))\n\n (define-macro letrec-syntax\n (lambda (form env)\n ",
|
||||||
"lues define-values\n quasiquote unquote unquote-splicing\n and o",
|
" (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n ",
|
||||||
"r\n cond case else =>\n do when unless\n parameterize\n ",
|
" `(let ()\n ,@(map (lambda (x)\n `(,(the 'define-sy",
|
||||||
" define-syntax\n syntax-quote syntax-unquote\n syntax-qua",
|
"ntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n (d",
|
||||||
"siquote syntax-unquote-splicing\n let-syntax letrec-syntax\n syn",
|
"efine-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(c",
|
||||||
"tax-error))\n\n",
|
"dr form))))\n\n (export let let* letrec letrec*\n let-values let*-values ",
|
||||||
|
"define-values\n quasiquote unquote unquote-splicing\n and or\n ",
|
||||||
|
" cond case else =>\n do when unless\n parameterize\n ",
|
||||||
|
" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquo",
|
||||||
|
"te syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-e",
|
||||||
|
"rror))\n\n",
|
||||||
"",
|
"",
|
||||||
""
|
""
|
||||||
};
|
};
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue