~ chicken-core (chicken-5) 6890c0527602a26b1a8219e5825d7dfea40c8b3f
commit 6890c0527602a26b1a8219e5825d7dfea40c8b3f
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sat Apr 10 20:11:40 2021 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Apr 11 18:21:17 2021 +0200
Do not try to resolve names in define-specialization macro directly
This is pretty iffy, and define-specialization seems to be the only
macro that tries to do this anymore. Instead, convert it to a new
core form which performs the action, so that the name resolution can
be done properly there.
The idea to do this is taken from define-type, which runs code in
a ##core#elaborationtimeonly block which does the actual work, so
the macro expander can do the name resolution.
This should also allow for using define-specialization inside an
expansion of a different macro, which was previously not possible.
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index fe95fee9..cde8e9e6 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -164,10 +164,8 @@
(##sys#check-syntax 'define-specialization x '(_ (variable . #(_ 0)) _ . #(_ 0 1)))
(let* ((head (cadr x))
(name (car head))
- (gname (##sys#globalize name '())) ;XXX correct?
(args (cdr head))
(alias (gensym name))
- (galias (##sys#globalize alias '())) ;XXX and this?
(rtypes (and (pair? (cdddr x)) (strip-syntax (caddr x))))
(%define (r 'define))
(body (if rtypes (cadddr x) (caddr x))))
@@ -176,26 +174,24 @@
(let ((anames (reverse anames))
(atypes (reverse atypes))
(spec
- `(,galias ,@(let loop2 ((anames anames) (i 1))
- (if (null? anames)
- '()
- (cons (vector i)
- (loop2 (cdr anames) (fx+ i 1))))))))
- (##sys#put!
- gname '##compiler#local-specializations
- (##sys#append
- (##sys#get gname '##compiler#local-specializations '())
- (list
- (cons atypes
- (if (and rtypes (pair? rtypes))
- (list
- (map (cut chicken.compiler.scrutinizer#check-and-validate-type
- <>
- 'define-specialization)
- rtypes)
- spec)
- (list spec))))))
+ `(,alias ,@(let loop2 ((anames anames) (i 1))
+ (if (null? anames)
+ '()
+ (cons (vector i)
+ (loop2 (cdr anames) (fx+ i 1))))))))
`(##core#begin
+ (##core#local-specialization
+ ,name
+ ,alias
+ ,(cons atypes
+ (if (and rtypes (pair? rtypes))
+ (list
+ (map (cut chicken.compiler.scrutinizer#check-and-validate-type
+ <>
+ 'define-specialization)
+ rtypes)
+ spec)
+ (list spec))))
(##core#declare (inline ,alias) (hide ,alias))
(,%define (,alias ,@anames)
(##core#let ,(map (lambda (an at)
diff --git a/core.scm b/core.scm
index fa19c354..34adbc43 100644
--- a/core.scm
+++ b/core.scm
@@ -98,6 +98,7 @@
; <variable>
; <constant>
; (##core#declare {<spec>})
+; (##core#local-specialization <variable> <alias> {<spec>})
; (##core#immutable <exp>)
; (##core#quote <exp>)
; (##core#syntax <exp>)
@@ -681,6 +682,18 @@
,(caddr x)
,(walk (cadddr x) e dest ldest h ln tl?)))
+ ((##core#local-specialization)
+ (let* ((name (resolve-variable (cadr x) e dest ldest h))
+ (raw-alias (caddr x))
+ (resolved-alias (resolve-variable raw-alias e dest ldest h))
+ (specs (##sys#get name '##compiler#local-specializations '())))
+ (letrec ((resolve-alias (lambda (form)
+ (cond ((pair? form) (cons (resolve-alias (car form)) (resolve-alias (cdr form))))
+ ((eq? form raw-alias) resolved-alias)
+ (else form)))))
+ (##sys#put! name '##compiler#local-specializations (##sys#append specs (resolve-alias (cdddr x))))
+ '(##core#undefined))))
+
((##core#typecase)
`(##core#typecase
,(or ln (cadr x))
diff --git a/eval.scm b/eval.scm
index a47759e5..9421e83d 100644
--- a/eval.scm
+++ b/eval.scm
@@ -606,7 +606,7 @@
[(##core#compiletimetoo)
(compile (cadr x) e #f tf cntr tl?) ]
- [(##core#compiletimeonly ##core#callunit)
+ [(##core#compiletimeonly ##core#callunit ##core#local-specialization)
(compile '(##core#undefined) e #f tf cntr tl?) ]
[(##core#declare)
Trap