;;;; numeric-macros.scm  -*- Scheme -*-
;;;; Kon Lovett, Aug '18
;;;; Kon Lovett, Aug '10

(module numeric-macros

(;export
  ;
  one? two? three? four? five? six? seven? eight? nine? ten?
  ;
  ++
  --
  fx++
  fx--
  fp++
  fp--
  fl++
  fl--
  ++!
  --!
  fx++!
  fx--!
  fp++!
  fp--!
  fl++!
  fl--!)

(import scheme
  (chicken base)
  (chicken fixnum)
  (chicken flonum)
  (chicken syntax))

(import-for-syntax (only moremacros set!-op type-case))

;;

(define-syntax one? (syntax-rules () ((one? ?n) (= 1 ?n))))
(define-syntax two? (syntax-rules () ((two? ?n) (= 2 ?n))))
(define-syntax three? (syntax-rules () ((three? ?n) (= 3 ?n))))
(define-syntax four? (syntax-rules () ((four? ?n) (= 4 ?n))))
(define-syntax five? (syntax-rules () ((five? ?n) (= 5 ?n))))
(define-syntax six? (syntax-rules () ((six? ?n) (= 6 ?n))))
(define-syntax seven? (syntax-rules () ((seven? ?n) (= 7 ?n))))
(define-syntax eight? (syntax-rules () ((eight? ?n) (= 8 ?n))))
(define-syntax nine? (syntax-rules () ((nine? ?n) (= 9 ?n))))
(define-syntax ten? (syntax-rules () ((ten? ?n) (= 10 ?n))))

;;

; The "numbers" extension provides number predicates & operators but
; they cannot be relied upon in the expansion environment.

(define-syntax numeric-op/1
  (er-macro-transformer
    (lambda (exp ren cmp)
      (let (
        (op (cadr exp))
        (ops (caddr exp)) )
        (let (
          (fx-op (car ops))
          (fl-op (cadr ops))
          (gn-op (caddr ops)) )
          `(define-syntax ,op
            (er-macro-transformer
              (lambda (exp ren cmp)
                (let (
                  (n (cadr exp)) )
                  (type-case n
                    ; Constant expression
                    (fixnum   (list ',fx-op n 1))
                    (flonum   (list ',fl-op n 1.0))
                    ; Unknown type or non-constant expression
                    (else     (list ',gn-op n 1)) ) ) ) ) ) ) ) ) ) )

;;; Immutable

(numeric-op/1 ++ (fx+ fp+ +))

(numeric-op/1 -- (fx- fp- -))

(define-syntax fx++
	(syntax-rules ()
		((fx++ ?n) (fx+ ?n 1)) ) )

(define-syntax fx--
	(syntax-rules ()
		((fx-- ?n) (fx- ?n 1)) ) )

(define-syntax fp++
	(syntax-rules ()
		((fp++ ?n) (fp+ ?n 1.0)) ) )

(define-syntax fp--
	(syntax-rules ()
		((_ ?n) (fp- ?n 1.0)) ) )

(define-syntax fl++
	(syntax-rules ()
		((fp-- ?n) (fp+ ?n 1.0)) ) )

(define-syntax fl--
	(syntax-rules ()
		((fl-- ?n) (fp- ?n 1.0)) ) )

;;; Mutable

(define-syntax ++!
	(syntax-rules ()
		((++! ?v) (set!-op ?v + <> 1)) ) )

(define-syntax --!
	(syntax-rules ()
		((--! ?v) (set!-op ?v - <> 1)) ) )

(define-syntax fx++!
	(syntax-rules ()
		((fx++! ?v) (set!-op ?v fx+ <> 1)) ) )

(define-syntax fx--!
	(syntax-rules ()
		((fx--! ?v) (set!-op ?v fx- <> 1)) ) )

(define-syntax fp++!
	(syntax-rules ()
		((fp++! ?v) (set!-op ?v fp+ <> 1.0)) ) )

(define-syntax fp--!
	(syntax-rules ()
		((fp--! ?v) (set!-op ?v fp- <> 1.0)) ) )

(define-syntax fl++!
	(syntax-rules ()
		((fl++! ?v) (set!-op ?v fp+ <> 1.0)) ) )

(define-syntax fl--!
	(syntax-rules ()
		((fl--! ?v) (set!-op ?v fp- <> 1.0)) ) )

) ;module numeric-macros