Work on new cal-period.

src/cal-period.scm

@@ -62,7 +62,11 @@
 	 (chicken string)
 	 cal-month
 	 testing
-	 configuration)
+	 configuration
+	 util-tag)
+
+ ;; Type tag
+ (define TAG-CAL-PERIOD (make-tag CAL-PERIOD))
 
  ;; Current month - if changed, we get the actual state for given month.
  (define *current-month*
@@ -73,19 +77,19 @@
 
  ;; Creates a new period value with optional since and before
  ;; comments.
- (define (make-period since before . args)
+ (define (make-cal-period since before . args)
    (let ((scomment (if (not (null? args)) (car args) #f))
 	 (bcomment (if (and (not (null? args))
 			    (not (null? (cdr args))))
 		       (cadr args)
 		       #f)))
-     (list since before scomment bcomment)))
+     (list TAG-CAL-PERIOD since before scomment bcomment)))
 
  ;; Simple accessors
- (define period-since car)
- (define period-before cadr)
- (define period-scomment caddr)
- (define period-bcomment cadddr)
+ (define cal-period-since cadr)
+ (define cal-period-before caddr)
+ (define cal-period-scomment cadddr)
+ (define cal-period-bcomment (compose cadddr cdr))
 
  ;; Sorts period markers (be it start or end) chronologically and
  ;; returns the sorted list.
@@ -95,15 +99,15 @@
 	   (month<? (cadr a) (cadr b)))))
 
  ;; Converts list of start/stop markers to list of pairs of months -
- ;; periods.
- (define (period-markers->periods l)
+ ;; periods. The markers are lists in the form (start/stop cal-month).
+ (define (period-markers->cal-periods l)
    (let loop ((l (sort-period-markers l))
 	      (ps '())
 	      (cb #f))
      (if (null? l)
 	 (list #t
 	       (if cb
-		   (reverse (cons (make-period (car cb) #f (cadr cb)) ps))
+		   (reverse (cons (make-cal-period (car cb) #f (cadr cb)) ps))
 		   (reverse ps))
 	       ""
 	       -1)
@@ -121,7 +125,7 @@
 	   (if (eq? mtype rmt)
 	       (if cb
 		   (loop (cdr l)
-			 (cons (make-period (car cb) month (cadr cb) comment) ps)
+			 (cons (make-cal-period (car cb) month (cadr cb) comment) ps)
 			 #f)
 		   (loop (cdr l)
 			 ps
@@ -133,91 +137,91 @@
 
  ;; Returns duration of period in months. Start is included, end is
  ;; not. The period contains the month just before the specified end.
- (define (period->duration p)
-   (let* ((b (period-since p))
-	  (e (period-before p))
+ (define (cal-period->duration p)
+   (let* ((b (cal-period-since p))
+	  (e (cal-period-before p))
 	  (e- (if e e (*current-month*))))
-     (month-diff b e-)))
+     (cal-month-diff b e-)))
 
  ;; Returns sum of periods lengths.
- (define (periods-duration l)
-   (apply + (map period->duration l)))
+ (define (cal-periods-duration l)
+   (apply + (map cal-period->duration l)))
 
  ;; True if month belongs to given month period - start inclusive, end
  ;; exclusive.
- (define (month-in-period? p . ml)
+ (define (cal-month-in-period? p . ml)
    (let ((m (if (null? ml)
 		(*current-month*)
 		(car ml))))
-     (and (or (not (period-before p))
-	      (month<? m (period-before p)))
-	  (not (month<? m (period-since p))))))
+     (and (or (not (cal-period-before p))
+	      (cal-month<? m (cal-period-before p)))
+	  (not (cal-month<? m (cal-period-since p))))))
 
  ;; Returns true if given month is in at least one of the periods
  ;; given. Defaults to current month.
- (define (month-in-periods? ps . ml)
+ (define (cal-month-in-periods? ps . ml)
    (let ((m (if (null? ml)
 		(*current-month*)
 		(car ml))))
      (let loop ((ps ps))
        (if (null? ps)
 	   #f
-	   (if (month-in-period? (car ps) m)
+	   (if (cal-month-in-period? (car ps) m)
 	       #t
 	       (loop (cdr ps)))))))
 
  ;; Returns string representing a month period with possibly open end.
- (define (period->string p)
+ (define (cal-period->string p)
    (sprintf "~A..~A"
-	    (month->string (period-since p))
-	    (month->string (period-before p))))
+	    (cal-month->string (cal-period-since p))
+	    (cal-month->string (cal-period-before p))))
 
  ;; Returns a string representing a list of periods.
- (define (periods->string ps)
+ (define (cal-periods->string ps)
    (string-intersperse
-    (map period->string ps)
+    (map cal-period->string ps)
     ", "))
 
  ;; Finds a period the month matches and returns it. If no period
  ;; matches, it returns #f.
- (define (periods-match ps .  ml)
+ (define (cal-periods-match ps .  ml)
    (let ((m (if (null? ml) (*current-month*) (car ml))))
      (let loop ((ps ps))
        (if (null? ps)
 	   #f
-	   (if (month-in-period? (car ps) m)
+	   (if (cal-month-in-period? (car ps) m)
 	       (car ps)
 	       (loop (cdr ps)))))))
 
  ;; Creates lookup table from definition source
- (define (make-period-lookup-table source)
+ (define (make-cal-period-lookup-table source)
    (let loop ((lst source)
 	      (res '())
 	      (prev #f))
      (if (null? lst)
 	 (reverse
-	  (cons (cons (make-period (car prev) #f)
+	  (cons (cons (make-cal-period (car prev) #f)
 		      (cdr prev))
 		res))
 	 (loop (cdr lst)
 	       (if prev
-		   (cons (cons (make-period (car prev) (caar lst))
+		   (cons (cons (make-cal-period (car prev) (caar lst))
 			       (cdr prev))
 			 res)
 		   res)
 	       (car lst)))))
 
  ;; Looks up current month and returns associated definitions
- (define (lookup-by-period table)
+ (define (lookup-by-cal-period table)
    (let loop ((lst table))
      (if (null? lst)
 	 #f
-	 (if (month-in-period? (caar lst))
+	 (if (cal-month-in-period? (caar lst))
 	     (cdar lst)
 	     (loop (cdr lst))))))
 
  ;; Performs self-tests of the period module.
- (define (period-tests!)
+ (define (cal-period-tests!)
    (run-tests
     period
     (test-equal? sort-period-markers