Hi all, The attached patch is quite straightforward and should fix the issues we've seen with the "coops" and "matchable" eggs. The reason coops would fail was that it contained a (match options '((reader: x) ...)) call, which would be expanded by syntax-rules into a pattern variable, which then would fail due to the fact that it would be put into a let form.
The diff in synrules.scm fixes that part. I also then changed the binding forms from expand.scm and chicken-syntax to use "variable" instead of "symbol" in their ##sys#check-syntax calls. This now no longer allows keywords. This avoids the weird "internal" error about keywords not having plists when you try something like (define foo: 1). Instead, you just get "identifier expected", which is clearer to the user and causes these macros to bail out much earlier. I'm pretty sure these aren't all assumptions in the compiler that symbols and keywords are the same, but this should cover 90% of the typical situations. We could consider making symbols and keywords completely distinct objects by having symbol? return #f on keywords. That probably requires a CR, though. It might be wise to do, as it would completely eradicate this class of errors. Cheers, Peter
From f1851b25af60adc66004b510658cec70968b86e2 Mon Sep 17 00:00:00 2001 From: Peter Bex <[email protected]> Date: Fri, 3 May 2019 21:07:24 +0200 Subject: [PATCH] Reject keywords as identifiers in binding forms Trying to bind a keyword would cause internal compiler errors like "(get): keyword has no plist". Instead, we reject them offhand by changing the binding forms' syntax check to use "variable" instead of "symbol" (which they should have done in the first place but it made no difference in practice). Then, we also change syntax-rules so it does not see keywords as valid pattern variables, which it would put in (let ...) forms. --- expand.scm | 25 ++++++++++++++----------- synrules.scm | 15 +++++++++------ tests/syntax-tests.scm | 13 +++++++++++++ 3 files changed, 36 insertions(+), 17 deletions(-) diff --git a/expand.scm b/expand.scm index 2092798c..baaa133c 100644 --- a/expand.scm +++ b/expand.scm @@ -770,6 +770,9 @@ (loop (cdr x)) ) ) ) (else #f) ) ) ) ) + (define (variable? v) + (and (symbol? v) (not (##core#inline "C_u_i_keywordp" v)))) + (define (proper-list? x) (let loop ((x x)) (cond ((eq? x '())) @@ -803,7 +806,7 @@ (case p ((_) #t) ((pair) (test x pair? "pair expected")) - ((variable) (test x symbol? "identifier expected")) + ((variable) (test x variable? "identifier expected")) ((symbol) (test x symbol? "symbol expected")) ((list) (test x proper-list? "proper list expected")) ((number) (test x number? "number expected")) @@ -1246,7 +1249,7 @@ (let ((head (cadr form)) (body (cddr form)) ) (cond ((not (pair? head)) - (##sys#check-syntax 'define form '(_ symbol . #(_ 0 1))) + (##sys#check-syntax 'define form '(_ variable . #(_ 0 1))) (let ((name (or (getp head '##core#macro-alias) head))) (##sys#register-export name (##sys#current-module))) (when (c (r 'define) head) @@ -1260,7 +1263,7 @@ (##sys#check-syntax 'define form '(_ (_ . lambda-list) . #(_ 1))) (loop (chicken.syntax#expand-curried-define head body '()))) ;XXX '() should be se (else - (##sys#check-syntax 'define form '(_ (symbol . lambda-list) . #(_ 1))) + (##sys#check-syntax 'define form '(_ (variable . lambda-list) . #(_ 1))) (loop (list (car x) (car head) `(##core#lambda ,(cdr head) ,@body))))))))))) (set! chicken.syntax#define-syntax-definition @@ -1269,7 +1272,7 @@ '() (##sys#er-transformer (lambda (form r c) - (##sys#check-syntax 'define-syntax form '(_ symbol _)) + (##sys#check-syntax 'define-syntax form '(_ variable _)) (let ((head (cadr form)) (body (caddr form))) (let ((name (or (getp head '##core#macro-alias) head))) @@ -1284,10 +1287,10 @@ (##sys#er-transformer (lambda (x r c) (cond ((and (pair? (cdr x)) (symbol? (cadr x))) - (##sys#check-syntax 'let x '(_ symbol #((symbol _) 0) . #(_ 1))) + (##sys#check-syntax 'let x '(_ variable #((variable _) 0) . #(_ 1))) (check-for-multiple-bindings (caddr x) x "let")) (else - (##sys#check-syntax 'let x '(_ #((symbol _) 0) . #(_ 1))) + (##sys#check-syntax 'let x '(_ #((variable _) 0) . #(_ 1))) (check-for-multiple-bindings (cadr x) x "let"))) `(##core#let ,@(cdr x))))) @@ -1296,7 +1299,7 @@ '() (##sys#er-transformer (lambda (x r c) - (##sys#check-syntax 'letrec x '(_ #((symbol _) 0) . #(_ 1))) + (##sys#check-syntax 'letrec x '(_ #((variable _) 0) . #(_ 1))) (check-for-multiple-bindings (cadr x) x "letrec") `(##core#letrec ,@(cdr x))))) @@ -1305,7 +1308,7 @@ '() (##sys#er-transformer (lambda (x r c) - (##sys#check-syntax 'let-syntax x '(_ #((symbol _) 0) . #(_ 1))) + (##sys#check-syntax 'let-syntax x '(_ #((variable _) 0) . #(_ 1))) (check-for-multiple-bindings (cadr x) x "let-syntax") `(##core#let-syntax ,@(cdr x))))) @@ -1314,7 +1317,7 @@ '() (##sys#er-transformer (lambda (x r c) - (##sys#check-syntax 'letrec-syntax x '(_ #((symbol _) 0) . #(_ 1))) + (##sys#check-syntax 'letrec-syntax x '(_ #((variable _) 0) . #(_ 1))) (check-for-multiple-bindings (cadr x) x "letrec-syntax") `(##core#letrec-syntax ,@(cdr x))))) @@ -1475,7 +1478,7 @@ '() (##sys#er-transformer (lambda (form r c) - (##sys#check-syntax 'let* form '(_ #((symbol _) 0) . #(_ 1))) + (##sys#check-syntax 'let* form '(_ #((variable _) 0) . #(_ 1))) (let ((bindings (cadr form)) (body (cddr form)) ) (let expand ((bs bindings)) @@ -1488,7 +1491,7 @@ '() (##sys#er-transformer (lambda (form r c) - (##sys#check-syntax 'do form '(_ #((symbol _ . #(_)) 0) . #(_ 1))) + (##sys#check-syntax 'do form '(_ #((variable _ . #(_)) 0) . #(_ 1))) (let ((bindings (cadr form)) (test (caddr form)) (body (cdddr form)) diff --git a/synrules.scm b/synrules.scm index d0919862..d3453fe7 100644 --- a/synrules.scm +++ b/synrules.scm @@ -64,6 +64,9 @@ (import scheme) +(define (plain-symbol? x) + (and (symbol? x) (not (##core#inline "C_u_i_keywordp" x))) ) + (define (syntax-rules-mismatch input) (##sys#syntax-error-hook "no rule matches form" input)) @@ -160,7 +163,7 @@ ;; Generate code to test whether input expression matches pattern (define (process-match input pattern seen-segment?) - (cond ((symbol? pattern) + (cond ((plain-symbol? pattern) (if (memq pattern subkeywords) `((,%compare ,input (,%rename (##core#syntax ,pattern)))) `())) @@ -199,7 +202,7 @@ ;; This is pretty bad, but it seems to work (can't say why). (define (process-pattern pattern path mapit seen-segment?) - (cond ((symbol? pattern) + (cond ((plain-symbol? pattern) (if (memq pattern subkeywords) '() (list (list pattern (mapit path))))) @@ -230,7 +233,7 @@ ;; Generate code to compose the output expression according to template (define (process-template template dim env) - (cond ((symbol? template) + (cond ((plain-symbol? template) (let ((probe (assq template env))) (if probe (if (<= (cdr probe) dim) @@ -250,7 +253,7 @@ env)) (gen (if (and (pair? vars) (null? (cdr vars)) - (symbol? x) + (plain-symbol? x) (eq? x (car vars))) x ;+++ `(,%map (,%lambda ,vars ,x) @@ -275,7 +278,7 @@ ;; Return an association list of (var . dim) (define (meta-variables pattern dim vars seen-segment?) - (cond ((symbol? pattern) + (cond ((plain-symbol? pattern) (if (memq pattern subkeywords) vars (cons (cons pattern dim) vars))) @@ -292,7 +295,7 @@ ;; Return a list of meta-variables of given higher dim (define (free-meta-variables template dim env free) - (cond ((symbol? template) + (cond ((plain-symbol? template) (if (and (not (memq template free)) (let ((probe (assq template env))) (and probe (>= (cdr probe) dim)))) diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm index bd88ec14..3637fde9 100644 --- a/tests/syntax-tests.scm +++ b/tests/syntax-tests.scm @@ -36,6 +36,11 @@ (t 100 (test 2 100)) + +;; Keywords are not symbols; don't attempt to bind them +(t 1 (let-syntax ((foo (syntax-rules () ((foo bar: qux) qux)))) + (foo bar: 1))) + ;; some basic contrived testing (define (fac n) @@ -809,6 +814,14 @@ ) |# +;;; Definitions of non-identifiers + +(f (eval '(define foo: 1))) +(f (eval '(define-syntax foo: (syntax-rules () ((_) 1))))) +(f (eval '(let foo: () 1))) +(f (eval '(let ((foo: 1)) 1))) + + ;;; Definitions in expression contexts are rejected (#1309) (f (eval '(+ 1 2 (begin (define x 3) x) 4))) -- 2.11.0
signature.asc
Description: PGP signature
_______________________________________________ Chicken-hackers mailing list [email protected] https://lists.nongnu.org/mailman/listinfo/chicken-hackers
