Initial impl of define-case-class in (liii case)

GoldfishScheme.tmu

@@ -5193,6 +5193,24 @@
     \;
   </scm-chunk>
 
+  <paragraph|define-case-class>
+
+  <\scm-chunk|tests/goldfish/liii/case-test.scm|true|true>
+    (define-case-class person ((name "Bob") (age 21)))
+
+    \;
+
+    (let1 bob (person :name "Bob" :age 21)
+
+    \ \ (check (bob 'name) =\<gtr\> "Bob")
+
+    \ \ (check (bob 'age) =\<gtr\> 21)
+
+    \ \ (check ((bob :name "hello") 'name) =\<gtr\> "hello"))
+
+    \;
+  </scm-chunk>
+
   <paragraph|case*><index|case*>
 
   <\scm-chunk|tests/goldfish/liii/case-test.scm|true|true>

goldfish/liii/case.scm

@@ -15,9 +15,37 @@
 ;
 
 (define-library (liii case)
-(export case*)
+(export case* define-case-class)
 (begin
 
+(define-macro (define-case-class class-name fields)
+  (let ((constructor (string->symbol (string-append (symbol->string class-name))))
+        (key-fields (map (lambda (field)
+                           (string->symbol (string-append ":" (symbol->string (car field)))))
+                         fields)))
+    `(begin
+       ;; 定义构造函数
+       (define* (,constructor ,@(map (lambda (field)
+                                       `(,(car field) ,(cadr field)))
+                                     fields))
+         (lambda (msg . args)
+           (cond
+             ;; 字段访问
+             ,@(map (lambda (field)
+                      `((eq? msg ',(car field)) ,(car field)))
+                    fields)
+             ;; 字段更新
+             ,@(map (lambda (field key-field)
+                      `((eq? msg ,key-field)
+                        (,constructor ,@(map (lambda (f)
+                                               (if (eq? (car f) (car field))
+                                                   '(car args)
+                                                   (car f)))
+                                             fields))))
+                    fields key-fields)
+             ;; 未知消息
+             (else (error "Unknown message"))))))))
+
 ; 0 clause BSD, from S7 repo case.scm
 (define case* 
   (let ((case*-labels (lambda (label)

tests/goldfish/liii/case-test.scm

@@ -3,6 +3,13 @@
 
 (check-set-mode! 'report-failed)
 
+(define-case-class person ((name "Bob") (age 21)))
+
+(let1 bob (person :name "Bob" :age 21)
+  (check (bob 'name) => "Bob")
+  (check (bob 'age) => 21)
+  (check ((bob :name "hello") 'name) => "hello"))
+
 ; 0 clause BSD, from S7 repo s7test.scm
 (define (scase x)
   (case* x