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

;; Needs "chicken-primitive-object-inlines.scm"

;;

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

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

  (else

    ;;

    (define-syntax define-inline-check-type
      (lambda (form r c)
        (let (($define-inline (r 'define-inline))
              ($#!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-inline (,nam loc obj ,$#!optional argnam)
               (unless (,pred obj)
                 (,errnam loc obj argnam) ) ) ) ) ) )

    ;;

    (define-inline (%check-positive-fixnum loc obj #!optional argnam)
      (unless (and (%fixnum? obj) (%fxpositive? obj))
        (error-positive-fixnum loc obj argnam) ) )

    (define-inline (%check-cardinal-fixnum loc obj #!optional argnam)
      (unless (and (%fixnum? obj) (%fxcardinal? obj))
        (error-cardinal-fixnum loc obj argnam) ) )

    ;;

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

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

    ;;

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

    (define-inline (%check-cardinal-number loc obj #!optional argnam)
      (unless (%cardinal? obj)
        (error-cardinal-number loc obj argnam) ) )

    ;;

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

;;

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