diff --git a/lib/srfi/99/records/syntactic.scm b/lib/srfi/99/records/syntactic.scm index 9e52d49f..1f8ae70c 100644 --- a/lib/srfi/99/records/syntactic.scm +++ b/lib/srfi/99/records/syntactic.scm @@ -37,14 +37,15 @@ (,(rename 'make-type-predicate) ,(id->string pred-name) ,name))) - #f) + '()) ;; accessors ,@(map (lambda (f) (let ((g (if (and (pair? f) (pair? (cdr f))) (cadr f) - (and (identifier? f) - (string->symbol - (string-append name-str "-" (id->string f))))))) + (string->symbol + (string-append name-str + "-" + (id->string (if (pair? f) (car f) f))))))) (and g `(,_define ,g (,(rename 'make-getter) @@ -53,11 +54,14 @@ (,_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))) - (car (cddr f)) - (and (identifier? f) + (let ((s (and (pair? f) + (if (and (pair? (cdr f)) (pair? (cddr f))) + (car (cddr f)) (string->symbol - (string-append name-str "-" (id->string f) "-set!")))))) + (string-append name-str + "-" + (id->string (car f)) + "-set!")))))) (and s `(,_define ,s (,(rename 'make-setter) @@ -66,45 +70,47 @@ (,_type_slot_offset ,name ',(if (pair? f) (car f) f))))))) fields) ;; constructor - ,(if make-fields - (let ((fields (map (lambda (f) (cons (rename f) f)) make-fields))) - `(,_define ,make-name - ,(let lp ((ls fields) (sets '())) - (cond - ((null? ls) - `(,_let ((,_make (,(rename 'make-constructor) - ,(id->string make-name) - ,name))) - (,_lambda ,(map car fields) - (,_let ((res (,_make))) - ,@sets - res)))) - (else - (let ((field (assq (cdar ls) fields))) - (cond - ((and (pair? field) (pair? (cdr field)) (pair? (cddr field))) - (lp (cdr ls) - (cons (list (car (cddr field)) 'res (cdar ls)) sets))) - (else - (lp (cdr ls) - (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(cdar ls)) ,(caar 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))))))))))))))) + ,@(if make-name + (if make-fields + (let ((fields (map (lambda (f) (cons (rename f) f)) make-fields))) + `((,_define ,make-name + ,(let lp ((ls fields) (sets '())) + (cond + ((null? ls) + `(,_let ((,_make (,(rename 'make-constructor) + ,(id->string make-name) + ,name))) + (,_lambda ,(map car fields) + (,_let ((res (,_make))) + ,@sets + res)))) + (else + (let ((field (assq (cdar ls) fields))) + (cond + ((and (pair? field) (pair? (cdr field)) (pair? (cddr field))) + (lp (cdr ls) + (cons (list (car (cddr field)) 'res (cdar ls)) sets))) + (else + (lp (cdr ls) + (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(cdar ls)) ,(caar 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))))))))))) + '())))))) diff --git a/tests/record-tests.scm b/tests/record-tests.scm index 40c7758e..c1159fe1 100644 --- a/tests/record-tests.scm +++ b/tests/record-tests.scm @@ -2,6 +2,7 @@ (cond-expand (modules (import (srfi 99) + (only (chibi) env-exports) (only (chibi test) test-begin test-assert test test-end))) (else #f)) @@ -112,8 +113,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-record-type person #t #t name sex age) -(define-record-type (employee person) #t #t department salary) +(define-record-type person #t #t (name) (sex) (age)) +(define-record-type (employee person) #t #t (department) (salary)) (define bob (make-employee "Bob" 'male 28 'hr 50000.0)) (define alice (make-employee "Alice" 'female 32 'research 100000.0)) @@ -148,9 +149,9 @@ (test #f (employee-department bob)) (test 0.0 (employee-salary bob)) -;;;; SRFI-99 forbids this, but we currently do it anyway. -;;(test-assert (equal? (make-employee "Chuck" 'male 20 'janitorial 50000.0) -;; (make-employee "Chuck" 'male 20 'janitorial 50000.0))) +;; SRFI-99 forbids this, but we currently do it anyway. +(test-assert (equal? (make-employee "Chuck" 'male 20 'janitorial 50000.0) + (make-employee "Chuck" 'male 20 'janitorial 50000.0))) (test-assert (record? alice)) (test 'person (rtd-name person)) @@ -169,7 +170,7 @@ ;; (make-foo x) ;; foo? ;; (x foo-x)) - +;; ;; (test-assert (not (rtd-field-mutable? foo 'x))) (define point (make-rtd "point" #(x y))) @@ -183,4 +184,39 @@ (test-assert (example? (make-example 3))) (test 3 (example-example (make-example 3))) +;; record types definitions with #f passed as either the constructor or +;; predicate argument should not create the corresponding function + +(define-record-type abstract + #f #t) + +(test #f (memq 'make-abstract (env-exports (current-environment)))) + +(define-record-type (derived abstract) + #t #f) + +(define instance (make-derived)) +(test-assert (abstract? instance)) +(test #f (memq 'derived? (env-exports (current-environment)))) + +(define-record-type container + #t #t + default-immutable + (default-mutable) + (named-immutable get-container-immutable) + (named-mutable get-container-mutable set-container-mutable!)) + +(define container-instance (make-container 1 2 3 4)) + +(test 1 (container-default-immutable container-instance)) +(test 2 (container-default-mutable container-instance)) +(test 3 (get-container-immutable container-instance)) +(test 4 (get-container-mutable container-instance)) + +(container-default-mutable-set! container-instance #t) +(test #t (container-default-mutable container-instance)) + +(set-container-mutable! container-instance #t) +(test #t (get-container-mutable container-instance)) + (test-end)