From 13cbbe7b6894d9240495526cd225834e77f31adb Mon Sep 17 00:00:00 2001 From: Peter Bex 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. --- chicken-syntax.scm | 16 ++++++++-------- expand.scm | 25 ++++++++++++++----------- synrules.scm | 15 +++++++++------ tests/syntax-tests.scm | 13 +++++++++++++ 4 files changed, 44 insertions(+), 25 deletions(-) diff --git a/chicken-syntax.scm b/chicken-syntax.scm index 2451075e..dbf74803 100644 --- a/chicken-syntax.scm +++ b/chicken-syntax.scm @@ -323,14 +323,14 @@ '() (##sys#er-transformer (lambda (form r c) - (##sys#check-syntax 'define-constant form '(_ symbol _)) + (##sys#check-syntax 'define-constant form '(_ variable _)) `(##core#define-constant ,@(cdr form))))) (##sys#extend-macro-environment 'define-record '() (##sys#er-transformer (lambda (x r c) - (##sys#check-syntax 'define-record x '(_ symbol . _)) + (##sys#check-syntax 'define-record x '(_ variable . _)) (let* ((type-name (cadr x)) (plain-name (strip-syntax type-name)) (prefix (symbol->string plain-name)) @@ -449,7 +449,7 @@ 'fluid-let '() (##sys#er-transformer (lambda (form r c) - (##sys#check-syntax 'fluid-let form '(_ #((symbol _) 0) . _)) + (##sys#check-syntax 'fluid-let form '(_ #((variable _) 0) . _)) (let* ((clauses (cadr form)) (body (cddr form)) (ids (##sys#map car clauses)) @@ -679,7 +679,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))))) @@ -728,7 +728,7 @@ (let ([b (car bs)] [bs2 (cdr bs)] ) (cond [(not (pair? b)) - (##sys#check-syntax 'and-let* b 'symbol) + (##sys#check-syntax 'and-let* b 'variable) (let ((var (r (gensym)))) `(##core#let ((,var ,b)) (##core#if ,var ,(fold bs2 var) #f)))] @@ -737,7 +737,7 @@ `(##core#let ((,var ,(car b))) (##core#if ,var ,(fold bs2 var) #f)))] [else - (##sys#check-syntax 'and-let* b '(symbol _)) + (##sys#check-syntax 'and-let* b '(variable _)) (let ((var (car b))) `(##core#let ((,var ,(cadr b))) (##core#if ,var ,(fold bs2 var) #f)))])))))))) @@ -1049,7 +1049,7 @@ (cond [(pair? head) (##sys#check-syntax 'define-record-printer (cons head body) - '((symbol symbol symbol) . #(_ 1))) + '((variable variable variable) . #(_ 1))) (let* ((plain-name (strip-syntax (##sys#slot head 0))) (tag (if (##sys#current-module) (symbol-append @@ -1060,7 +1060,7 @@ (##core#quote ,tag) (##core#lambda ,(##sys#slot head 1) ,@body)))] (else - (##sys#check-syntax 'define-record-printer (cons head body) '(symbol _)) + (##sys#check-syntax 'define-record-printer (cons head body) '(variable _)) (let* ((plain-name (strip-syntax head)) (tag (if (##sys#current-module) (symbol-append 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