diff --git a/GoldfishScheme.tmu b/GoldfishScheme.tmu index 066d191..7037fe7 100644 --- a/GoldfishScheme.tmu +++ b/GoldfishScheme.tmu @@ -147,7 +147,7 @@ - <\scm-chunk|goldfish/scheme/base.scm|false|true> + <\goldfish-chunk|goldfish/scheme/base.scm|false|true> ; ; Copyright (C) 2024 The Goldfish Scheme Authors @@ -179,9 +179,9 @@ ; \; - + - <\scm-chunk|goldfish/liii/base.scm|false|true> + <\goldfish-chunk|goldfish/liii/base.scm|false|true> ; ; Copyright (C) 2024 The Goldfish Scheme Authors @@ -213,7 +213,7 @@ ; \; - + \; @@ -319,7 +319,7 @@ \; - <\scm-chunk|goldfish/liii/base.scm|true|true> + <\goldfish-chunk|goldfish/liii/base.scm|true|true> (define-library (liii base) (import (scheme base) @@ -404,14 +404,14 @@ \ \ ; Extra routines for (liii base) - \ \ == != display* in? let1 compose identity typed-lambda + \ \ == != display* in? let1 compose identity typed-lambda typed-define ) (begin \; - + @@ -3671,6 +3671,68 @@ \; + + + <\goldfish-chunk|goldfish/liii/base.scm|true|true> + (define-macro (typed-define name-and-params body) + + \ \ (let* ((name (car name-and-params)) + + \ \ \ \ \ \ \ \ \ (params (cdr name-and-params))) + + \ \ \ \ `(define* (,name ,@(map (lambda (param) + + \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (let ((param-name (car param)) + + \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (type-pred (cadr param)) + + \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (default-value (cddr param))) + + \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (if (null? default-value) + + \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ param-name ; 无默认值时直接使用参数名 + + \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ `(,param-name ,(car default-value))))) ; 有默认值时使用默认值 + + \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ params)) + + \; + + \ \ \ \ \ \ \ ,@(map (lambda (param) + + \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (let ((param-name (car param)) + + \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (type-pred (cadr param))) + + \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ `(unless (,type-pred ,param-name) + + \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (error 'type-error (string-append "Invalid type for " (symbol-\string ',param-name)))))) + + \ \ \ \ \ \ \ \ \ \ \ \ \ \ params) + + \; + + \ \ \ \ \ \ \ ,body))) + + \; + + + <\goldfish-chunk|tests/goldfish/liii/base-test.scm|true|true> + (typed-define (person (name string? "Bob") (age integer?)) + + \ \ (string-append name " is " (number-\string age) " years old")) + + \; + + (check (person :age 21) =\ "Bob is 21 years old") + + (check (person :name "Alice" :age 25) =\ "Alice is 25 years old") + + (check-catch 'type-error (person :name 123 :age 25)) + + \; + + \; @@ -5196,7 +5258,7 @@ <\scm-chunk|tests/goldfish/liii/case-test.scm|true|true> - (define-case-class person ((name "Bob") (age 21))) + (define-case-class person ((name string? "Bob") (age integer?))) \; @@ -5209,6 +5271,10 @@ \ \ (check ((bob :name "hello") 'name) =\ "hello")) \; + + (check-catch 'type-error (person 1 21)) + + \; diff --git a/goldfish/liii/base.scm b/goldfish/liii/base.scm index ecb98c4..05484c8 100644 --- a/goldfish/liii/base.scm +++ b/goldfish/liii/base.scm @@ -56,7 +56,7 @@ ; SRFI-8 receive ; Extra routines for (liii base) - == != display* in? let1 compose identity typed-lambda + == != display* in? let1 compose identity typed-lambda typed-define ) (begin @@ -116,6 +116,27 @@ args) ,@body)))) +(define-macro (typed-define name-and-params body) + (let* ((name (car name-and-params)) + (params (cdr name-and-params))) + `(define* (,name ,@(map (lambda (param) + (let ((param-name (car param)) + (type-pred (cadr param)) + (default-value (cddr param))) + (if (null? default-value) + param-name ; 无默认值时直接使用参数名 + `(,param-name ,(car default-value))))) ; 有默认值时使用默认值 + params)) + + ,@(map (lambda (param) + (let ((param-name (car param)) + (type-pred (cadr param))) + `(unless (,type-pred ,param-name) + (error 'type-error (string-append "Invalid type for " (symbol->string ',param-name)))))) + params) + + ,body))) + ) ; end of begin ) ; end of define-library diff --git a/goldfish/liii/case.scm b/goldfish/liii/case.scm index fb55302..2f3e5db 100644 --- a/goldfish/liii/case.scm +++ b/goldfish/liii/case.scm @@ -15,6 +15,7 @@ ; (define-library (liii case) +(import (liii base)) (export case* define-case-class) (begin @@ -24,17 +25,12 @@ (string->symbol (string-append ":" (symbol->string (car field))))) fields))) `(begin - ;; 定义构造函数 - (define* (,constructor ,@(map (lambda (field) - `(,(car field) ,(cadr field))) - fields)) + (typed-define ,(cons class-name 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) @@ -43,8 +39,7 @@ (car f))) fields)))) fields key-fields) - ;; 未知消息 - (else (error "Unknown message")))))))) + (else (value-error "Unknown message" msg)))))))) ; 0 clause BSD, from S7 repo case.scm (define case* diff --git a/tests/goldfish/liii/base-test.scm b/tests/goldfish/liii/base-test.scm index 76dc0d9..fb9d28f 100755 --- a/tests/goldfish/liii/base-test.scm +++ b/tests/goldfish/liii/base-test.scm @@ -677,6 +677,13 @@ (check (add3 1 2 3) => 6) (check-catch 'type-error (add3 1.2 2 3)) +(typed-define (person (name string? "Bob") (age integer?)) + (string-append name " is " (number->string age) " years old")) + +(check (person :age 21) => "Bob is 21 years old") +(check (person :name "Alice" :age 25) => "Alice is 25 years old") +(check-catch 'type-error (person :name 123 :age 25)) + (check-report) (check (make-list 3 #\a) => (list #\a #\a #\a)) diff --git a/tests/goldfish/liii/case-test.scm b/tests/goldfish/liii/case-test.scm index b5dc2dd..e77d387 100644 --- a/tests/goldfish/liii/case-test.scm +++ b/tests/goldfish/liii/case-test.scm @@ -3,13 +3,15 @@ (check-set-mode! 'report-failed) -(define-case-class person ((name "Bob") (age 21))) +(define-case-class person ((name string? "Bob") (age integer?))) (let1 bob (person :name "Bob" :age 21) (check (bob 'name) => "Bob") (check (bob 'age) => 21) (check ((bob :name "hello") 'name) => "hello")) +(check-catch 'type-error (person 1 21)) + ; 0 clause BSD, from S7 repo s7test.scm (define (scase x) (case* x