mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-21 14:49:18 +02:00
adding (... ...) escapes and SRFI-46 ellipse specifiers to syntax-rules
This commit is contained in:
Alex Shinn
parent
fea2428eb6
commit
05ee7c6725
3 changed files with 61 additions and 31 deletions
28
TODO
28
TODO
|
|
@ -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
58
lib/init.scm
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -459,6 +459,12 @@
|
|||
(c 'talk2)
|
||||
(reverse path)))))
|
||||
|
||||
(test 2 (let-syntax
|
||||
((foo (syntax-rules ::: ()
|
||||
((foo ... args :::)
|
||||
(args ::: ...)))))
|
||||
(foo 3 - 5)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(test-report)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue