;;;; numbers-compiler-macros.scm


(define-for-syntax (numbers:fold-operator args fixop numop zero)
  (reduce-right
   (lambda (x y)
     (let ((tmp (gensym))
	   (tx (gensym))
	   (ty (gensym)) )
       `(let ((,tx ,x)
	      (,ty ,y) )
	  (let ((,tmp (,@fixop ,tx ,ty)))
	    (if ,tmp
		,tmp
		(,numop ,tx ,ty) ) ) ) ) )
   zero
   args) )

(define-for-syntax numbers:bitwise-with-overflow 
  (string>=? (chicken-version) "3.0.2"))

(define-compiler-macro (+ . args)
  (numbers:fold-operator args '(##core#inline "C_i_o_fixnum_plus") 'numbers:+ 0) )

(define-compiler-macro (bitwise-and . args)
  (if numbers:bitwise-with-overflow
      (numbers:fold-operator 
       args 
       '(##core#inline "C_i_o_fixnum_and") 
       'numbers:bitwise-and 
       -1)
      `(numbers:bitwise-and ,@args)))

(define-compiler-macro (bitwise-ior . args)
  (if numbers:bitwise-with-overflow
      (numbers:fold-operator 
       args
       '(##core#inline "C_i_o_fixnum_ior") 
       'numbers:bitwise-ior
       0) 
      `(numbers:bitwise-ior ,@args)))

(define-compiler-macro (bitwise-xor . args)
  (if numbers:bitwise-with-overflow
      (numbers:fold-operator 
       args 
       '(##core#inline "C_i_o_fixnum_xor") 
       'numbers:bitwise-xor
       0)
      `(numbers:bitwise-xor ,@args)))

(define-compiler-macro (bitwise-not n)
  (let ((tmp (gensym)))
    `(let ((,tmp ,n))
       (if (##core#inline "C_fixnump" ,tmp)
	   (##core#inline "C_fixnum_not" ,tmp)
	   (numbers:bitwise-not ,tmp) ) ) ) )

(define-compiler-macro (- #:whole form . args)
  (cond ((null? args) form)
	((null? (cdr args)) 
	 (let ((tmp (gensym)))
	   `(let ((,tmp ,(car args)))
	      (if (##core#inline "C_fixnump" ,tmp)
		  (##core#inline "C_fixnum_negate" ,tmp)
		  (numbers:- 0 ,tmp) ) ) ) )
	(else
	 (reduce
	  (lambda (y x)
	    (let ((tmp (gensym))
		  (tx (gensym))
		  (ty (gensym)) )
	      `(let ((,tx ,x)
		     (,ty ,y) )
		 (let ((,tmp (##core#inline "C_i_o_fixnum_difference" ,tx ,ty)))
		   (if ,tmp
		       ,tmp
		       (numbers:- ,tx ,ty) ) ) ) ) )
	  #f
	  args) ) ) )

(define-for-syntax (numbers:fold-predicate args fixop numop fail)
  (if (<= (length args) 1)
      fail
      (let ((t1 (gensym))
	    (tp1 (gensym)) )
	`(let ((,t1 ,(car args)))
	   (let ((,tp1 (##core#inline "C_fixnump" ,t1)))
	     ,(let loop ((args (cdr args)) (prev t1) (prevt tp1))
		(if (null? args)
		    #t
		    (let ((t2 (gensym))
			  (tp2 (gensym)) )
		      `(let ((,t2 ,(car args)))
			 (let ((,tp2 (##core#inline "C_fixnump" ,t2)))
			   (if (if (if ,prevt ,tp2 #f)
				   (,@fixop ,prev ,t2)
				   (,numop ,prev ,t2) )
			       ,(loop (cdr args) t2 tp2)
			       #f) ) ) ) ) ) ) ) ) ) )

(define-compiler-macro (= #:whole form . args)
  (numbers:fold-predicate args '(eq?) 'numbers:= form) )

(define-compiler-macro (> #:whole form . args)
  (numbers:fold-predicate 
   args '(##core#inline "C_fixnum_greaterp") 
   'numbers:> form) )

(define-compiler-macro (< #:whole form . args)
  (numbers:fold-predicate 
   args '(##core#inline "C_fixnum_lessp")
   'numbers:< form) )

(define-compiler-macro (>= #:whole form . args)
  (numbers:fold-predicate 
   args '(##core#inline "C_fixnum_greater_or_equal_p")
   'numbers:>= form) )

(define-compiler-macro (<= #:whole form . args)
  (numbers:fold-predicate 
   args '(##core#inline "C_fixnum_less_or_equal_p")
   'numbers:<= form) )