diff --git a/.gitignore b/.gitignore index dc8eedaf4..7d2d79daa 100644 --- a/.gitignore +++ b/.gitignore @@ -168,3 +168,4 @@ INSTALL /meta/build-env /lib/limits.h /lib/stdint.h +/filesys-test-link.tmp diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index adc699713..41feb947c 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -954,13 +954,12 @@ ;; and if so, compare their bindings, that they are either ;; bound to the same variable, or both unbound and have ;; the same name. - (and (eq? nj (id-sym-name j)) - (let ((bi (id-module-binding i mi))) + (and (symbol? nj) + (let ((bi (id-module-binding ni mi))) (if bi - (eq? bi (id-module-binding j mj)) - (and (not (id-module-binding j mj)) - (eq? ni nj)))) - (eq? (id-module-binding i mi) (id-module-binding j mj)))) + (eq? bi (id-module-binding nj mj)) + (and (not (id-module-binding nj mj)) + (eq? ni nj)))))) (else ;; Otherwise `i' is bound, so check that `j' is bound, and ;; bound to the same thing. @@ -1129,6 +1128,11 @@ mod)) (lambda () (build-global-definition s var (expand e r w mod))))))))) + ((define-alias-form) + (let ((id (wrap value w mod)) + (label (id-var-name e w mod))) + (extend-ribcage! ribcage id label) + '())) ((define-syntax-form define-syntax-parameter-form) (let* ((id (wrap value w mod)) (label (gen-label)) @@ -1272,6 +1276,7 @@ ;; call none any other call ;; begin-form none begin expression ;; define-form id variable definition + ;; define-alias-form id alias definition ;; define-syntax-form id syntax definition ;; define-syntax-parameter-form id syntax parameter definition ;; local-syntax-form rec? syntax definition @@ -1359,6 +1364,11 @@ (wrap e w mod) #'(if #f #f) empty-wrap s mod)))) + ((define-alias) + (syntax-case e () + ((_ name val) + (and (id? #'name) (id? #'val)) + (values 'define-alias-form #'name e #'val w s mod)))) ((define-syntax) (syntax-case e () ((_ name val) @@ -1443,7 +1453,8 @@ (if (memq 'eval when-list) (expand-sequence #'(e1 e2 ...) r w s mod) (expand-void)))))) - ((define-form define-syntax-form define-syntax-parameter-form) + ((define-form define-alias-form define-syntax-form + define-syntax-parameter-form) (syntax-violation #f "definition in expression context, where definitions are not allowed," (source-wrap form w s mod))) ((syntax) @@ -1600,6 +1611,12 @@ (cons id var-ids) (cons var vars) (cons (cons er (wrap e w mod)) vals) (cons (make-binding 'lexical var) bindings))))) + ((define-alias-form) + (let ((id (wrap value w mod)) + (label (id-var-name e w mod))) + (extend-ribcage! ribcage id label) + (parse (cdr body) (cons id ids) labels var-ids vars vals + bindings))) ((define-syntax-form) (let ((id (wrap value w mod)) (label (gen-label)) @@ -1727,8 +1744,8 @@ (call-with-values (lambda () (resolve-identifier (make-syntax '#{ $sc-ellipsis }# - (syntax-wrap e) - (syntax-module e)) + (syntax-wrap e) + (syntax-module e)) empty-wrap r mod #f)) (lambda (type value mod) (if (eq? type 'ellipsis) @@ -2036,10 +2053,10 @@ (eval-local-transformer (expand x trans-r w mod) mod))) #'(val ...))))) (expand-body #'(e1 e2 ...) - (source-wrap e w s mod) - (extend-env names bindings r) - w - mod))) + (source-wrap e w s mod) + (extend-env names bindings r) + w + mod))) (_ (syntax-violation 'syntax-parameterize "bad syntax" (source-wrap e w s mod)))))) @@ -2290,8 +2307,8 @@ (let ((id (if (symbol? #'dots) '#{ $sc-ellipsis }# (make-syntax '#{ $sc-ellipsis }# - (syntax-wrap #'dots) - (syntax-module #'dots))))) + (syntax-wrap #'dots) + (syntax-module #'dots))))) (let ((ids (list id)) (labels (list (gen-label))) (bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod))))) @@ -2503,6 +2520,8 @@ (global-extend 'define 'define '()) + (global-extend 'define-alias 'define-alias '()) + (global-extend 'define-syntax 'define-syntax '()) (global-extend 'define-syntax-parameter 'define-syntax-parameter '()) @@ -2519,12 +2538,12 @@ (syntax-case p* () ((x . y) (call-with-values - (lambda () (cvt* #'y n ids)) - (lambda (y ids) - (call-with-values - (lambda () (cvt #'x n ids)) - (lambda (x ids) - (values (cons x y) ids)))))) + (lambda () (cvt* #'y n ids)) + (lambda (y ids) + (call-with-values + (lambda () (cvt #'x n ids)) + (lambda (x ids) + (values (cons x y) ids)))))) (_ (cvt p* n ids))))) (define (v-reverse x) @@ -2589,15 +2608,15 @@ 'apply (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '() (expand exp - (extend-env - labels - (map (lambda (var level) - (make-binding 'syntax `(,var . ,level))) - new-vars - (map cdr pvars)) - r) - (make-binding-wrap ids labels empty-wrap) - mod)) + (extend-env + labels + (map (lambda (var level) + (make-binding 'syntax `(,var . ,level))) + new-vars + (map cdr pvars)) + r) + (make-binding-wrap ids labels empty-wrap) + mod)) y)))))) (define gen-clause @@ -2653,12 +2672,12 @@ no-source (list (syntax->datum #'pat)) #f (list var) '() (expand #'exp - (extend-env labels - (list (make-binding 'syntax `(,var . 0))) - r) - (make-binding-wrap #'(pat) - labels empty-wrap) - mod)) + (extend-env labels + (list (make-binding 'syntax `(,var . 0))) + r) + (make-binding-wrap #'(pat) + labels empty-wrap) + mod)) (list x)))) (gen-clause x keys (cdr clauses) r #'pat #t #'exp mod))) @@ -2696,58 +2715,58 @@ ;; expanded, and the expanded definitions are also residualized into ;; the object file if we are compiling a file. (set! macroexpand - (lambda* (x #:optional (m 'e) (esew '(eval))) - (expand-top-sequence (list x) null-env top-wrap #f m esew - (cons 'hygiene (module-name (current-module)))))) + (lambda* (x #:optional (m 'e) (esew '(eval))) + (expand-top-sequence (list x) null-env top-wrap #f m esew + (cons 'hygiene (module-name (current-module)))))) (set! identifier? - (lambda (x) - (nonsymbol-id? x))) + (lambda (x) + (nonsymbol-id? x))) (set! datum->syntax - (lambda (id datum) - (make-syntax datum (syntax-wrap id) - (syntax-module id)))) + (lambda (id datum) + (make-syntax datum (syntax-wrap id) + (syntax-module id)))) (set! syntax->datum - ;; accepts any object, since syntax objects may consist partially - ;; or entirely of unwrapped, nonsymbolic data - (lambda (x) - (strip x empty-wrap))) + ;; accepts any object, since syntax objects may consist partially + ;; or entirely of unwrapped, nonsymbolic data + (lambda (x) + (strip x empty-wrap))) (set! syntax-source - (lambda (x) (source-annotation x))) + (lambda (x) (source-annotation x))) (set! generate-temporaries - (lambda (ls) - (arg-check list? ls 'generate-temporaries) - (let ((mod (cons 'hygiene (module-name (current-module))))) - (map (lambda (x) - (wrap (module-gensym "t") top-wrap mod)) - ls)))) + (lambda (ls) + (arg-check list? ls 'generate-temporaries) + (let ((mod (cons 'hygiene (module-name (current-module))))) + (map (lambda (x) + (wrap (module-gensym "t") top-wrap mod)) + ls)))) (set! free-identifier=? - (lambda (x y) - (arg-check nonsymbol-id? x 'free-identifier=?) - (arg-check nonsymbol-id? y 'free-identifier=?) - (free-id=? x y))) + (lambda (x y) + (arg-check nonsymbol-id? x 'free-identifier=?) + (arg-check nonsymbol-id? y 'free-identifier=?) + (free-id=? x y))) (set! bound-identifier=? - (lambda (x y) - (arg-check nonsymbol-id? x 'bound-identifier=?) - (arg-check nonsymbol-id? y 'bound-identifier=?) - (bound-id=? x y))) + (lambda (x y) + (arg-check nonsymbol-id? x 'bound-identifier=?) + (arg-check nonsymbol-id? y 'bound-identifier=?) + (bound-id=? x y))) (set! syntax-violation - (lambda* (who message form #:optional subform) - (arg-check (lambda (x) (or (not x) (string? x) (symbol? x))) - who 'syntax-violation) - (arg-check string? message 'syntax-violation) - (throw 'syntax-error who message - (or (source-annotation subform) - (source-annotation form)) - (strip form empty-wrap) - (and subform (strip subform empty-wrap))))) + (lambda* (who message form #:optional subform) + (arg-check (lambda (x) (or (not x) (string? x) (symbol? x))) + who 'syntax-violation) + (arg-check string? message 'syntax-violation) + (throw 'syntax-error who message + (or (source-annotation subform) + (source-annotation form)) + (strip form empty-wrap) + (and subform (strip subform empty-wrap))))) (let () (define (%syntax-module id) @@ -2788,8 +2807,8 @@ ((ellipsis) (values 'ellipsis (make-syntax (syntax-expression value) - (anti-mark (syntax-wrap value)) - (syntax-module value)))) + (anti-mark (syntax-wrap value)) + (syntax-module value)))) (else (values 'other #f)))))))) (define (syntax-locally-bound-identifiers id) @@ -2913,8 +2932,8 @@ ((null? p) (and (null? e) r)) ((pair? p) (and (pair? e) (match (car e) (car p) w - (match (cdr e) (cdr p) w r mod) - mod))) + (match (cdr e) (cdr p) w r mod) + mod))) ((eq? p 'each-any) (let ((l (match-each-any e w mod))) (and l (cons l r)))) (else @@ -2960,14 +2979,14 @@ (else (match* e p w r mod))))) (set! $sc-dispatch - (lambda (e p) - (cond - ((eq? p 'any) (list e)) - ((eq? p '_) '()) - ((syntax? e) - (match* (syntax-expression e) - p (syntax-wrap e) '() (syntax-module e))) - (else (match* e p empty-wrap '() #f)))))))) + (lambda (e p) + (cond + ((eq? p 'any) (list e)) + ((eq? p '_) '()) + ((syntax? e) + (match* (syntax-expression e) + p (syntax-wrap e) '() (syntax-module e))) + (else (match* e p empty-wrap '() #f)))))))) (define-syntax with-syntax diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 883004a27..67df87b3d 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -1649,6 +1649,50 @@ (hash interpreted most-positive-fixnum) (hash compiled most-positive-fixnum)))) +(with-test-prefix "aliases" + (pass-if "aliased variables are eq?" + (let ((x "var")) + (define-alias y x) + (eq? x y))) + + (pass-if "can alias definition in the same body" + (let ((y #f)) + (define x #t) + (define-alias y x) + y)) + + (pass-if "right hand side of alias-definition is not postponed" + (let ((x #t)) + (define-alias y x) + (define x #f) + y)) + + (pass-if "alias is free-identifier=?" + (let ((x #t)) + (define-syntax foo + (syntax-rules (x) + ((foo x) #t) + ((foo _) #f))) + (let () + (define-alias y x) + (foo y)))) + + (pass-if "alias is free-identifier=? with unbound" + (let () + (define-syntax foo + (syntax-rules (x z) + ((foo z) #f) + ((foo x) #t) + ((foo _) #f))) + (let () + (define-alias y x) + (foo y)))) + + (pass-if-equal "alias is free-identifier=? with globals" + '(1 5) + (let () + (define-alias comma unquote) + `(1 (comma (+ 2 3)))))) ;;; Local Variables: ;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1)