;;;; type-checks.scm
;;;; Kon Lovett, Apr '09

(declare
  (usual-integrations)
  (generic)
  (inline)
  (local)
  (no-procedure-checks)
  (no-bound-checks)
  (bound-to-procedure
    ##sys#structure?) )

;;;

(module type-checks (;export
  check-fixnum
  check-positive-fixnum
  check-cardinal-fixnum
  check-flonum
  check-integer
  check-positive-integer
  check-cardinal-integer
  check-number
  check-positive-number
  check-cardinal-number
  check-procedure
  check-input-port
  check-output-port
  check-list
  check-pair
  check-blob
  check-vector
  check-structure
  check-symbol
  check-keyword
  check-string
  check-char
  check-boolean
  ;;
  define-check-type define-check+error-type)

(import chicken scheme type-errors)
(require-library type-errors)

;;

(cond-expand
  (unsafe
 
    (define-syntax define-check-type
      (lambda (form r c)
        (let (($define (r 'define)))
          (let* ((typ (cadr form))
                 (nam (string->symbol (string-append "check-" (symbol->string typ)))) )
            `(,$define (,nam . _) (begin) ) ) ) ) )

    (define (check-positive-fixnum . _) (begin))
    (define (check-cardinal-fixnum . _) (begin))
    (define (check-positive-integer . _) (begin))
    (define (check-cardinal-integer . _) (begin))
    (define (check-positive-number . _) (begin))
    (define (check-cardinal-number . _) (begin))
    (define (check-structure . _) (begin)) )

  (else

    ;;

    ; <symbol>          : <pred> is '<symbol>?'
    ; <symbol> <symbol> : <pred> is <symbol>
    ; ->
    ; (define (check-<symbol> loc obj #!optional argnam)
    ;   (unless (<pred> obj)
    ;     (error-<symbol> loc obj argnam) ) )

    (define-syntax define-check-type
      (lambda (form r c)
        (let (($define (r 'define))
              ($#!optional (r '#!optional)) )
          (let* ((typ (cadr form))
                 (typstr (symbol->string typ))
                 (pred (if (not (null? (cddr form))) (caddr form) (string->symbol (string-append typstr "?"))))
                 (nam (string->symbol (string-append "check-" typstr)))
                 (errnam (string->symbol (string-append "error-" typstr))) )
            `(,$define (,nam loc obj ,$#!optional argnam)
               (unless (,pred obj)
                 (,errnam loc obj argnam) ) ) ) ) ) )
    ;;

    (define (check-positive-fixnum loc obj #!optional argnam)
      (unless (and (fixnum? obj) (fx< 0 obj))
        (error-positive-fixnum loc obj argnam) ) )

    (define (check-cardinal-fixnum loc obj #!optional argnam)
      (unless (and (fixnum? obj) (fx<= 0 obj))
        (error-cardinal-fixnum loc obj argnam) ) )

    ;;

    (define (check-positive-integer loc obj #!optional argnam)
      (unless (and (integer? obj) (positive? obj))
        (error-positive-integer loc obj argnam) ) )

    (define (check-cardinal-integer loc obj #!optional argnam)
      (unless (and (integer? obj) (<= 0 obj))
        (error-cardinal-integer loc obj argnam) ) )

    ;;

    (define (check-positive-number loc obj #!optional argnam)
      (unless (positive? obj)
        (error-positive-number loc obj argnam) ) )

    (define (check-cardinal-number loc obj #!optional argnam)
      (unless (<= 0 obj)
        (error-cardinal-number loc obj argnam) ) )

    ;;

    (define (check-structure loc obj tag #!optional argnam)
      (unless (##sys#structure? obj tag)
        (error-structure loc obj tag argnam) ) ) ) )

;;

(define-check-type fixnum)
(define-check-type flonum)
(define-check-type integer)
(define-check-type number)
(define-check-type symbol)
(define-check-type keyword)
(define-check-type string)
(define-check-type char)
(define-check-type boolean)
(define-check-type procedure)
(define-check-type input-port)
(define-check-type output-port)
(define-check-type list)
(define-check-type pair)
(define-check-type blob)
(define-check-type vector)

;;

(define-syntax define-check+error-type
  (lambda (form r c)
    (let (($define-check-type (r 'define-check-type))
          ($define-error-type (r 'define-error-type)) )
      (let ((typ (cadr form)))
        `(begin
           (,$define-check-type ,typ)
           (,$define-error-type ,typ) ) ) ) ) )

) ;module type-checks