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

- Added (syntax-transpose syntax-object base-id new-id-object). 

It returns syntax-object wrapped with the marks and substitutions
  that have been added to new-id since its introduction as base-id.
  The new-id and base-id should be free-identifier=? and new-id
  should have the same (or more) marks as base-id.
This commit is contained in:
Abdulaziz Ghuloum 2008-12-25 16:33:50 -05:00
parent 788762da44
commit 2be7d93637
3 changed files with 41 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/last-revision
View File

@ -1 +1 @@
1724
1725

1
scheme/makefile.ss
View File

@ -1314,6 +1314,7 @@
[variable-transformer? i]
[variable-transformer-procedure i]
[make-compile-time-value i]
[syntax-transpose i]
[char-alphabetic? i r uc se]
[char-ci<=? i r uc se]
[char-ci<? i r uc se]

40
scheme/psyntax.expander.ss
View File

@ -32,7 +32,7 @@
interaction-environment
ellipsis-map assertion-error
environment environment? environment-symbols
new-interaction-environment)
new-interaction-environment syntax-transpose)
(import
(except (rnrs)
environment environment? identifier?
@ -2991,6 +2991,44 @@
(make-stx (stx-expr x) (append diff (stx-mark* x)) '() '()))
id-vec))))
(define (syntax-transpose object base-id new-id)
(define who 'syntax-transpose)
(define (err msg . args) (apply assertion-violation who msg args))
(define (split s*)
(cond
[(eq? (car s*) 'shift)
(values (list 'shift) (cdr s*))]
[else
(let-values ([(s1* s2*) (split (cdr s*))])
(values (cons (car s*) s1*) s2*))]))
(define (final s*)
(cond
[(or (null? s*) (eq? (car s*) 'shift)) '()]
[else (cons (car s*) (final (cdr s*)))]))
(define (diff m m* s* ae*)
(if (null? m*)
(err "unmatched identifiers" base-id new-id)
(let ([m1 (car m*)])
(if (eq? m m1)
(values '() (final s*) '())
(let-values ([(s1* s2*) (split s*)])
(let-values ([(nm* ns* nae*)
(diff m (cdr m*) s2* (cdr ae*))])
(values (cons m1 nm*)
(append s1* ns*)
(cons (car ae*) nae*))))))))
(unless (id? base-id) (err "not an identifier" base-id))
(unless (id? new-id) (err "not an identifier" new-id))
(unless (free-identifier=? base-id new-id)
(err "not the same identifier" base-id new-id))
(let-values ([(m* s* ae*)
(diff (car (stx-mark* base-id))
(stx-mark* new-id)
(stx-subst* new-id)
(stx-ae* new-id))])
(if (and (null? m*) (null? s*))
object
(mkstx object m* s* ae*))))
(define chi-internal-module
(lambda (e r mr lex* rhs* mod** kwd*)