>From 568d5a773f0c86af76a0e1953e3b401c0417149d Mon Sep 17 00:00:00 2001 From: Evan Hanson Date: Wed, 14 Mar 2018 18:53:48 +1300 Subject: [PATCH 2/2] 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. --- chicken-syntax.scm | 3 +-- compiler-syntax.scm | 8 ++++---- core.scm | 7 ++----- eval.scm | 16 ++++++++-------- expand.scm | 10 +--------- modules.scm | 17 ++++------------- 6 files changed, 20 insertions(+), 41 deletions(-) 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) -- 2.11.0