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

Revert "use uninterned symbols instead of syntax-marks"

Browse Source 
This reverts commit dea60a15ca.
This commit is contained in:
AlexKnauth 2015-07-18 18:14:58 -04:00
parent d460c678ac
commit 4551bf4261
2 changed files with 43 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
afl/reader.rkt
View File

@ -16,33 +16,33 @@
racket/port racket/port
racket/list racket/list
syntax/srcloc syntax/srcloc
(for-syntax racket/base (for-meta -10 racket/base)
racket/list (for-meta -9 racket/base)
)) (for-meta -8 racket/base)
(for-meta -7 racket/base)
(for-meta -6 racket/base)
(for-meta -5 racket/base)
(for-meta -4 racket/base)
(for-meta -3 racket/base)
(for-meta -2 racket/base)
(for-meta -1 racket/base)
(for-meta 0 racket/base)
(for-meta 1 racket/base)
(for-meta 2 racket/base)
(for-meta 3 racket/base)
(for-meta 4 racket/base)
(for-meta 5 racket/base)
(for-meta 6 racket/base)
(for-meta 7 racket/base)
(for-meta 8 racket/base)
(for-meta 9 racket/base)
(for-meta 10 racket/base)
(for-meta 11 (only-in racket/base #%app make-rename-transformer syntax))
)
(module+ test (module+ test
(require rackunit)) (require rackunit))
(define-syntax (define-unbindable-ids stx)
(syntax-case stx ()
[(_ [name id] ...)
(with-syntax ([(gen-id ...)
(for/list ([id (in-list (syntax->list #'(id ...)))])
(string->uninterned-symbol (symbol->string (syntax-e id))))]
[(n ...) (range -10 11)])
#`(begin
(require (for-meta n (only-in racket/base [id gen-id] ...))
...)
(define name (quote-syntax gen-id))
...))]))
(define-unbindable-ids
[lambda-id lambda]
[define-syntax-id define-syntax]
[app-id #%app]
[make-rename-transformer-id make-rename-transformer]
[syntax-id syntax])
(define (afl-read [in (current-input-port)] #:arg-str [arg-str (current-arg-string)]) (define (afl-read [in (current-input-port)] #:arg-str [arg-str (current-arg-string)])
(define orig-readtable (current-readtable)) (define orig-readtable (current-readtable))
(parameterize ([current-arg-string arg-str] (parameterize ([current-arg-string arg-str]
@ -78,15 +78,13 @@
(module+ test (module+ test
(define-check (check-thing= a b) (check-equal? (afl-read (open-input-string "#λ(+ % %2)"))
(check-equal? (format "~s" a) (format "~s" b)))
(check-thing= (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-thing= (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)))
) )
@ -127,7 +125,7 @@
(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))
(define intro (λ (x) x) #;(make-syntax-introducer)) (define intro (make-syntax-introducer))
(define stx* (intro stx)) (define stx* (intro stx))
(match-define (srcloc src ln col pos spn) (build-source-location loc)) (match-define (srcloc src ln col pos spn) (build-source-location loc))
(define stx-pos (syntax-position stx*)) (define stx-pos (syntax-position stx*))
@ -137,11 +135,7 @@
#:column (and col (+ col 1)) #:column (and col (+ col 1))
#:position (and pos (+ pos 1)) #:position (and pos (+ pos 1))
#:span (and stx-pos pos (max 0 (- stx-pos pos 1))))) #:span (and stx-pos pos (max 0 (- stx-pos pos 1)))))
(with-syntax ([lambda (orig (quasisyntax/loc λ-loc #,lambda-id))] (with-syntax ([lambda (orig (syntax/loc λ-loc lambda))]
[define-syntax define-syntax-id]
[app app-id]
[make-rename-transformer make-rename-transformer-id]
[syntax syntax-id]
[args (parse-args stx* #:arg-str arg-str)] [args (parse-args stx* #:arg-str arg-str)]
[% (string->id stx* arg-str)] [% (string->id stx* arg-str)]
[%1 (string->id stx* arg-str "1")] [%1 (string->id stx* arg-str "1")]
@ -149,7 +143,7 @@
(intro (intro
(syntax/loc loc-stx (syntax/loc loc-stx
(lambda args (lambda args
(define-syntax % (app make-rename-transformer #'%1)) (define-syntax % (make-rename-transformer #'%1))
body)))))) body))))))
(define (orig stx) (define (orig stx)
@ -158,26 +152,26 @@
(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-thing= (chk #'(+)) (check-equal? (chk #'(+))
'(lambda () '(lambda ()
(define-syntax % (#%app make-rename-transformer #'%1)) (define-syntax % (make-rename-transformer #'%1))
(+))) (+)))
(check-thing= (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-thing= (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-thing= (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-thing= (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

10
afl/tests/test-afl-racket.rkt
View File

@ -14,11 +14,7 @@
"I am x") "I am x")
(check-equal? (#λ(begin (set! % "%") %1) "%1") (check-equal? (#λ(begin (set! % "%") %1) "%1")
"%") "%")
(check-equal? (let ([lambda "not lambda"] (check-equal? (let ([lambda "not lambda"] [define-syntax "not define-syntax"])
[define-syntax "not define-syntax"] (#λ% 3))
[make-rename-transformer "not"] 3)
[syntax "not"])
(let-syntax ([#%app (syntax-rules () [(app f x) (f 4)])])
(#λ% 3)))
4)
) )