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

nicer indentation

Browse source
This commit is contained in:
Alex Shinn 2010-09-16 00:09:54 +09:00
parent 11e552576e
commit 6c074d686a
1 changed files with 53 additions and 54 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

107
lib/srfi/99/records/syntactic.scm
View file

@ -31,9 +31,9 @@
;; predicate ;; predicate
,@(if pred-name ,@(if pred-name
`((,_define ,pred-name `((,_define ,pred-name
(,(rename 'make-type-predicate) (,(rename 'make-type-predicate)
,(id->string pred-name) ,(id->string pred-name)
,name))) ,name)))
#f) #f)
;; accessors ;; accessors
,@(map (lambda (f) ,@(map (lambda (f)
@ -44,10 +44,10 @@
(string-append name-str "-" (id->string f))))))) (string-append name-str "-" (id->string f)))))))
(and g (and g
`(,_define ,g `(,_define ,g
(,(rename 'make-getter) (,(rename 'make-getter)
,(id->string g) ,(id->string g)
,name ,name
(,_type_slot_offset ,name ',(if (pair? f) (car f) f))))))) (,_type_slot_offset ,name ',(if (pair? f) (car f) f)))))))
fields) fields)
,@(map (lambda (f) ,@(map (lambda (f)
(let ((s (if (and (pair? f) (pair? (cdr f)) (pair? (cddr f))) (let ((s (if (and (pair? f) (pair? (cdr f)) (pair? (cddr f)))
@ -57,53 +57,52 @@
(string-append name-str "-" (id->string f) "-set!")))))) (string-append name-str "-" (id->string f) "-set!"))))))
(and s (and s
`(,_define ,s `(,_define ,s
(,(rename 'make-setter) (,(rename 'make-setter)
,(id->string s) ,(id->string s)
,name ,name
(,_type_slot_offset ,name ',(if (pair? f) (car f) f))))))) (,_type_slot_offset ,name ',(if (pair? f) (car f) f)))))))
fields) fields)
;; constructor ;; constructor
,(if make-fields ,(if make-fields
`(,_define ,make-name `(,_define ,make-name
,(let lp ((ls make-fields) (sets '())) ,(let lp ((ls make-fields) (sets '()))
(cond (cond
((null? ls) ((null? ls)
`(,_let ((%make (,(rename 'make-constructor) `(,_let ((%make (,(rename 'make-constructor)
,(id->string make-name) ,(id->string make-name)
,name))) ,name)))
(,_lambda ,make-fields (,_lambda ,make-fields
(,_let ((res (%make))) (,_let ((res (%make)))
,@sets ,@sets
res)))) res))))
(else (else
(let ((field (assq (car ls) fields))) (let ((field (assq (car ls) fields)))
(cond (cond
;;((not field) ;;((not field)
;; (error "unknown record field in constructor" (car ls))) ;; (error "unknown record field in constructor" (car ls)))
((and (pair? field) (pair? (cdr field)) (pair? (cddr field))) ((and (pair? field) (pair? (cdr field)) (pair? (cddr field)))
(lp (cdr ls) (lp (cdr ls)
(cons (list (caddr field) 'res (car ls)) sets))) (cons (list (caddr field) 'res (car ls)) sets)))
(else (else
(lp (cdr ls) (lp (cdr ls)
(cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) sets))))))))) (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) sets)))))))))
`(,_define ,make-name `(,_define ,make-name
(,_let ((%make (,(rename 'make-constructor) (,_let ((%make (,(rename 'make-constructor)
,(id->string make-name) ,(id->string make-name)
,name))) ,name)))
(,_lambda args (,_lambda args
(,_let ((res (%make))) (,_let ((res (%make)))
(let lp ((a args) (let lp ((a args)
(p (,_vector->list (,_rtd-all-field-names ,name)))) (p (,_vector->list (,_rtd-all-field-names ,name))))
(cond (cond
((null? a) ((null? a)
(if (null? p) (if (null? p)
res res
(error ,(string-append "not enough arguments to " (id->string make-name) ": missing") (error ,(string-append "not enough arguments to " (id->string make-name) ": missing")
p))) p)))
((null? p) ((null? p)
(error ,(string-append "too many arguments to " (id->string make-name)) (error ,(string-append "too many arguments to " (id->string make-name))
a)) a))
(else (else
(,_slot-set! ,name res (,_type_slot_offset ,name (car p)) (car a)) (,_slot-set! ,name res (,_type_slot_offset ,name (car p)) (car a))
(lp (cdr a) (cdr p))))))))) (lp (cdr a) (cdr p)))))))))))))))
))))))