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

adding (... ...) escapes and SRFI-46 ellipse specifiers to syntax-rules

Browse source
This commit is contained in:
Alex Shinn 2009-12-26 02:07:18 +09:00
parent fea2428eb6
commit 05ee7c6725
3 changed files with 61 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
TODO
View file

@ -39,9 +39,10 @@
- State "DONE" [2009-12-08 Tue 14:41]
** DONE macroexpand utility
- State "DONE" [2009-12-08 Tue 14:41]
** TODO compiler macros
** TODO SRFI-46 basic syntax-rules extensions
** TODO (... ...) support
** DONE (... ...) support
- State "DONE" [2009-12-26 Sat 02:06]
** TODO compiler macros
** TODO syntax-rules common pattern reduction
** TODO syntax-rules loop optimization
@ -61,6 +62,9 @@
- State "DONE" [2009-07-07 Tue 14:42]
** TODO unicode
** TODO threads
** DONE dynamic-wind
- State "DONE" [2009-12-26 Sat 01:51]
Adapted a version from Scheme48.
** DONE recursive disasm
- State "DONE" [2009-12-18 Fri 14:15]
@ -69,13 +73,16 @@
- State "DONE" [2009-12-08 Tue 14:45]
** DONE opcode generation interface
- State "DONE" [2009-11-15 Sun 14:45]
** TODO stub generator
** DONE stub generator
- State "DONE" [2009-12-26 Sat 01:50]
*** DONE define-c-struct
- State "DONE" [2009-11-29 Sun 14:48]
*** DONE define-c
- State "DONE" [2009-11-29 Sun 14:48]
*** TODO array return types
*** TODO pre-buffered string types (like getcwd)
*** DONE array return types
- State "DONE" [2009-12-26 Sat 01:49]
*** DONE pre-buffered string types (like getcwd)
- State "DONE" [2009-12-26 Sat 01:49]
* module system
** DONE scheme48-like config language
@ -85,7 +92,8 @@
** DONE only/except/rename/prefix modifiers
- State "DONE" [2009-12-16 Wed 18:57]
** TODO scheme-complete.el support
** TODO access individual modules from repl
** DONE access individual modules from repl
- State "DONE" [2009-12-26 Sat 01:49]
* core modules
** DONE SRFI-0 cond-expand
@ -100,6 +108,14 @@
- State "DONE" [2009-12-08 Tue 14:54]
** TODO network interface
** TODO posix interface
Splitting this into several parts.
*** DONE filesystem interface
- State "DONE" [2009-12-26 Sat 01:50]
*** DONE process interface
- State "DONE" [2009-12-26 Sat 01:50]
*** DONE time interface
- State "DONE" [2009-12-26 Sat 01:50]
*** TODO host system interface
** DONE pathname library
- State "DONE" [2009-12-16 Wed 18:58]
** DONE uri library

58
lib/init.scm
View file

@ -615,8 +615,7 @@
(define-syntax syntax-rules
(er-macro-transformer
(lambda (expr rename compare)
(let ((lits (cadr expr))
(forms (cddr expr))
(let ((ellipse-specified? (identifier? (cadr expr)))
(count 0)
(_er-macro-transformer (rename 'er-macro-transformer))
(_lambda (rename 'lambda)) (_let (rename 'let))
@ -634,6 +633,9 @@
(_error (rename 'error))
(_vector->list (rename 'vector->list))
(_list->vector (rename 'list->vector)))
(define ellipse (rename (if ellipse-specified? (cadr expr) '...)))
(define lits (if ellipse-specified? (caddr expr) (cadr expr)))
(define forms (if ellipse-specified? (cdddr expr) (cddr expr)))
(define (next-v)
(set! count (+ count 1))
(rename (string->symbol (string-append "v." (number->string count)))))
@ -708,8 +710,9 @@
(lp (vector->list p) (list _vector->list v) dim vars k)))
((null? p) (list _and (list _null? v) (k vars)))
(else (list _and (list _equal? v p) (k vars))))))))
(define (ellipse-escape? x) (and (pair? x) (compare ellipse (car x))))
(define (ellipse? x)
(and (pair? x) (pair? (cdr x)) (compare (rename '...) (cadr x))))
(and (pair? x) (pair? (cdr x)) (compare ellipse (cadr x))))
(define (ellipse-depth x)
(if (ellipse? x)
(+ 1 (ellipse-depth (cdr x)))
@ -753,28 +756,33 @@
(else
(list _rename (list _quote t)))))
((pair? t)
(if (ellipse? t)
(let* ((depth (ellipse-depth t))
(ell-dim (+ dim depth))
(ell-vars (free-vars (car t) vars ell-dim)))
(if (null? ell-vars)
(error "too many ...'s")
(let* ((once (lp (car t) ell-dim))
(nest (if (and (null? (cdr ell-vars))
(identifier? once)
(eq? once (car vars)))
once ;; shortcut
(cons _map
(cons (list _lambda ell-vars once)
ell-vars))))
(many (do ((d depth (- d 1))
(many nest
(list _apply _append many)))
((= d 1) many))))
(if (null? (ellipse-tail t))
many ;; shortcut
(list _append many (lp (ellipse-tail t) dim))))))
(list _cons (lp (car t) dim) (lp (cdr t) dim))))
(cond
((ellipse-escape? t)
(if (pair? (cdr t))
(if (pair? (cddr t)) (cddr t) (cadr t))
(cdr t)))
((ellipse? t)
(let* ((depth (ellipse-depth t))
(ell-dim (+ dim depth))
(ell-vars (free-vars (car t) vars ell-dim)))
(if (null? ell-vars)
(error "too many ...'s")
(let* ((once (lp (car t) ell-dim))
(nest (if (and (null? (cdr ell-vars))
(identifier? once)
(eq? once (car vars)))
once ;; shortcut
(cons _map
(cons (list _lambda ell-vars once)
ell-vars))))
(many (do ((d depth (- d 1))
(many nest
(list _apply _append many)))
((= d 1) many))))
(if (null? (ellipse-tail t))
many ;; shortcut
(list _append many (lp (ellipse-tail t) dim)))))))
(else (list _cons (lp (car t) dim) (lp (cdr t) dim)))))
((vector? t) (list _list->vector (lp (vector->list t) dim)))
((null? t) (list _quote '()))
(else t))))

6
tests/r5rs-tests.scm
View file

@ -459,6 +459,12 @@
(c 'talk2)
(reverse path)))))
(test 2 (let-syntax
((foo (syntax-rules ::: ()
((foo ... args :::)
(args ::: ...)))))
(foo 3 - 5)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(test-report)