diff --git a/src/brmember.scm b/src/brmember.scm index 08a11cd..56798a4 100644 --- a/src/brmember.scm +++ b/src/brmember.scm @@ -473,10 +473,10 @@ (make-ldict `((info . ,(make-ldict `((member . (,(make-cal-period (make-cal-month 2015 1) #f))) - (suspend (make-cal-period - (make-cal-month 2010 1) - (make-cal-onth 2022 4) - #f #f)))))))))) + (suspend ,(make-cal-period + (make-cal-month 2010 1) + (make-cal-month 2022 4) + #f #f)))))))))) (test-true brmember-active? (parameterize ((*current-month* (make-cal-month 2023 2))) (brmember-active? @@ -484,10 +484,10 @@ `((member . (,(make-cal-period (make-cal-month 2015 1) #f))) - (suspend (make-cal-period - (make-cal-month 2010 1) - (make-cal-month 2022 4) - #f #f)))))))))) + (suspend ,(make-cal-period + (make-cal-month 2010 1) + (make-cal-month 2022 4) + #f #f)))))))))) )) ) diff --git a/src/cal-period.scm b/src/cal-period.scm index 316b1f7..bfe492d 100644 --- a/src/cal-period.scm +++ b/src/cal-period.scm @@ -52,6 +52,7 @@ lookup-by-cal-period cal-ensure-month + cal-ensure-day cal-period-tests! ) @@ -215,6 +216,17 @@ #t (loop (cdr ps))))))) + ;; Checks whether given day belongs to day or month period + (define (cal-day-in-period? p . dl) + (let ((d (if (null? dl) + (*current-day*) + (cal-ensure-day (car dl)))) + (before (cal-ensure-day (cal-period-before p))) + (since (cal-ensure-day (cal-period-since p)))) + (and (or (not before) + (cal-daystring p) (sprintf "~A..~A" @@ -271,7 +283,21 @@ (if v (if (cal-month? v) v - (apply cal-day->month v stop?s)) + (if (cal-day? v) + (apply cal-day->month v stop?s) + #f)) + #f)) + + ;; Ensures day for checking the periods + (define (cal-ensure-day v) + (if v + (if (cal-day? v) + v + (if (cal-month? v) + (make-cal-day (cal-month-year v) + (cal-month-month v) + 1) + #f)) #f)) ;; Performs self-tests of the period module. diff --git a/src/testing.scm b/src/testing.scm index ec191a3..6e20214 100644 --- a/src/testing.scm +++ b/src/testing.scm @@ -91,7 +91,7 @@ (let ((result expression)) (if (eq? result #f) (display ".") - (error 'test-true (sprintf "~A expression=~S result=~S" + (error 'test-false (sprintf "~A expression=~S result=~S" 'name 'expression result))))))) ;; Passes if the-test raises an exception