;;;; srfi-102.scm  -*- Hen -*-
;;;; Kon Lovett, Oct '09

(module srfi-102

  (;export
    ; SRFI 102
    procedure-arity
    arity-at-least?
    arity-at-least-value
    procedure-arity-includes?
    ; Extensions
    procedure-arity-available?
    procedure-minimum-arity
    procedure-fixed-arity?
    fixed-arity->arity-at-least
    procedure-arity-set!
    append-procedure-arity!)

  (import scheme chicken
          (rename procedure-introspection
                  (procedure-arity pi:procedure-arity)
                  (procedure-arity-includes? pi:procedure-arity-includes?)
                  (procedure-minimum-arity pi:procedure-minimum-arity)
                  (procedure-fixed-arity? pi:procedure-fixed-arity?)))

  (require-library procedure-introspection)

  (declare (bound-to-procedure ##sys#check-closure ##sys#exact->inexact))

;;; Public API

;;

(define (arity-at-least? obj) (and (inexact? obj) (<= 0 obj)))

(define (arity-at-least-value k) (if (arity-at-least? k) (inexact->exact k) k))

(define (fixed-arity->arity-at-least k)
  (check-scalar-arity k 'fixed-arity->arity-at-least)
  (##sys#exact->inexact k) )

;;

; When in doubt assume the best

(define (procedure-arity proc)
  (##sys#check-closure proc 'procedure-arity)
  (*procedure-arity proc) )

(define (procedure-arity-includes? proc k)
  (or (not (procedure-arity-available? proc))
      (pi:procedure-arity-includes? proc k)) )

;NOT SRFI 102

(define (procedure-minimum-arity proc)
  (and (procedure-arity-available? proc)
       (pi:procedure-minimum-arity proc) ) )

;NOT SRFI 102

(define (procedure-fixed-arity? proc)
  (and (procedure-arity-available? proc) 
       (pi:procedure-fixed-arity? proc)) )

;;;

(register-feature! 'srfi-102)

) ;module srfi-102