Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Implement with-ellipsis

Browse source
This commit is contained in:
Marc Nieper-Wißkirchen 2018-12-09 19:05:22 +01:00
parent 2c37dfedd3
commit 5d978dd37b
3 changed files with 35 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
lib/chibi/syntax-case-test.sld
View file

@ -47,4 +47,10 @@
(syntax-case '((a b c) (d e f)) () (syntax-case '((a b c) (d e f)) ()
(((x ... y) ...) #'((x ...) ... y ...)))) (((x ... y) ...) #'((x ...) ... y ...))))
(test "with-ellipsis"
'((a b))
(with-ellipsis :::
(syntax-case '(a) ()
((... :::) #'((... b) :::)))))
(test-end)))) (test-end))))

33
lib/chibi/syntax-case.scm
View file

@ -29,8 +29,15 @@
(define (rename id) (define (rename id)
((current-renamer) id)) ((current-renamer) id))
(define (ellipsis? id) (define current-ellipsis-id
(free-identifier=? id (rename '...))) (make-syntactic-closure (current-environment) '() 'current-ellipsis))
(define (ellipsis-identifier? id)
(let* ((cell (env-cell (current-usage-environment) current-ellipsis-id))
(ellipsis (if cell
(macro-aux (cdr cell))
(rename '...))))
(free-identifier=? id ellipsis)))
(define bound-identifier=? (define bound-identifier=?
(lambda (x y) (lambda (x y)
@ -40,7 +47,7 @@
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(let*-values (((out envs) (let*-values (((out envs)
(gen-template (cadr expr) '() ellipsis? level))) (gen-template (cadr expr) '() ellipsis-identifier? level)))
out)))) out))))
(define (syntax->datum stx) (define (syntax->datum stx)
@ -183,7 +190,7 @@
(cond (cond
((and (pair? (cdr pattern)) ((and (pair? (cdr pattern))
(identifier? (cadr pattern)) (identifier? (cadr pattern))
(ellipsis? (cadr pattern))) (ellipsis-identifier? (cadr pattern)))
(let* ((l (length+ (cddr pattern))) (let* ((l (length+ (cddr pattern)))
(h (car (generate-temporaries '(#f)))) (h (car (generate-temporaries '(#f))))
(t (car (generate-temporaries '(#f))))) (t (car (generate-temporaries '(#f)))))
@ -219,7 +226,7 @@
#,(k) #,(k)
(fail))) (fail)))
vars)) vars))
((ellipsis? pattern) ((ellipsis-identifier? pattern)
(error "misplaced ellipsis" pattern)) (error "misplaced ellipsis" pattern))
((free-identifier=? pattern #'_) ((free-identifier=? pattern #'_)
(values (lambda (k) (values (lambda (k)
@ -297,5 +304,19 @@
(define (syntax-violation who message . form*) (define (syntax-violation who message . form*)
(apply error message form*)) (apply error message form*))
(define-syntax define-current-ellipsis
(lambda (stx)
(syntax-case stx ()
((_ ellipsis)
(let ((mac (cdr (env-cell (current-usage-environment) current-ellipsis-id))))
(macro-aux-set! mac #'ellipsis))
#'(begin)))))
;; TODO: Move datum->syntax from init-7 here. (define-syntax with-ellipsis
(lambda (stx)
(syntax-case stx ()
((_ ellipsis . body)
(with-syntax ((current-ellipsis current-ellipsis-id))
#'(let-syntax ((current-ellipsis (syntax-rules ())))
(define-current-ellipsis ellipsis)
. body))))))

3
lib/chibi/syntax-case.sld
View file

@ -2,7 +2,8 @@
(export ... _ free-identifier=? bound-identifier=? identifier? (export ... _ free-identifier=? bound-identifier=? identifier?
syntax-case syntax quasisyntax unsyntax unsyntax-splicing syntax-case syntax quasisyntax unsyntax unsyntax-splicing
datum->syntax syntax->datum datum->syntax syntax->datum
generate-temporaries with-syntax syntax-violation) generate-temporaries with-syntax syntax-violation
with-ellipsis)
(import (chibi) (import (chibi)
(chibi ast) (chibi ast)
(meta) (meta)