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

stripping syntactic-closures from record descriptive names

Browse source
This commit is contained in:
Alex Shinn 2010-02-25 23:55:38 +09:00
parent 819fbd2c99
commit 445f5f5f31
1 changed files with 9 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
lib/srfi/9.module
View file

@ -7,12 +7,13 @@
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(let* ((name (cadr expr)) (let* ((name (cadr expr))
(name-str (symbol->string (identifier->symbol name)))
(make (caaddr expr)) (make (caaddr expr))
(make-fields (cdaddr expr)) (make-fields (cdaddr expr))
(pred (cadddr expr)) (pred (cadddr expr))
(fields (cddddr expr)) (fields (cddddr expr))
(num-fields (length fields)) (num-fields (length fields))
(index (register-simple-type (symbol->string name) num-fields)) (index (register-simple-type name-str num-fields))
(_define (rename 'define)) (_define (rename 'define))
(_lambda (rename 'lambda)) (_lambda (rename 'lambda))
(_let (rename 'let))) (_let (rename 'let)))
@ -21,7 +22,7 @@
(if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1)))))
`(,(rename 'begin) `(,(rename 'begin)
(,_define ,pred (,(rename 'make-type-predicate) (,_define ,pred (,(rename 'make-type-predicate)
,(symbol->string pred) ,(symbol->string (identifier->symbol pred))
,index)) ,index))
,@(let lp ((ls fields) (i 0) (res '())) ,@(let lp ((ls fields) (i 0) (res '()))
(if (null? ls) (if (null? ls)
@ -29,7 +30,8 @@
(let ((res (let ((res
(cons `(,_define ,(cadar ls) (cons `(,_define ,(cadar ls)
(,(rename 'make-getter) (,(rename 'make-getter)
,(symbol->string (cadar ls)) ,(symbol->string
(identifier->symbol (cadar ls)))
,index ,index
,i)) ,i))
res))) res)))
@ -39,7 +41,8 @@
(cons (cons
`(,_define ,(caddar ls) `(,_define ,(caddar ls)
(,(rename 'make-setter) (,(rename 'make-setter)
,(symbol->string (caddar ls)) ,(symbol->string
(identifier->symbol (caddar ls)))
,index ,index
,i)) ,i))
res) res)
@ -49,7 +52,7 @@
(cond (cond
((null? ls) ((null? ls)
`(,_let ((%make (,(rename 'make-constructor) `(,_let ((%make (,(rename 'make-constructor)
,(symbol->string make) ,(symbol->string (identifier->symbol make))
,index)) ,index))
,@set-defs) ,@set-defs)
(,_lambda ,make-fields (,_lambda ,make-fields
@ -67,7 +70,7 @@
set-defs)) set-defs))
(else (else
(let* ((setter-name (let* ((setter-name
(string-append "%" (symbol->string name) "-" (string-append "%" name-str "-"
(symbol->string (car ls)) "-set!")) (symbol->string (car ls)) "-set!"))
(setter (rename (string->symbol setter-name))) (setter (rename (string->symbol setter-name)))
(i (index-of (car ls) fields))) (i (index-of (car ls) fields)))