conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* faster syntax-match implementation.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-08 05:10:37 -04:00
parent 65dbda85fc
commit 1355665e55
2 changed files with 109 additions and 185 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

252
src/ikarus.syntax.ss
View File

@ -6,10 +6,12 @@
(import (import
(ikarus library-manager) (ikarus library-manager)
(only (ikarus compiler) eval-core) (only (ikarus compiler) eval-core)
(rename (except (ikarus) boot-library-expand syntax-error (rename (except (ikarus) boot-library-expand
eval-top-level installed-libraries) eval-top-level installed-libraries)
(free-identifier=? sys:free-identifier=?) (free-identifier=? sys:free-identifier=?)
(identifier? sys:identifier?) (identifier? sys:identifier?)
(syntax-error sys:syntax-error)
;(syntax->datum sys:syntax->datum)
(generate-temporaries sys:generate-temporaries))) (generate-temporaries sys:generate-temporaries)))
(define who 'expander) (define who 'expander)
@ -410,8 +412,7 @@
(define make-eval-transformer (define make-eval-transformer
(lambda (x) (lambda (x)
(sanitize-binding (eval-core x) x))) (sanitize-binding (eval-core x) x)))
(module (syntax-match) (define-syntax syntax-match
(define-syntax syntax-match-test
(lambda (ctx) (lambda (ctx)
(define dots? (define dots?
(lambda (x) (lambda (x)
@ -420,188 +421,111 @@
(define free-identifier-member? (define free-identifier-member?
(lambda (x ls) (lambda (x ls)
(and (ormap (lambda (y) (sys:free-identifier=? x y)) ls) #t))) (and (ormap (lambda (y) (sys:free-identifier=? x y)) ls) #t)))
(define f (define (parse-clause lits cls)
(lambda (ctx lits) (define (parse-pat pat)
(syntax-case ctx () (syntax-case pat ()
[id (sys:identifier? #'id) [id (sys:identifier? #'id)
(if (free-identifier-member? #'id lits) (if (free-identifier-member? #'id lits)
#'(lambda (x) (and (id? x) (free-id=? x (scheme-stx 'id)))) (values '()
#'(lambda (x) #t))] #'(lambda (x)
(if (and (id? x) (free-id=? x (scheme-stx 'id)))
'()
#f)))
(values (list #'id)
#'(lambda (x) (list x))))]
[(pat dots) (dots? #'dots) [(pat dots) (dots? #'dots)
(with-syntax ([p (f #'pat lits)]) (let-values ([(pvars decon) (parse-pat #'pat)])
#'(lambda (x) (with-syntax ([(v* ...) pvars] [decon decon])
(and (syntax-list? x) (values pvars
(andmap p (syntax->list x)))))] #'(letrec ([f (lambda (x)
[(pat dots . last) (dots? #'dots)
(with-syntax ([p (f #'pat lits)] [l (f #'last lits)])
#'(lambda (x)
(let loop ([x x])
(cond (cond
[(syntax-pair? x) [(syntax-pair? x)
(and (p (syntax-car x)) (let ([cars/f (decon (syntax-car x))])
(loop (syntax-cdr x)))] (and cars/f
[else (l x)]))))] (let ([cdrs/f (f (syntax-cdr x))])
[(a . d) (and cdrs/f
(with-syntax ([pa (f #'a lits)] [pd (f #'d lits)]) (map cons cars/f cdrs/f)))))]
[(syntax-null? x)
(list (begin 'v* '()) ...)]
[else #f]))])
f))))]
[(pat dots . last) (dots? #'dots)
(let-values ([(p1 d1) (parse-pat #'pat)]
[(p2 d2) (parse-pat #'last)])
(with-syntax ([(v* ...) (append p1 p2)]
[(v1* ...) p1]
[(v2* ...) p2]
[d1 d1] [d2 d2])
(values (append p1 p2)
#'(letrec ([f (lambda (x)
(cond
[(syntax-pair? x)
(let ([cars/f (d1 (syntax-car x))])
(and cars/f
(let ([d/f (f (syntax-cdr x))])
(and d/f
(cons (map cons cars/f (car d/f))
(cdr d/f))))))]
[else
(let ([d (d2 x)])
(and d
(cons (list (begin 'v1* '()) ...)
d)))]))])
(lambda (x)
(let ([x (f x)])
(and x (append (car x) (cdr x)))))))))]
[(pat1 . pat2)
(let-values ([(p1 d1) (parse-pat #'pat1)]
[(p2 d2) (parse-pat #'pat2)])
(with-syntax ([d1 d1] [d2 d2])
(values (append p1 p2)
#'(lambda (x) #'(lambda (x)
(and (syntax-pair? x) (and (syntax-pair? x)
(pa (syntax-car x)) (let ([q (d1 (syntax-car x))])
(pd (syntax-cdr x)))))] (and q
(let ([r (d2 (syntax-cdr x))])
(and r (append q r))))))))))]
[#(pats ...) [#(pats ...)
(with-syntax ([p (f #'(pats ...) lits)]) (let-values ([(pvars d) (parse-pat #'(pats ...))])
(with-syntax ([d d])
(values pvars
#'(lambda (x) #'(lambda (x)
(and (syntax-vector? x) (and (syntax-vector? x)
(p (syntax-vector->list x)))))] (d (syntax-vector->list x)))))))]
[datum [datum
(values '()
#'(lambda (x) #'(lambda (x)
(equal? (strip x '()) 'datum))]))) (and (equal? (strip x '()) 'datum) '())))]))
(syntax-case cls ()
[(pat body)
(let-values ([(pvars decon) (parse-pat #'pat)])
(with-syntax ([(v* ...) pvars])
(values decon
#'(lambda (v* ...) #t)
#'(lambda (v* ...) body))))]))
(syntax-case ctx () (syntax-case ctx ()
[(_ x (lits ...) [pat code]) [(_ expr (lits ...)) (andmap sys:identifier? #'(lits ...))
(with-syntax ([pat-code (f #'pat #'(lits ...))]) #'(stx-error expr "invalid syntax")]
#'(pat-code x))]))) [(_ expr (lits ...) cls cls* ...) (andmap sys:identifier? #'(lits ...))
(define-syntax syntax-match-conseq (let-values ([(decon guard body)
(lambda (ctx) (parse-clause #'(lits ...) #'cls)])
(define free-identifier-member? (with-syntax ([decon decon]
(lambda (x ls) [guard guard]
(and (ormap (lambda (y) (sys:free-identifier=? x y)) ls) #t))) [body body])
(define dots?
(lambda (x)
(and (sys:identifier? x)
(sys:free-identifier=? x #'(... ...)))))
(define f
(lambda (stx lits)
(syntax-case stx ()
[id (sys:identifier? #'id)
(if (free-identifier-member? #'id lits)
(values '() #'(lambda (x) (dont-call-me)))
(values (list #'id) #'(lambda (x) x)))]
[(pat dots) (dots? #'dots)
(let-values ([(vars extractor) (f #'pat lits)])
(cond
[(null? vars)
(values '() #'(lambda (x) (dont-call-me)))]
[else
(values vars
(with-syntax ([(vars ...) vars]
[ext extractor]
[(t* ...) (sys:generate-temporaries vars)])
#'(lambda (x)
(let f ([x x] [vars '()] ...)
(cond
[(syntax-null? x)
(values (reverse vars) ...)]
[else
(let-values ([(t* ...) (ext (syntax-car x))])
(f (syntax-cdr x)
(cons t* vars)
...))])))))]))]
[(pat dots . last) (dots? #'dots)
(let-values ([(pvars pext) (f #'pat lits)])
(let-values ([(lvars lext) (f #'last lits)])
(cond
[(and (null? pvars) (null? lvars))
(values '() #'(lambda (x) (dont-call-me)))]
[(null? lvars)
(values pvars
(with-syntax ([(pvars ...) pvars]
[(t* ...) (sys:generate-temporaries pvars)]
[pext pext])
#'(lambda (x)
(let loop ([x x] [pvars '()] ...)
(cond
[(syntax-pair? x)
(let-values ([(t* ...) (pext (syntax-car x))])
(loop (syntax-cdr x)
(cons t* pvars) ...))]
[else
(values (reverse pvars) ...)])))))]
[(null? pvars)
(values lvars
(with-syntax ([lext lext])
#'(let loop ([x x])
(cond
[(syntax-pair? x) (loop (syntax-cdr x))]
[else (lext x)]))))]
[else
(values (append pvars lvars)
(with-syntax ([(pvars ...) pvars]
[(t* ...) (sys:generate-temporaries pvars)]
[(lvars ...) lvars]
[lext lext]
[pext pext])
#'(lambda (x)
(let loop ([x x] [pvars '()] ...)
(cond
[(syntax-pair? x)
(let-values ([(t* ...) (pext (syntax-car x))])
(loop (syntax-cdr x)
(cons t* pvars) ...))]
[else
(let-values ([(lvars ...) (lext x)])
(values (reverse pvars) ...
lvars ...))])))))])))]
[(a . d)
(let-values ([(avars aextractor) (f #'a lits)])
(let-values ([(dvars dextractor) (f #'d lits)])
(cond
[(and (null? avars) (null? dvars))
(values '() #'(lambda (x) (dot-call-me)))]
[(null? avars)
(values dvars
(with-syntax ([d dextractor])
#'(lambda (x) (d (syntax-cdr x)))))]
[(null? dvars)
(values avars
(with-syntax ([a aextractor])
#'(lambda (x) (a (syntax-car x)))))]
[else
(values (append avars dvars)
(with-syntax ([(avars ...) avars]
[(dvars ...) dvars]
[a aextractor]
[d dextractor])
#'(lambda (x)
(let-values ([(avars ...) (a (syntax-car x))])
(let-values ([(dvars ...) (d (syntax-cdr x))])
(values avars ... dvars ...))))))])))]
[#(pats ...)
(let-values ([(vars extractor) (f #'(pats ...) lits)])
(cond
[(null? vars) (values '() #f)]
[else
(values vars
(with-syntax ([extractor extractor])
#'(lambda (x)
(extractor (syntax-vector->list x)))))]))]
[datum
(values '() #'(lambda (x) (dot-call-me)))])))
(syntax-case ctx ()
[(_ x (lits ...) [pat code code* ...])
(let-values ([(vars extractor)
(f #'pat #'(lits ...))])
(with-syntax ([e extractor] [(vs ...) vars])
(case (length vars)
[(0) #'(begin #f code)]
[(1) #'(let ([vs ... (e x)]) #f code)]
[else #'(let-values ([(vs ...) (e x)]) #f code)])))])))
(define-syntax syntax-match
(lambda (x)
(syntax-case x ()
[(_ expr (lits ...)) #'(stx-error expr)]
[(_ expr (lits ...) cls cls* ...)
#'(let ([t expr]) #'(let ([t expr])
(if (syntax-match-test t (lits ...) cls) (let ([ls/false (decon t)])
(syntax-match-conseq t (lits ...) cls) (if (and ls/false (apply guard ls/false))
(syntax-match t (lits ...) cls* ...)))])))) (apply body ls/false)
(syntax-match t (lits ...) cls* ...))))))])))
(define parse-define (define parse-define
(lambda (x) (lambda (x)
(syntax-match x () (syntax-match x ()
[(_ (id . fmls) b b* ...) [(__ (id . fmls) b b* ...)
(if (id? id) (if (id? id)
(values id (values id
(cons 'defun (cons fmls (cons b b*)))) (cons 'defun (cons fmls (cons b b*))))
(stx-error x))] (stx-error x))]
[(_ id val) [(__ id val)
(if (id? id) (if (id? id)
(values id (cons 'expr val)) (values id (cons 'expr val))
(stx-error x))]))) (stx-error x))])))