;;;; check-errors.builtins.scm  -*- Scheme -*-

(module (check-errors sys)

(;export
  ;
  check-list check-pair check-vector check-boolean check-char check-exact
  check-inexact check-number check-integer check-real check-fixnum
  check-string check-symbol check-keyword check-output-port check-input-port
  check-locative check-closure check-procedure check-byte-vector check-blob
  ;
  check-exact-integer check-exact-unsigned-integer
  check-fixnum-in-range
  ;
  check-structure
  define-check-structure)

(import scheme
  (chicken base)
  (chicken syntax))

(cond-expand
  (unsafe
    (define-syntax check-list
      (syntax-rules ()
        ((check-list ?loc ?obj) ?obj) ) )

    (define-syntax check-pair
      (syntax-rules ()
        ((check-pair ?loc ?obj) ?obj) ) )

    (define-syntax check-vector
      (syntax-rules ()
        ((check-vector ?loc ?obj) ?obj) ) )

    (define-syntax check-boolean
      (syntax-rules ()
        ((check-boolean ?loc ?obj) ?obj) ) )

    (define-syntax check-char
      (syntax-rules ()
        ((check-char ?loc ?obj) ?obj) ) )

    (define-syntax check-exact
      (syntax-rules ()
        ((check-exact ?loc ?obj) ?obj) ) )

    (define-syntax check-inexact
      (syntax-rules ()
        ((check-inexact ?loc ?obj) ?obj) ) )

    (define-syntax check-number
      (syntax-rules ()
        ((check-number ?loc ?obj) ?obj) ) )

    (define-syntax check-integer
      (syntax-rules ()
        ((check-integer ?loc ?obj) ?obj) ) )

    (define-syntax check-real
      (syntax-rules ()
        ((check-real ?loc ?obj) ?obj) ) )

    (define-syntax check-fixnum
      (syntax-rules ()
        ((check-fixnum ?loc ?obj) ?obj) ) )

    (define-syntax check-string
      (syntax-rules ()
        ((check-string ?loc ?obj) ?obj) ) )

    (define-syntax check-symbol
      (syntax-rules ()
        ((check-symbol ?loc ?obj) ?obj) ) )

    (define-syntax check-keyword
      (syntax-rules ()
        ((check-keyword ?loc ?obj) ?obj) ) )

    (define-syntax check-output-port
      (syntax-rules ()
        ((check-output-port ?loc ?obj) ?obj) ) )

    (define-syntax check-input-port
      (syntax-rules ()
        ((check-input-port ?loc ?obj) ?obj) ) )

    (define-syntax check-locative
      (syntax-rules ()
        ((check-locative ?loc ?obj) ?obj) ) )

    (define-syntax check-closure
      (syntax-rules ()
        ((check-closure ?loc ?obj) ?obj) ) )

    (define-syntax check-procedure
      (syntax-rules ()
        ((check-procedure ?loc ?obj) ?obj) ) )

    (define-syntax check-byte-vector
      (syntax-rules ()
        ((check-byte-vector ?loc ?obj) ?obj) ) )

    (define-syntax check-blob
      (syntax-rules ()
        ((check-blob ?loc ?obj) ?obj) ) )

    (define-syntax check-exact-integer
      (syntax-rules ()
        ((check-exact-integer ?loc ?obj) ?obj) ) )

    (define-syntax check-exact-unsigned-integer
      (syntax-rules ()
        ((check-exact-unsigned-integer ?loc ?obj) ?obj) ) )

    ;NOTE the module must export the tag as a binding, not all do!
    (define-syntax check-structure
      (syntax-rules ()
        ((check-structure ?loc ?obj tag)
          (begin (##sys#check-structure ?obj tag ?loc) ?obj)) ) )

    (define-syntax check-fixnum-in-range
      (syntax-rules ()
        ((check-fixnum-in-range ?loc ?obj ?from ?to) ?obj)) )

    (define-syntax define-check-structure
      (er-macro-transformer
        (lambda (frm rnm cmp)
          (let ((_define (rnm 'define)))
            (let* ((tag (cadr frm))
                   (nam (string->symbol (string-append "check-" (symbol->string tag)))) )
              `(,_define (,nam loc obj) obj) ) ) ) ) ) )
  (else
    (define-syntax check-list
      (syntax-rules ()
        ((check-list ?loc ?obj)
          (begin (##sys#check-list ?obj ?loc) ?obj)) ) )

    (define-syntax check-pair
      (syntax-rules ()
        ((check-pair ?loc ?obj)
          (begin (##sys#check-pair ?obj ?loc) ?obj)) ) )

    (define-syntax check-vector
      (syntax-rules ()
        ((check-vector ?loc ?obj)
          (begin (##sys#check-vector ?obj ?loc) ?obj)) ) )

    (define-syntax check-boolean
      (syntax-rules ()
        ((check-boolean ?loc ?obj)
          (begin (##sys#check-boolean ?obj ?loc) ?obj)) ) )

    (define-syntax check-char
      (syntax-rules ()
        ((check-char ?loc ?obj)
          (begin (##sys#check-char ?obj ?loc) ?obj)) ) )

    (define-syntax check-exact
      (syntax-rules ()
        ((check-exact ?loc ?obj)
          (begin (##sys#check-exact ?obj ?loc) ?obj)) ) )

    (define-syntax check-inexact
      (syntax-rules ()
        ((check-inexact ?loc ?obj)
          (begin (##sys#check-inexact ?obj ?loc) ?obj)) ) )

    (define-syntax check-number
      (syntax-rules ()
        ((check-number ?loc ?obj)
          (begin (##sys#check-number ?obj ?loc) ?obj)) ) )

    (define-syntax check-integer
      (syntax-rules ()
        ((check-integer ?loc ?obj)
          (begin (##sys#check-integer ?obj ?loc) ?obj)) ) )

    (define-syntax check-real
      (syntax-rules ()
        ((check-real ?loc ?obj)
          (begin (##sys#check-real ?obj ?loc) ?obj)) ) )

    (define-syntax check-fixnum
      (syntax-rules ()
        ((check-fixnum ?loc ?obj)
          (begin (##sys#check-fixnum ?obj ?loc) ?obj)) ) )

    (define-syntax check-string
      (syntax-rules ()
        ((check-string ?loc ?obj)
          (begin (##sys#check-string ?obj ?loc) ?obj)) ) )

    (define-syntax check-symbol
      (syntax-rules ()
        ((check-symbol ?loc ?obj)
          (begin (##sys#check-symbol ?obj ?loc) ?obj)) ) )

    (define-syntax check-keyword
      (syntax-rules ()
        ((check-keyword ?loc ?obj)
          (begin (##sys#check-keyword ?obj ?loc) ?obj)) ) )

    (define-syntax check-output-port
      (syntax-rules ()
        ((check-output-port ?loc ?obj)
          (begin (##sys#check-output-port ?obj ?loc) ?obj)) ) )

    (define-syntax check-input-port
      (syntax-rules ()
        ((check-input-port ?loc ?obj)
          (begin (##sys#check-input-port ?obj ?loc) ?obj)) ) )

    (define-syntax check-locative
      (syntax-rules ()
        ((check-locative ?loc ?obj)
          (begin (##sys#check-locative ?obj ?loc) ?obj)) ) )

    (define-syntax check-closure
      (syntax-rules ()
        ((check-closure ?loc ?obj)
          (begin (##sys#check-closure ?obj ?loc) ?obj)) ) )

    (define-syntax check-procedure
      (syntax-rules ()
        ((check-procedure ?loc ?obj)
          (begin (##sys#check-closure ?obj ?loc) ?obj)) ) )

    (define-syntax check-byte-vector
      (syntax-rules ()
        ((check-byte-vector ?loc ?obj)
          (begin (##sys#check-byte-vector ?obj ?loc) ?obj)) ) )

    (define-syntax check-blob
      (syntax-rules ()
        ((check-blob ?loc ?obj)
          (begin (##sys#check-blob ?obj ?loc) ?obj)) ) )

    (define-syntax check-exact-integer
      (syntax-rules ()
        ((check-exact-integer ?loc ?obj)
          (begin (##sys#check-exact-integer ?obj ?loc) ?obj)) ) )

    (define-syntax check-exact-unsigned-integer
      (syntax-rules ()
        ((check-exact-unsigned-integer ?loc ?obj)
          (begin (##sys#check-exact-uinteger ?obj ?loc) ?obj)) ) )

    ;NOTE the module must export the tag as a binding, not all do!
    (define-syntax check-structure
      (syntax-rules ()
        ((check-structure ?loc ?obj tag)
          (begin (##sys#check-structure ?obj tag ?loc) ?obj)) ) )

    (define-syntax check-fixnum-in-range
      (syntax-rules ()
        ((check-fixnum-in-range ?loc ?obj ?from ?to)
          (begin (##sys#check-range ?obj ?from ?to ?loc) ?obj)) ) )

    ;NOTE the module must export the tag as a binding, not all do!
    (define-syntax define-check-structure
      (er-macro-transformer
        (lambda (frm rnm cmp)
          (let ((_define (rnm 'define))
                (_check-structure (rnm 'check-structure)))
           (let* ((tag (cadr frm))
                  (nam (string->symbol (string-append "check-" (symbol->string tag)))) )
              `(,_define (,nam loc obj) (,_check-structure loc obj ,tag)) ) ) ) ) ) ) )

) ;module (check-errors sys)