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

merge

Browse source
This commit is contained in:
Alex Shinn 2010-09-17 01:48:51 +00:00
commit 078c591cbc
3 changed files with 90 additions and 88 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lib/init.scm
View file

@ -525,6 +525,8 @@
;; I/O utils ;; I/O utils
(define (port? x) (or (input-port? x) (output-port? x)))
(define (char-ready? . o) (define (char-ready? . o)
(not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port)))))) (not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port))))))

69
lib/srfi/9.scm
View file

@ -17,7 +17,7 @@
(_type_slot_offset (rename 'type-slot-offset))) (_type_slot_offset (rename 'type-slot-offset)))
`(,(rename 'begin) `(,(rename 'begin)
;; type ;; type
(,_define ,name (,_register ,name-str ,parent ',fields)) (,_define ,name (,_register ,name-str ,parent ',(map car fields)))
;; predicate ;; predicate
(,_define ,pred (,(rename 'make-type-predicate) (,_define ,pred (,(rename 'make-type-predicate)
,(symbol->string (identifier->symbol pred)) ,(symbol->string (identifier->symbol pred))
@ -25,42 +25,43 @@
;; fields ;; fields
,@(map (lambda (f) ,@(map (lambda (f)
(and (pair? f) (pair? (cdr f)) (and (pair? f) (pair? (cdr f))
`(,_define ,(cadar ls) `(,_define ,(cadr f)
(,(rename 'make-getter) (,(rename 'make-getter)
,(symbol->string ,(symbol->string
(identifier->symbol (cadr f))) (identifier->symbol (cadr f)))
,name ,name
(,_type_slot_offset ,name ,(car f)))))) (,_type_slot_offset ,name ',(car f))))))
fields) fields)
,@(map (lambda (f) ,@(map (lambda (f)
(and (pair? f) (pair? (cdr f)) (pair? (cddr f)) (and (pair? f) (pair? (cdr f)) (pair? (cddr f))
`(,_define ,(caddar ls) `(,_define ,(caddr f)
(,(rename 'make-setter) (,(rename 'make-setter)
,(symbol->string ,(symbol->string
(identifier->symbol (caddr f))) (identifier->symbol (caddr f)))
,name ,name
(,_type_slot_offset ,name ,(car f)))))) (,_type_slot_offset ,name ',(car f))))))
fields) fields)
;; constructor ;; constructor
(,_define ,make (,_define ,make
,(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)
,(symbol->string (identifier->symbol make)) ,(symbol->string (identifier->symbol make))
,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)))
((pair? (cddr field)) ((pair? (cddr field))
(lp (cdr ls) (lp (cdr ls)
(cons (list (caddr field) 'res (car ls)) sets))) (cons `(,(caddr field) res ,(car ls)) sets)))
(else (else
(lp (cdr ls) (lp (cdr ls)
(cons (list _slot-set! 'res (list 'quote (car ls)) (car ls)) sets)))))))))))))) (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls))
sets))))))))))))))

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)))))))))))))))
))))))