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

better source preservation from syntax-rules on restructured ellipsis patterns

Browse source
This commit is contained in:
Alex Shinn 2012-06-24 15:04:49 -07:00
parent 5013c0fdcb
commit 38144adfc5
1 changed files with 37 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

59
lib/init-7.scm
View file

@ -1,5 +1,5 @@
;; init.scm -- R5RS library procedures ;; init-7.scm -- core library procedures for R7RS
;; Copyright (c) 2009-2011 Alex Shinn. All rights reserved. ;; Copyright (c) 2009-2012 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt ;; BSD-style license: http://synthcode.com/license.txt
(define (caar x) (car (car x))) (define (caar x) (car (car x)))
@ -7,6 +7,13 @@
(define (cdar x) (cdr (car x))) (define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x))) (define (cddr x) (cdr (cdr x)))
(define (cons-source kar kdr source)
((lambda (pair)
(if (pair? source)
(pair-source-set! pair (pair-source source)))
pair)
(cons kar kdr)))
;; basic utils ;; basic utils
(define (procedure? x) (if (closure? x) #t (opcode? x))) (define (procedure? x) (if (closure? x) #t (opcode? x)))
@ -612,7 +619,8 @@
(_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i)) (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i))
(_reverse (rename 'reverse)) (_reverse (rename 'reverse))
(_vector->list (rename 'vector->list)) (_vector->list (rename 'vector->list))
(_list->vector (rename 'list->vector))) (_list->vector (rename 'list->vector))
(_cons3 (rename 'cons-source)))
(define ellipsis (rename (if ellipsis-specified? (cadr expr) '...))) (define ellipsis (rename (if ellipsis-specified? (cadr expr) '...)))
(define lits (if ellipsis-specified? (car (cddr expr)) (cadr expr))) (define lits (if ellipsis-specified? (car (cddr expr)) (cadr expr)))
(define forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr))) (define forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr)))
@ -662,7 +670,9 @@
k) k)
(,_lp (,_cdr ,_ls) (,_lp (,_cdr ,_ls)
(,_- ,_i 1) (,_- ,_i 1)
(,_cons (,_car ,_ls) ,_res)))))))))) (,_cons3 (,_car ,_ls)
,_res
,_ls))))))))))
((identifier? (car p)) ((identifier? (car p))
(list _and (list _list? v) (list _and (list _list? v)
(list _let (list (list (car p) v)) (list _let (list (list (car p) v))
@ -770,24 +780,29 @@
(let* ((depth (ellipsis-depth t)) (let* ((depth (ellipsis-depth t))
(ell-dim (+ dim depth)) (ell-dim (+ dim depth))
(ell-vars (free-vars (car t) vars ell-dim))) (ell-vars (free-vars (car t) vars ell-dim)))
(if (null? ell-vars) (cond
(error "too many ...'s") ((null? ell-vars)
(let* ((once (lp (car t) ell-dim)) (error "too many ...'s"))
(nest (if (and (null? (cdr ell-vars)) ((and (null? (cdr (cdr t))) (identifier? (car t)))
(identifier? once) ;; shortcut for (var ...)
(eq? once (car vars))) (lp (car t) depth))
once ;; shortcut (else
(cons _map (let* ((once (lp (car t) ell-dim))
(cons (list _lambda ell-vars once) (nest (if (and (null? (cdr ell-vars))
ell-vars)))) (identifier? once)
(many (do ((d depth (- d 1)) (eq? once (car vars)))
(many nest once ;; shortcut
(list _apply _append many))) (cons _map
((= d 1) many)))) (cons (list _lambda ell-vars once)
(if (null? (ellipsis-tail t)) ell-vars))))
many ;; shortcut (many (do ((d depth (- d 1))
(list _append many (lp (ellipsis-tail t) dim))))))) (many nest
(else (list _cons (lp (car t) dim) (lp (cdr t) dim))))) (list _apply _append many)))
((= d 1) many))))
(if (null? (ellipsis-tail t))
many ;; shortcut
(list _append many (lp (ellipsis-tail t) dim))))))))
(else (list _cons3 (lp (car t) dim) (lp (cdr t) dim) (list _quote t)))))
((vector? t) (list _list->vector (lp (vector->list t) dim))) ((vector? t) (list _list->vector (lp (vector->list t) dim)))
((null? t) (list _quote '())) ((null? t) (list _quote '()))
(else t)))) (else t))))