From d320d54e7df107fff622aa9b3d19807057b67783 Mon Sep 17 00:00:00 2001 From: "michele.simionato" Date: Tue, 24 Mar 2009 06:12:12 +0000 Subject: Simplified the syntax-match implementation --- scheme/sweet-macros/helper1.mzscheme.sls | 8 ++--- scheme/sweet-macros/helper2.mzscheme.sls | 32 +++++++++---------- scheme/sweet-macros/helper3.mzscheme.sls | 15 +++++---- scheme/sweet-macros/main.sls | 55 +++++++++++++++----------------- 4 files changed, 52 insertions(+), 58 deletions(-) (limited to 'scheme') diff --git a/scheme/sweet-macros/helper1.mzscheme.sls b/scheme/sweet-macros/helper1.mzscheme.sls index 206f540..a5964b5 100644 --- a/scheme/sweet-macros/helper1.mzscheme.sls +++ b/scheme/sweet-macros/helper1.mzscheme.sls @@ -21,11 +21,7 @@ )))))) (lambda (x) (syntax-case x () - ((guarded-syntax-case () (literal ...) clause ...) - #'(lambda (y) (guarded-syntax-case y (literal ...) clause ...))) ((guarded-syntax-case y (literal ...) clause ...) - (with-syntax - (((c ...) (fold-right add-clause '() #'(clause ...)))) - #'(syntax-case y (literal ...) c ...))) - )))) + (with-syntax (((c ...) (fold-right add-clause '() #'(clause ...)))) + #'(syntax-case y (literal ...) c ...))))))) ) diff --git a/scheme/sweet-macros/helper2.mzscheme.sls b/scheme/sweet-macros/helper2.mzscheme.sls index 2be4d40..29045f5 100644 --- a/scheme/sweet-macros/helper2.mzscheme.sls +++ b/scheme/sweet-macros/helper2.mzscheme.sls @@ -5,20 +5,20 @@ (for (sweet-macros helper1) (meta -1) (meta 0) (meta 1))) (define-syntax syntax-match - (guarded-syntax-case () (sub) - - ((self (literal ...) (sub patt skel rest ...) ...) - #'(guarded-syntax-case () - ( literal ...) - ((ctx ) #''(literal ...)) - ((ctx ) #''((... (... patt)) ...)) - (patt skel rest ...) - ...) - (for-all identifier? #'(literal ...)) - (syntax-violation 'syntax-match "Found non identifier" #'(literal ...) - (remp identifier? #'(literal ...)))) - - ((self x (literal ...) (sub patt skel rest ...) ...) - #'(guarded-syntax-case x (literal ...) (patt skel rest ...) ...)) - )) + (lambda (y) + (guarded-syntax-case y (sub) + + ((self (literal ...) (sub patt skel rest ...) ...) + #'(lambda (x) (self x (literal ...) (sub patt skel rest ...) ...))) + + ((self x (literal ...) (sub patt skel rest ...) ...) + #'(guarded-syntax-case x ( literal ...) + ((ctx ) #''(literal ...)) + ((ctx ) #''((... (... patt)) ...)) + (patt skel rest ...) + ...) + (for-all identifier? #'(literal ...)) + (syntax-violation 'syntax-match "Found non identifier" #'(literal ...) + (remp identifier? #'(literal ...)))) + ))) ) diff --git a/scheme/sweet-macros/helper3.mzscheme.sls b/scheme/sweet-macros/helper3.mzscheme.sls index b1cb947..f737dc0 100644 --- a/scheme/sweet-macros/helper3.mzscheme.sls +++ b/scheme/sweet-macros/helper3.mzscheme.sls @@ -6,6 +6,12 @@ (define-syntax def-syntax (syntax-match (extends) + (sub (def-syntax name (extends parent) (literal ...) clause ...) + #'(def-syntax name + (syntax-match (literal ...) + clause ... + (sub x ((parent ) #'x))))) + (sub (def-syntax (name . args) skel rest ...) #'(def-syntax name (syntax-match () (sub (name . args) skel rest ...)))) @@ -16,13 +22,8 @@ ((name ) #'(... (... transformer))) ((name ) #''(... (... transformer))) (x (transformer #'x))))) - (identifier? #'name)) - ;(syntax-violation 'def-syntax "Invalid name" #'name)) + (identifier? #'name) + (syntax-violation 'def-syntax "Invalid name" #'name)) - (sub (def-syntax name (extends parent) (literal ...) clause ...) - #'(def-syntax name - (syntax-match (literal ...) - clause ... - (sub x ((parent ) #'x))))) )) ) diff --git a/scheme/sweet-macros/main.sls b/scheme/sweet-macros/main.sls index 946daf0..d1b4775 100644 --- a/scheme/sweet-macros/main.sls +++ b/scheme/sweet-macros/main.sls @@ -21,39 +21,41 @@ )))))) (lambda (x) (syntax-case x () - ((guarded-syntax-case () (literal ...) clause ...) - #'(lambda (y) (guarded-syntax-case y (literal ...) clause ...))) ((guarded-syntax-case y (literal ...) clause ...) - (with-syntax - (((c ...) (fold-right add-clause '() #'(clause ...)))) - #'(syntax-case y (literal ...) c ...))) - )))) + (with-syntax (((c ...) (fold-right add-clause '() #'(clause ...)))) + #'(syntax-case y (literal ...) c ...))))))) ;;END ;;SYNTAX-MATCH (define-syntax syntax-match - (guarded-syntax-case () (sub) - - ((self (literal ...) (sub patt skel rest ...) ...) - #'(guarded-syntax-case () - ( literal ...) - ((ctx ) #''(literal ...)) - ((ctx ) #''((... (... patt)) ...)) - (patt skel rest ...) - ...) - (for-all identifier? #'(literal ...)) - (syntax-violation 'syntax-match "Found non identifier" #'(literal ...) - (remp identifier? #'(literal ...)))) - - ((self x (literal ...) (sub patt skel rest ...) ...) - #'(guarded-syntax-case x (literal ...) (patt skel rest ...) ...)) - )) + (lambda (y) + (guarded-syntax-case y (sub) + + ((self (literal ...) (sub patt skel rest ...) ...) + #'(lambda (x) (self x (literal ...) (sub patt skel rest ...) ...))) + + ((self x (literal ...) (sub patt skel rest ...) ...) + #'(guarded-syntax-case x ( literal ...) + ((ctx ) #''(literal ...)) + ((ctx ) #''((... (... patt)) ...)) + (patt skel rest ...) + ...) + (for-all identifier? #'(literal ...)) + (syntax-violation 'syntax-match "Found non identifier" #'(literal ...) + (remp identifier? #'(literal ...)))) + ))) ;;END ;; DEF-SYNTAX (define-syntax def-syntax (syntax-match (extends) + (sub (def-syntax name (extends parent) (literal ...) clause ...) + #'(def-syntax name + (syntax-match (literal ...) + clause ... + (sub x ((parent ) #'x))))) + (sub (def-syntax (name . args) skel rest ...) #'(def-syntax name (syntax-match () (sub (name . args) skel rest ...)))) @@ -64,14 +66,9 @@ ((name ) #'(... (... transformer))) ((name ) #''(... (... transformer))) (x (transformer #'x))))) - (identifier? #'name)) - ;(syntax-violation 'def-syntax "Invalid name" #'name)) + (identifier? #'name) + (syntax-violation 'def-syntax "Invalid name" #'name)) - (sub (def-syntax name (extends parent) (literal ...) clause ...) - #'(def-syntax name - (syntax-match (literal ...) - clause ... - (sub x ((parent ) #'x))))) )) ;;END -- cgit v1.2.1