mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-21 14:49:18 +02:00
merge
This commit is contained in:
Alex Shinn
commit
078c591cbc
3 changed files with 90 additions and 88 deletions
|
|
@ -525,6 +525,8 @@
|
|||
|
||||
;; I/O utils
|
||||
|
||||
(define (port? x) (or (input-port? x) (output-port? x)))
|
||||
|
||||
(define (char-ready? . o)
|
||||
(not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@
|
|||
(_type_slot_offset (rename 'type-slot-offset)))
|
||||
`(,(rename 'begin)
|
||||
;; type
|
||||
(,_define ,name (,_register ,name-str ,parent ',fields))
|
||||
(,_define ,name (,_register ,name-str ,parent ',(map car fields)))
|
||||
;; predicate
|
||||
(,_define ,pred (,(rename 'make-type-predicate)
|
||||
,(symbol->string (identifier->symbol pred))
|
||||
|
|
@ -25,42 +25,43 @@
|
|||
;; fields
|
||||
,@(map (lambda (f)
|
||||
(and (pair? f) (pair? (cdr f))
|
||||
`(,_define ,(cadar ls)
|
||||
(,(rename 'make-getter)
|
||||
,(symbol->string
|
||||
(identifier->symbol (cadr f)))
|
||||
,name
|
||||
(,_type_slot_offset ,name ,(car f))))))
|
||||
`(,_define ,(cadr f)
|
||||
(,(rename 'make-getter)
|
||||
,(symbol->string
|
||||
(identifier->symbol (cadr f)))
|
||||
,name
|
||||
(,_type_slot_offset ,name ',(car f))))))
|
||||
fields)
|
||||
,@(map (lambda (f)
|
||||
(and (pair? f) (pair? (cdr f)) (pair? (cddr f))
|
||||
`(,_define ,(caddar ls)
|
||||
(,(rename 'make-setter)
|
||||
,(symbol->string
|
||||
(identifier->symbol (caddr f)))
|
||||
,name
|
||||
(,_type_slot_offset ,name ,(car f))))))
|
||||
`(,_define ,(caddr f)
|
||||
(,(rename 'make-setter)
|
||||
,(symbol->string
|
||||
(identifier->symbol (caddr f)))
|
||||
,name
|
||||
(,_type_slot_offset ,name ',(car f))))))
|
||||
fields)
|
||||
;; constructor
|
||||
(,_define ,make
|
||||
,(let lp ((ls make-fields) (sets '()))
|
||||
(cond
|
||||
((null? ls)
|
||||
`(,_let ((%make (,(rename 'make-constructor)
|
||||
,(symbol->string (identifier->symbol make))
|
||||
,name)))
|
||||
(,_lambda ,make-fields
|
||||
(,_let ((res (%make)))
|
||||
,@sets
|
||||
res))))
|
||||
(else
|
||||
(let ((field (assq (car ls) fields)))
|
||||
(cond
|
||||
((not field)
|
||||
(error "unknown record field in constructor" (car ls)))
|
||||
((pair? (cddr field))
|
||||
(lp (cdr ls)
|
||||
(cons (list (caddr field) 'res (car ls)) sets)))
|
||||
(else
|
||||
(lp (cdr ls)
|
||||
(cons (list _slot-set! 'res (list 'quote (car ls)) (car ls)) sets))))))))))))))
|
||||
,(let lp ((ls make-fields) (sets '()))
|
||||
(cond
|
||||
((null? ls)
|
||||
`(,_let ((%make (,(rename 'make-constructor)
|
||||
,(symbol->string (identifier->symbol make))
|
||||
,name)))
|
||||
(,_lambda ,make-fields
|
||||
(,_let ((res (%make)))
|
||||
,@sets
|
||||
res))))
|
||||
(else
|
||||
(let ((field (assq (car ls) fields)))
|
||||
(cond
|
||||
((not field)
|
||||
(error "unknown record field in constructor" (car ls)))
|
||||
((pair? (cddr field))
|
||||
(lp (cdr ls)
|
||||
(cons `(,(caddr field) res ,(car ls)) sets)))
|
||||
(else
|
||||
(lp (cdr ls)
|
||||
(cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls))
|
||||
sets))))))))))))))
|
||||
|
|
|
|||
|
|
@ -31,9 +31,9 @@
|
|||
;; predicate
|
||||
,@(if pred-name
|
||||
`((,_define ,pred-name
|
||||
(,(rename 'make-type-predicate)
|
||||
,(id->string pred-name)
|
||||
,name)))
|
||||
(,(rename 'make-type-predicate)
|
||||
,(id->string pred-name)
|
||||
,name)))
|
||||
#f)
|
||||
;; accessors
|
||||
,@(map (lambda (f)
|
||||
|
|
@ -44,10 +44,10 @@
|
|||
(string-append name-str "-" (id->string f)))))))
|
||||
(and g
|
||||
`(,_define ,g
|
||||
(,(rename 'make-getter)
|
||||
,(id->string g)
|
||||
,name
|
||||
(,_type_slot_offset ,name ',(if (pair? f) (car f) f)))))))
|
||||
(,(rename 'make-getter)
|
||||
,(id->string g)
|
||||
,name
|
||||
(,_type_slot_offset ,name ',(if (pair? f) (car f) f)))))))
|
||||
fields)
|
||||
,@(map (lambda (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!"))))))
|
||||
(and s
|
||||
`(,_define ,s
|
||||
(,(rename 'make-setter)
|
||||
,(id->string s)
|
||||
,name
|
||||
(,_type_slot_offset ,name ',(if (pair? f) (car f) f)))))))
|
||||
(,(rename 'make-setter)
|
||||
,(id->string s)
|
||||
,name
|
||||
(,_type_slot_offset ,name ',(if (pair? f) (car f) f)))))))
|
||||
fields)
|
||||
;; constructor
|
||||
,(if make-fields
|
||||
`(,_define ,make-name
|
||||
,(let lp ((ls make-fields) (sets '()))
|
||||
(cond
|
||||
((null? ls)
|
||||
`(,_let ((%make (,(rename 'make-constructor)
|
||||
,(id->string make-name)
|
||||
,name)))
|
||||
(,_lambda ,make-fields
|
||||
(,_let ((res (%make)))
|
||||
,@sets
|
||||
res))))
|
||||
(else
|
||||
(let ((field (assq (car ls) fields)))
|
||||
(cond
|
||||
;;((not field)
|
||||
;; (error "unknown record field in constructor" (car ls)))
|
||||
((and (pair? field) (pair? (cdr field)) (pair? (cddr field)))
|
||||
(lp (cdr ls)
|
||||
(cons (list (caddr field) 'res (car ls)) sets)))
|
||||
(else
|
||||
(lp (cdr ls)
|
||||
(cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) sets)))))))))
|
||||
`(,_define ,make-name
|
||||
(,_let ((%make (,(rename 'make-constructor)
|
||||
,(id->string make-name)
|
||||
,name)))
|
||||
(,_lambda args
|
||||
(,_let ((res (%make)))
|
||||
(let lp ((a args)
|
||||
(p (,_vector->list (,_rtd-all-field-names ,name))))
|
||||
(cond
|
||||
((null? a)
|
||||
(if (null? p)
|
||||
res
|
||||
(error ,(string-append "not enough arguments to " (id->string make-name) ": missing")
|
||||
p)))
|
||||
((null? p)
|
||||
(error ,(string-append "too many arguments to " (id->string make-name))
|
||||
a))
|
||||
(else
|
||||
(,_slot-set! ,name res (,_type_slot_offset ,name (car p)) (car a))
|
||||
(lp (cdr a) (cdr p)))))))))
|
||||
))))))
|
||||
`(,_define ,make-name
|
||||
,(let lp ((ls make-fields) (sets '()))
|
||||
(cond
|
||||
((null? ls)
|
||||
`(,_let ((%make (,(rename 'make-constructor)
|
||||
,(id->string make-name)
|
||||
,name)))
|
||||
(,_lambda ,make-fields
|
||||
(,_let ((res (%make)))
|
||||
,@sets
|
||||
res))))
|
||||
(else
|
||||
(let ((field (assq (car ls) fields)))
|
||||
(cond
|
||||
;;((not field)
|
||||
;; (error "unknown record field in constructor" (car ls)))
|
||||
((and (pair? field) (pair? (cdr field)) (pair? (cddr field)))
|
||||
(lp (cdr ls)
|
||||
(cons (list (caddr field) 'res (car ls)) sets)))
|
||||
(else
|
||||
(lp (cdr ls)
|
||||
(cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) sets)))))))))
|
||||
`(,_define ,make-name
|
||||
(,_let ((%make (,(rename 'make-constructor)
|
||||
,(id->string make-name)
|
||||
,name)))
|
||||
(,_lambda args
|
||||
(,_let ((res (%make)))
|
||||
(let lp ((a args)
|
||||
(p (,_vector->list (,_rtd-all-field-names ,name))))
|
||||
(cond
|
||||
((null? a)
|
||||
(if (null? p)
|
||||
res
|
||||
(error ,(string-append "not enough arguments to " (id->string make-name) ": missing")
|
||||
p)))
|
||||
((null? p)
|
||||
(error ,(string-append "too many arguments to " (id->string make-name))
|
||||
a))
|
||||
(else
|
||||
(,_slot-set! ,name res (,_type_slot_offset ,name (car p)) (car a))
|
||||
(lp (cdr a) (cdr p)))))))))))))))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue