;;;; type-checks-structured.impl.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18

(import scheme
  (only (chicken blob) blob?)
  type-errors-structured
  type-checks-basic)

;;

(cond-expand

  (unsafe

    (define (check-structure loc obj . _) obj)
    (define (check-record loc obj . _) obj)
    (define (check-record-type loc obj . _) obj) )

  (else

    ;;These are weak predicates. Only check for structure.

    (define (alist? obj)
      (or
        (null? obj)
        (and
          (pair? obj)
          (let loop ((ls obj))
            (or
              (null? ls)
              (and
                ;since anything can be a key no stronger check possible
                (pair? (car ls))
                (loop (cdr ls) ) ) ) ) ) ) )

    (define (plist? obj)
      ;since anything can be a key no stronger check possible
      (and (list? obj) (even? (length obj))) )

    ;;

    (define (check-structure loc obj tag . args)
      (unless (##sys#structure? obj tag)
        (error-structure loc obj tag (optional args)))
      obj )

    (define (check-record loc obj tag . args)
      (unless (##sys#structure? obj tag)
        (error-record loc obj tag (optional args)))
      obj )

    (define (check-record-type loc obj tag . args)
      (unless (##sys#structure? obj tag)
        (error-record-type loc obj tag (optional args)))
      obj ) ) )

;;

(define-check-type string)
(define-check-type procedure)
(define check-closure check-procedure)
(define-check-type input-port)
(define-check-type output-port)
(define-check-type list)
(define-check-type plist)
(define-check-type alist)
(define-check-type pair)
(define-check-type blob)
(define-check-type vector)