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

(import scheme type-errors-basic)

;;

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

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

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

;;

;maybe a problem with expansion environment namespace pollution
(define-for-syntax (symbolize . elts)
  (string->symbol (apply conc (map strip-syntax elts))) )

;;

(cond-expand

  (unsafe

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

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

  (else

    ;<symbol>          : <pred> is '<symbol>?'
    ;<symbol> <symbol> : <pred> is <symbol>
    ;->
    ;(define (check-<symbol> loc obj . args)
    ;  (unless (<pred> obj)
    ;    (error-<symbol> loc obj (optional args)))
    ;  obj )

    (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 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-type defined-value)
(define-check-type bound-value)

(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 )

;;

;<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) '())) ) ) ) ) ) )