Function: math-setup-holidays

math-setup-holidays is an autoloaded and byte-compiled function defined in calc-forms.el.gz.

Signature

(math-setup-holidays &optional DATE)

Source Code

;; Defined in /usr/src/emacs/lisp/calc/calc-forms.el.gz
(defun math-setup-holidays (&optional date)
  (or (eq (calc-var-value 'var-Holidays) math-holidays-cache-tag)
      (let ((h (calc-var-value 'var-Holidays))
	    (wdnames '( (sun . 0) (mon . 1) (tue . 2) (wed . 3)
			(thu . 4) (fri . 5) (sat . 6) ))
	    (days nil) (weekdays nil) (exprs nil) (limit nil) (hours nil))
	(or (math-vectorp h)
	    (math-reject-arg h "*Holidays variable must be a vector"))
	(while (setq h (cdr h))
	  (cond ((or (and (eq (car-safe (car h)) 'date)
			  (integerp (nth 1 (car h))))
		     (and (eq (car-safe (car h)) 'intv)
			  (eq (car-safe (nth 2 (car h))) 'date))
		     (eq (car-safe (car h)) 'vec))
		 (setq days (cons (car h) days)))
		((and (eq (car-safe (car h)) 'var)
		      (assq (nth 1 (car h)) wdnames))
		 (setq weekdays (cons (cdr (assq (nth 1 (car h)) wdnames))
				      weekdays)))
		((and (eq (car-safe (car h)) 'intv)
		      (eq (car-safe (nth 2 (car h))) 'hms)
		      (eq (car-safe (nth 3 (car h))) 'hms))
		 (if hours
		     (math-reject-arg
		      (car h) "*Only one hours interval allowed in Holidays"))
		 (setq hours (math-div (car h) '(hms 24 0 0)))
		 (if (or (Math-lessp (nth 2 hours) 0)
			 (Math-lessp 1 (nth 3 hours)))
		     (math-reject-arg
		      (car h) "*Hours interval out of range"))
		 (setq hours (cons (nth 2 hours)
				   (math-sub (nth 3 hours) (nth 2 hours))))
		 (if (Math-zerop (cdr hours))
		     (math-reject-arg
		      (car h) "*Degenerate hours interval")))
		((or (and (eq (car-safe (car h)) 'intv)
			  (Math-integerp (nth 2 (car h)))
			  (Math-integerp (nth 3 (car h))))
		     (and (integerp (car h))
			  (> (car h) 1900) (< (car h) 2100)))
		 (if limit
		     (math-reject-arg
		      (car h) "*Only one limit allowed in Holidays"))
		 (setq limit (calcFunc-vint (car h) '(intv 3 1 2737)))
		 (if (equal limit '(vec))
		     (math-reject-arg (car h) "*Limit is out of range")))
		((or (math-expr-contains (car h) '(var y var-y))
		     (math-expr-contains (car h) '(var m var-m)))
		 (setq exprs (cons (car h) exprs)))
		(t (math-reject-arg
		    (car h) "*Holidays must contain a vector of holidays"))))
	(if (= (length weekdays) 7)
	    (math-reject-arg nil "*Too many weekend days"))
	(setq math-holidays-cache (list (list -1)  ; 0: days list
					(list -1)  ; 1: inverse-days list
					nil        ; 2: exprs
					(sort weekdays '<)
					(or limit '(intv 3 1 2737))
					nil        ; 5: (lo.hi) expanded years
					(cons exprs days)
					hours)     ; 7: business hours
	      math-holidays-cache-tag (calc-var-value 'var-Holidays))))
  (if date
      (let ((year (calcFunc-year date))
	    (limits (nth 5 math-holidays-cache))
	    (done nil))
	(or (eq (calcFunc-in year (nth 4 math-holidays-cache)) 1)
	    (progn
	      (or (eq (car-safe date) 'date) (setq date (list 'date date)))
	      (math-reject-arg date "*Date is outside valid range")))
	(unwind-protect
	    (let ((days (nth 6 math-holidays-cache)))
	      (if days
		  (let ((math-sh-year nil))   ; see below
		    (setcar (nthcdr 6 math-holidays-cache) nil)
		    (math-setup-add-holidays (cons 'vec (cdr days)))
		    (setcar (nthcdr 2 math-holidays-cache) (car days))))
	      (cond ((not (nth 2 math-holidays-cache))
		     (setq done t)
		     nil)
		    ((not limits)
		     (setcar (nthcdr 5 math-holidays-cache) (cons year year))
		     (math-setup-year-holidays year)
		     (setq done t))
		    ((< year (car limits))
		     (message "Computing holidays, %d .. %d"
			      year (1- (car limits)))
		     (calc-set-command-flag 'clear-message)
		     (while (< year (car limits))
		       (setcar limits (1- (car limits)))
		       (math-setup-year-holidays (car limits)))
		     (setq done t))
		    ((> year (cdr limits))
		     (message "Computing holidays, %d .. %d"
			      (1+ (cdr limits)) year)
		     (calc-set-command-flag 'clear-message)
		     (while (> year (cdr limits))
		       (setcdr limits (1+ (cdr limits)))
		       (math-setup-year-holidays (cdr limits)))
		     (setq done t))
		    (t
		     (setq done t)
		     nil)))
	  (or done (setq math-holidays-cache-tag t))))))