~ chicken-core (chicken-5) 6329d68f5d50c122ebe565f65cab73ba1d781910
commit 6329d68f5d50c122ebe565f65cab73ba1d781910
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sat Apr 10 20:15:12 2021 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Apr 11 18:21:29 2021 +0200
Get rid of ##sys#globalize and a hack in ##core#declare
In ##core#declare, there was some questionable messing around with the
parameterization of ##sys#current-environment after which it called
process-declaration. And process-declaration was the only procedure
which was still using ##sys#globalize so it can be dropped now.
The process of looking up variables in declarations can be a
simplified version of "resolve-variable" because it needs to take into
account only regular bindings. So, we can just look it up in the
syntax env (resolving macro aliases) and then use the alias global
hook to module-prefix it, if needed.
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/core.scm b/core.scm
index 34adbc43..492a23a7 100644
--- a/core.scm
+++ b/core.scm
@@ -1380,17 +1380,12 @@
name)))))
((##core#declare)
- (let ((old-se (##sys#current-environment)))
- (parameterize ((##sys#current-environment '())) ;; ??
- (walk
- `(##core#begin
- ,@(map (lambda (d)
- (process-declaration
- d old-se
- (lambda (id)
- (memq (lookup id) e))))
- (cdr x) ) )
- e #f #f h ln #f))) )
+ (walk
+ `(##core#begin
+ ,@(map (lambda (d)
+ (process-declaration d lookup (lambda (id) (memq (lookup id) e))))
+ (cdr x) ) )
+ e #f #f h ln #f) )
((##core#foreign-callback-wrapper)
(let-values ([(args lam) (split-at (cdr x) 4)])
@@ -1541,21 +1536,18 @@
'() #f #f #f #f #t) ) )
-(define (process-declaration spec se local?)
+(define (process-declaration spec lookup local?)
(define (check-decl spec minlen . maxlen)
(let ([n (length (cdr spec))])
(if (or (< n minlen) (> n (optional maxlen 99999)))
(syntax-error "invalid declaration" spec) ) ) )
- (define (stripa x) ; global aliasing
- (##sys#globalize x se))
- (define (globalize-all syms)
- (filter-map
- (lambda (var)
- (cond ((local? var)
- (note-local var)
- #f)
- (else (##sys#globalize var se))))
- syms))
+ (define (globalize var)
+ (cond ((local? var)
+ (note-local var)
+ #f)
+ (else (##sys#alias-global-hook (lookup var) #t #f))))
+ (define (globalize-all vars)
+ (filter-map globalize vars))
(define (note-local var)
(##sys#notice
(sprintf "ignoring declaration for locally bound variable `~a'" var)))
@@ -1578,17 +1570,17 @@
((standard-bindings)
(if (null? (cdr spec))
(set! standard-bindings default-standard-bindings)
- (set! standard-bindings (append (stripa (cdr spec)) standard-bindings)) ) )
+ (set! standard-bindings (append (globalize-all (cdr spec)) standard-bindings)) ) )
((extended-bindings)
(if (null? (cdr spec))
(set! extended-bindings default-extended-bindings)
- (set! extended-bindings (append (stripa (cdr spec)) extended-bindings)) ) )
+ (set! extended-bindings (append (globalize-all (cdr spec)) extended-bindings)) ) )
((usual-integrations)
(cond [(null? (cdr spec))
(set! standard-bindings default-standard-bindings)
(set! extended-bindings default-extended-bindings) ]
[else
- (let ([syms (stripa (cdr spec))])
+ (let ([syms (globalize-all (cdr spec))])
(set! standard-bindings (lset-intersection/eq? syms default-standard-bindings))
(set! extended-bindings (lset-intersection/eq? syms default-extended-bindings)))]))
((number-type)
@@ -1603,7 +1595,7 @@
((no-procedure-checks) (set! no-procedure-checks #t))
((disable-interrupts) (set! insert-timer-checks #f))
((always-bound)
- (for-each (cut mark-variable <> '##compiler#always-bound) (stripa (cdr spec))))
+ (for-each (cut mark-variable <> '##compiler#always-bound) (cdr spec)))
((safe-globals) (set! safe-globals-flag #t))
((no-procedure-checks-for-usual-bindings)
(for-each
@@ -1640,13 +1632,13 @@
(set! standard-bindings '())
(set! standard-bindings
(lset-difference/eq? default-standard-bindings
- (stripa (cddr spec)))))]
+ (globalize-all (cddr spec)))))]
[(extended-bindings)
(if (null? (cddr spec))
(set! extended-bindings '())
(set! extended-bindings
(lset-difference/eq? default-extended-bindings
- (stripa (cddr spec)))))]
+ (globalize-all (cddr spec)))))]
[(inline)
(if (null? (cddr spec))
(set! inline-locally #f)
@@ -1658,7 +1650,7 @@
(set! standard-bindings '())
(set! extended-bindings '()) ]
[else
- (let ([syms (stripa (cddr spec))])
+ (let ([syms (globalize-all (cddr spec))])
(set! standard-bindings (lset-difference/eq? default-standard-bindings syms))
(set! extended-bindings (lset-difference/eq? default-extended-bindings syms)))])]
((inline-global)
@@ -1709,7 +1701,7 @@
"invalid argument to `unroll-limit' declaration"
spec) ) ) )
((pure)
- (let ((syms (cdr spec)))
+ (let ((syms (globalize-all (cdr spec))))
(if (every symbol? syms)
(for-each
(cut mark-variable <> '##compiler#pure #t)
@@ -1745,7 +1737,7 @@
(else
(for-each
(cut mark-variable <> '##compiler#local)
- (stripa (cdr spec))))))
+ (globalize-all (cdr spec))))))
((inline-global)
(set! enable-inline-files #t)
(set! inline-locally #t)
@@ -1760,7 +1752,7 @@
(>= (length spec) 2)
(symbol? (car spec))))
(warning "illegal type declaration" (strip-syntax spec))
- (let ((name (##sys#globalize (car spec) se))
+ (let ((name (globalize (car spec)))
(type (strip-syntax (cadr spec))))
(if (local? (car spec))
(note-local (car spec))
@@ -1768,7 +1760,6 @@
(cond (type
;; HACK: since `:' doesn't have access to the SE, we
;; fixup the procedure name if type is a named procedure type
- ;; (We only have access to the SE for ##sys#globalize in here).
;; Quite terrible.
(when (and (pair? type)
(eq? 'procedure (car type))
@@ -1793,7 +1784,7 @@
(for-each
(lambda (spec)
(cond ((and (list? spec) (symbol? (car spec)) (= 2 (length spec)))
- (let ((name (##sys#globalize (car spec) se))
+ (let ((name (globalize (car spec)))
(type (strip-syntax (cadr spec))))
(if (local? (car spec))
(note-local (car spec))
diff --git a/expand.scm b/expand.scm
index 9a3ee7ac..e815a2b9 100644
--- a/expand.scm
+++ b/expand.scm
@@ -143,21 +143,6 @@
(append (map (lambda (x y) (cons x y)) vars aliases) se)) ; inline cons
-;;; resolve symbol to global name
-
-(define (##sys#globalize sym se)
- (let loop1 ((sym sym))
- (cond ((not (symbol? sym)) sym)
- ((getp sym '##core#macro-alias) =>
- (lambda (a) (if (symbol? a) (loop1 a) sym)))
- (else
- (let loop ((se se)) ; ignores syntax bindings
- (cond ((null? se)
- (##sys#alias-global-hook sym #t #f)) ;XXX could hint at decl (3rd arg)
- ((and (eq? sym (caar se)) (symbol? (cdar se))) (cdar se))
- (else (loop (cdr se)))))))))
-
-
;;; Macro handling
(define ##sys#macro-environment (make-parameter '()))
Trap