diff --git a/lib/init.scm b/lib/init.scm index 62d044ec..c8a807e7 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -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)))))) diff --git a/lib/srfi/9.scm b/lib/srfi/9.scm index c1818042..9fb1aeca 100644 --- a/lib/srfi/9.scm +++ b/lib/srfi/9.scm @@ -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)))))))))))))) diff --git a/lib/srfi/99/records/syntactic.scm b/lib/srfi/99/records/syntactic.scm index 356ec34f..c5cf90f7 100644 --- a/lib/srfi/99/records/syntactic.scm +++ b/lib/srfi/99/records/syntactic.scm @@ -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)))))))))))))))