suzanne.soy/aful
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

use more macro-like approach to hygiene

Browse Source
This commit is contained in:
AlexKnauth 2015-04-16 22:42:25 -04:00
parent 5e7c99f10a
commit d0029ed1f5
1 changed files with 17 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
afl/reader.rkt
View File

@ -79,11 +79,11 @@
(module+ test (module+ test
(check-equal? (afl-read (open-input-string "#λ(+ % %2)")) (check-equal? (afl-read (open-input-string "#λ(+ % %2)"))
'(lambda (%1 %2) '(lambda (%1 %2)
(define-syntax % (#%app make-rename-transformer #'%1)) (define-syntax % (make-rename-transformer #'%1))
(+ % %2))) (+ % %2)))
(check-equal? (afl-read (open-input-string "#λ(+ _ _2)") #:arg-str "_") (check-equal? (afl-read (open-input-string "#λ(+ _ _2)") #:arg-str "_")
'(lambda (_1 _2) '(lambda (_1 _2)
(define-syntax _ (#%app make-rename-transformer #'_1)) (define-syntax _ (make-rename-transformer #'_1))
(+ _ _2))) (+ _ _2)))
) )
@ -114,42 +114,40 @@
(parameterize ([current-arg-string arg-str]) (parameterize ([current-arg-string arg-str])
(define (string->id stx . strs) (define (string->id stx . strs)
(datum->syntax stx (string->symbol (apply string-append strs)) stx)) (datum->syntax stx (string->symbol (apply string-append strs)) stx))
(with-syntax ([lambda ((make-syntax-introducer) #'lambda)] (define intro (make-syntax-introducer))
[define-syntax ((make-syntax-introducer) #'define-syntax)] (define stx* (intro stx))
[app ((make-syntax-introducer) #'#%app)] (with-syntax ([args (parse-args stx* #:arg-str arg-str)]
[make-rename-transformer ((make-syntax-introducer) #'make-rename-transformer)] [% (string->id stx* arg-str)]
[syntax2 ((make-syntax-introducer) #'syntax)] [%1 (string->id stx* arg-str "1")]
[args (parse-args stx #:arg-str arg-str)] [body stx*])
[% (string->id #'args arg-str)] (intro
[%1 (string->id #'args arg-str "1")] #'(lambda args
[body stx]) (define-syntax % (make-rename-transformer #'%1))
#'(lambda args body)))))
(define-syntax % (app make-rename-transformer (syntax2 %1)))
body))))
(module+ test (module+ test
;; These test `parse`. See test.rkt for tests of readtable use per se. ;; These test `parse`. See test.rkt for tests of readtable use per se.
(define chk (compose1 syntax->datum parse)) (define chk (compose1 syntax->datum parse))
(check-equal? (chk #'(+)) (check-equal? (chk #'(+))
'(lambda () '(lambda ()
(define-syntax % (#%app make-rename-transformer #'%1)) (define-syntax % (make-rename-transformer #'%1))
(+))) (+)))
(check-equal? (chk #'(+ 2 %1 %1)) (check-equal? (chk #'(+ 2 %1 %1))
'(lambda (%1) '(lambda (%1)
(define-syntax % (#%app make-rename-transformer #'%1)) (define-syntax % (make-rename-transformer #'%1))
(+ 2 %1 %1))) (+ 2 %1 %1)))
(check-equal? (chk #'(+ 2 %3 %2 %1)) (check-equal? (chk #'(+ 2 %3 %2 %1))
'(lambda (%1 %2 %3) '(lambda (%1 %2 %3)
(define-syntax % (#%app make-rename-transformer #'%1)) (define-syntax % (make-rename-transformer #'%1))
(+ 2 %3 %2 %1))) (+ 2 %3 %2 %1)))
(check-equal? (chk #'(apply list* % %&)) (check-equal? (chk #'(apply list* % %&))
'(lambda (%1 . %&) '(lambda (%1 . %&)
(define-syntax % (#%app make-rename-transformer #'%1)) (define-syntax % (make-rename-transformer #'%1))
(apply list* % %&))) (apply list* % %&)))
(check-equal? (parameterize ([current-arg-string "_"]) (check-equal? (parameterize ([current-arg-string "_"])
(chk #'(apply list* _ _&))) (chk #'(apply list* _ _&)))
'(lambda (_1 . _&) '(lambda (_1 . _&)
(define-syntax _ (#%app make-rename-transformer #'_1)) (define-syntax _ (make-rename-transformer #'_1))
(apply list* _ _&)))) (apply list* _ _&))))
;; parse-args : Stx -> KW-Formals-Stx ;; parse-args : Stx -> KW-Formals-Stx