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

(import scheme type-errors-basic)

;;

(define-syntax unbound-value
	(syntax-rules ()
		((unbound-value)
			(##sys#slot '##sys#arbitrary-unbound-symbol 0) ) ) )

(define-syntax unbound-value?
	(syntax-rules ()
		((unbound-value? ?val)
			(eq? (unbound-value) ?val) ) ) )

(define-syntax unbound?
	(syntax-rules ()
		((unbound? ?sym)
			(unbound-value? (##sys#slot ?sym 0)) ) ) )

;;

(cond-expand

  (unsafe

    (define-syntax define-check-type
      (er-macro-transformer
        (lambda (frm rnm cmp)
          (let ((_define (rnm 'define)))
            (let* ((typ (cadr frm))
                   (typstr (symbol->string (strip-syntax typ)))
                   (nam (string->symbol (string-append "check-" typstr))) )
              `(,_define (,nam loc obj . _) obj) ) ) ) ) )

    (define defined-value? (lambda _ #t))
    (define bound-value? (lambda _ #t))

    (define (check-minimum-argument-count loc obj . _) obj)
    (define (check-argument-count loc obj . _) obj) )

  (else

    (define-syntax define-check-type
      (er-macro-transformer
        (lambda (frm rnm cmp)
          (let ((_define (rnm 'define))
                (_unless (rnm 'unless))
                (_optional (rnm 'optional)) )
            (let* ((typ (cadr frm))
                   (typstr (symbol->string (strip-syntax typ)))
                   (pred
                     (if (not (null? (cddr frm)))
                         (caddr frm)
                         (string->symbol (string-append typstr "?"))))
              (nam (string->symbol (string-append "check-" typstr)))
              (errnam (string->symbol (string-append "error-" typstr))) )
              `(,_define (,nam loc obj . args)
                 (,_unless (,pred obj)
                   (,errnam loc obj (,_optional args)))
                 obj ) ) ) ) ) )

    ;; Is the object non-void?

    (define (defined-value? obj)
      (not (eq? (void) obj)) )

    ;; Is the object bound to value?

    ;is obj the value from the de-ref of an unbound variable.
    ;could only occur in a rather unsafe calling environnment.

    (define (bound-value? obj)
      (##core#inline "C_unboundvaluep" obj) )

    ;;

    (define (check-minimum-argument-count loc argc minargc)
      (unless (<= minargc argc)
        (error-minimum-argument-count loc argc minargc))
      argc )

    (define (check-argument-count loc argc maxargc)
      (unless (<= argc maxargc)
        (error-argument-count loc argc maxargc))
      argc ) ) )

;;

(define-check-type defined-value)
(define-check-type bound-value)


;;

;<type-symbol> [<type-predicate> [<message-string>]]

(define-syntax define-check+error-type
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (let ((_define-check-type (rnm 'define-check-type))
            (_define-error-type (rnm 'define-error-type)) )
        (let* ((typ (cadr frm))
               (pred (and (not (null? (cddr frm))) (caddr frm)))
               (mesg (and pred (not (null? (cdddr frm))) (cadddr frm))) )
          `(begin
             (,_define-error-type ,typ ,@(if mesg `(,mesg) '()))
             (,_define-check-type ,typ ,@(if pred `(,pred) '())) ) ) ) ) ) )