~ chicken-core (chicken-5) 571d33e252c845bf22cd208fd563c9bae5045f7c
commit 571d33e252c845bf22cd208fd563c9bae5045f7c
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Wed Mar 14 18:53:48 2018 +1300
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun Mar 18 14:19:42 2018 +0100
Remove primitive aliasing
Now that all built-in values are namespaced rather than marked as
"##core#primitive" and aliased with a "#%" prefix, we can drop all
special handling for primitive variable marks.
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index c267f198..772c59d9 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -75,8 +75,7 @@
(##sys#extend-macro-environment
'condition-case
- `((else . ,(##sys#primitive-alias 'else))
- (memv . scheme#memv))
+ `((memv . scheme#memv))
(##sys#er-transformer
(lambda (form r c)
(##sys#check-syntax 'condition-case form '(_ _ . _))
diff --git a/compiler-syntax.scm b/compiler-syntax.scm
index 57ca9fbb..ca73b5ac 100644
--- a/compiler-syntax.scm
+++ b/compiler-syntax.scm
@@ -67,7 +67,7 @@
((_ (names . llist) se . body)
(r-c-s 'names (lambda llist . body) se))))
-(define-internal-compiler-syntax ((scheme#for-each ##sys#for-each #%for-each) x r c)
+(define-internal-compiler-syntax ((scheme#for-each ##sys#for-each) x r c)
'((pair? . scheme#pair?))
(let ((%let (r 'let))
(%if (r 'if))
@@ -97,7 +97,7 @@
,@(map (lambda (v) `(##sys#slot ,v 1)) vars) ) )))))
x)))
-(define-internal-compiler-syntax ((scheme#map ##sys#map #%map) x r c)
+(define-internal-compiler-syntax ((scheme#map ##sys#map) x r c)
'((pair? . scheme#pair?) (cons . scheme#cons))
(let ((%let (r 'let))
(%if (r 'if))
@@ -274,7 +274,7 @@
(loop '()) )
(loop (cons c chunk)))))))))))))
-(define-internal-compiler-syntax ((chicken.base#foldr #%foldr) x r c)
+(define-internal-compiler-syntax ((chicken.base#foldr) x r c)
'((pair? . scheme#pair?))
(if (and (fx= (length x) 4)
(memq 'chicken.base#foldr extended-bindings) ) ; s.a.
@@ -296,7 +296,7 @@
,z))))
x))
-(define-internal-compiler-syntax ((chicken.base#foldl #%foldl) x r c)
+(define-internal-compiler-syntax ((chicken.base#foldl) x r c)
'((pair? . scheme#pair?))
(if (and (fx= (length x) 4)
(memq 'chicken.base#foldl extended-bindings) ) ; s.a.
diff --git a/core.scm b/core.scm
index 69822b98..be629780 100644
--- a/core.scm
+++ b/core.scm
@@ -578,7 +578,6 @@
(finish-foreign-result ft body)
t)
e se dest ldest h #f #f))))
- ((##sys#get x '##core#primitive))
((not (memq x e)) (##sys#alias-global-hook x #f h)) ; only if global
(else x))))
@@ -624,8 +623,7 @@
(##sys#syntax-error/context (sprintf "(~a) - malformed expression" ln) x)
(##sys#syntax-error/context "malformed expression" x)))
(set! ##sys#syntax-error-culprit x)
- (let* ((name0 (lookup (car x) se))
- (name (or (and (symbol? name0) (##sys#get name0 '##core#primitive)) name0))
+ (let* ((name (lookup (car x) se))
(xexpanded
(fluid-let ((chicken.syntax#expansion-result-hook
(handle-expansion-result ln)))
@@ -1100,8 +1098,7 @@
e se #f #f h ln #f))))
(else
(unless (memq var e) ; global?
- (set! var (or (##sys#get var '##core#primitive)
- (##sys#alias-global-hook var #t dest)))
+ (set! var (##sys#alias-global-hook var #t dest))
(when safe-globals-flag
(mark-variable var '##compiler#always-bound-to-procedure)
(mark-variable var '##compiler#always-bound))
diff --git a/eval.scm b/eval.scm
index 8dfbee9d..b777c412 100644
--- a/eval.scm
+++ b/eval.scm
@@ -134,10 +134,10 @@
(receive (i j) (lookup x e se)
(cond ((not i)
(let ((var (cond ((not (symbol? j)) x) ; syntax?
- ((not (assq x se))
- (and (not static)
- (##sys#alias-global-hook j #f cntr)))
- (else (or (##sys#get j '##core#primitive) j)))))
+ ((assq x se) j)
+ ((not static)
+ (##sys#alias-global-hook j #f cntr))
+ (else #f))))
(when (and ##sys#unbound-in-eval
(or (not var)
(not (##sys#symbol-has-toplevel-binding? var))))
@@ -263,10 +263,10 @@
((symbol? (cdr a))))
(##sys#notice "assignment to imported value binding" var)))
(let ((var
- (if (not (assq x se)) ;XXX this looks wrong
- (and (not static)
- (##sys#alias-global-hook j #t cntr))
- (or (##sys#get j '##core#primitive) j))))
+ (cond ((assq x se) j) ;XXX this looks wrong
+ ((not static)
+ (##sys#alias-global-hook j #t cntr))
+ (else #f))))
(if (not var) ; static
(lambda (v)
(##sys#error 'eval "environment is not mutable" evalenv var)) ;XXX var?
diff --git a/expand.scm b/expand.scm
index c33b547e..18237e54 100644
--- a/expand.scm
+++ b/expand.scm
@@ -91,12 +91,6 @@
;;XXX should this be in eval.scm?
(define ##sys#active-eval-environment (make-parameter ##sys#current-environment))
-(define (##sys#primitive-alias sym)
- (let ((alias (##sys#string->symbol
- (##sys#string-append "#%" (##sys#slot sym 1)))))
- (putp alias '##core#primitive sym)
- alias))
-
(define (lookup id se)
(cond ((##core#inline "C_u_i_assq" id se) => cdr)
((getp id '##core#macro-alias))
@@ -874,9 +868,7 @@
(lookup2 2 s2 dse)
s2) ) )
(cond ((symbol? ss1)
- (cond ((symbol? ss2)
- (eq? (or (getp ss1 '##core#primitive) ss1)
- (or (getp ss2 '##core#primitive) ss2)))
+ (cond ((symbol? ss2) (eq? ss1 ss2))
((assq ss1 (##sys#macro-environment)) =>
(lambda (a) (eq? (cdr a) ss2)))
(else #f) ) )
diff --git a/modules.scm b/modules.scm
index aed031c4..1a88dc92 100644
--- a/modules.scm
+++ b/modules.scm
@@ -407,11 +407,7 @@
(let* ((me (##sys#macro-environment))
(mod (make-module
name lib '()
- (map (lambda (ve)
- (if (symbol? ve)
- (cons ve (##sys#primitive-alias ve))
- ve))
- vexports)
+ vexports
(map (lambda (se)
(if (symbol? se)
(or (assq se me)
@@ -782,11 +778,7 @@
(module-rename sym (module-name mod))))
(else sym)))
(cond ((##sys#qualified-symbol? sym) sym)
- ((getp sym '##core#primitive) =>
- (lambda (p)
- (dm "(ALIAS) primitive: " p)
- p))
- ((getp sym '##core#aliased)
+ ((getp sym '##core#aliased)
(dm "(ALIAS) marked: " sym)
sym)
((namespaced-symbol? sym) sym)
@@ -794,9 +786,8 @@
(lambda (a)
(let ((sym2 (cdr a)))
(dm "(ALIAS) in current environment " sym " -> " sym2)
- (if (pair? sym2) ; macro (XXX can this be?)
- (mrename sym)
- (or (getp sym2 '##core#primitive) sym2)))))
+ ;; check for macro (XXX can this be?)
+ (if (pair? sym2) (mrename sym) sym2))))
(else (mrename sym))))
(define (##sys#validate-exports exps loc)
Trap