;;; cpcheck.ss
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;; 
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;; 
;;; http://www.apache.org/licenses/LICENSE-2.0
;;; 
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; cpcheck checks argument counts in calls to primitives and user-defined
;;; procedures, where it can recognize them.  by running it after cp0, we
;;; catch more potentially incorrect calls, including calls to the record
;;; constructors and accessors constructed by cp0.  running it after cp0 can
;;; also lead to bogus warnings on rare occasions, as in:
;;; 
;;; (define (f b)
;;;   (define h (lambda (b f) (if b (f 1) (f 1 2))))
;;;   (if b
;;;       (h b (lambda (x) x))
;;;       (h b (lambda (x y) y))))
;;;
;;; where the calls (f 1) and (f 1 2) will be identified as having possible
;;; incorrect argument counts.  it seems like a reasonable tradeoff.

(define $cpcheck
(let ()
  (import (nanopass))
  (include "base-lang.ss")

  (define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds))
  (define rtd-size (csv7:record-field-accessor #!base-rtd 'size))

  (define maybe-remake-rtd
    (lambda (rtd)
      (if (eq? ($target-machine) (machine-type))
          rtd
          ($remake-rtd rtd (let () (include "layout.ss") compute-field-offsets)))))

  (define record-field-offset
    (lambda (rtd index)
      (let ([rtd (maybe-remake-rtd rtd)])
        (fld-byte (list-ref (rtd-flds rtd) index)))))

  (define-pass cpcheck : Lsrc (ir) -> Lsrc ()
    (definitions
      (define-record-type call-context
        (nongenerative)
        (sealed #t)
        (fields cnt (mutable err))
        (protocol
          (lambda (new)
            (lambda (cnt) (new cnt #f)))))

      (define check!
        (lambda (ctxt interface*)
          (define interface-okay?
            (lambda (interface* cnt)
              (ormap
                (lambda (interface)
                  (if (fx< interface 0)
                      (fx>= cnt (lognot interface))
                      (fx= cnt interface)))
                interface*)))
          (when ctxt
            (unless (interface-okay? interface* (call-context-cnt ctxt))
              (call-context-err-set! ctxt #t)))))

      (define record-lambda!
        (lambda (id val)
          (unless (prelex-assigned id)
            (nanopass-case (Lsrc Expr) val
              [(case-lambda ,preinfo (clause (,x** ...) ,interface* ,body*) ...)
               (prelex-operand-set! id interface*)]
              [else (void)]))))

      (define-syntax with-record-lambda
        (syntax-rules ()
          [(_ ids vals body)
           (begin
             (for-each record-lambda! ids vals)
             (let ([x body])
               (for-each (lambda (id) (prelex-operand-set! id #f)) ids)
               x))]))

      (with-output-language (Lsrc Expr)
        (define build-sequence
          (lambda (x* body)
            (fold-left (lambda (body x) `(seq ,x ,body)) body x*)))

        (define argcnt-error
          (lambda (preinfo f args)
            (let ([call (parameterize ([print-gensym #f] [print-level 3] [print-length 6])
                          (format "~s" (preinfo-sexpr preinfo)))])
              `(seq ,f
                 ,(build-sequence args
                    (cond
                      [(preinfo-src preinfo) =>
                       (lambda (src)
                         ($source-warning 'compile src #t
                           "possible incorrect argument count in call ~a"
                           call)
                         `(call ,preinfo
                            ,(lookup-primref 2 '$source-violation)
                            (quote #f)
                            (quote ,src)
                            (quote #t)
                            (quote "incorrect argument count in call ~a")
                            (quote ,call)))]
                      [else
                       `(call ,preinfo
                          ,(lookup-primref 2 '$oops)
                          (quote #f)
                          (quote "incorrect argument count in call ~a")
                          (quote ,call))]))))))))
    (Expr : Expr (ir [ctxt #f]) -> Expr ()
      [(quote ,d) ir]
      [(ref ,maybe-src ,x)
       (cond
         [(prelex-operand x) =>
          (lambda (interface*)
            (and (list? interface*)
                 (check! ctxt interface*)))])
       `(ref ,maybe-src ,x)]
      [(set! ,maybe-src ,x ,[e #f -> e]) `(set! ,maybe-src ,x ,e)]
      [(seq ,[e1 #f -> e1] ,[e2]) `(seq ,e1 ,e2)]
      [(if ,[e1 #f -> e1] ,[e2 #f -> e2] ,[e3 #f -> e3]) `(if ,e1 ,e2 ,e3)]
      [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
       (check! ctxt (list (length arg-type*)))
       `(foreign (,conv* ...) ,name ,(Expr e #f) (,arg-type* ...) ,result-type)]
      [(fcallable (,conv* ...) ,[e #f -> e] (,arg-type* ...) ,result-type)
        `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)]
      [(call ,preinfo0
         (case-lambda ,preinfo1
           (clause (,x* ...) ,interface ,body)
           ,cl* ...)
         ,[e* #f -> e*] ...)
       (guard (fx= (length e*) interface))
       `(call ,preinfo0
          (case-lambda ,preinfo1
            (clause (,x* ...) ,interface
              ,(with-record-lambda x* e* (Expr body ctxt))))
          ,e* ...)]
      [(call ,preinfo ,e ,[e* #f -> e*] ...)
       (let ([sexpr (preinfo-sexpr preinfo)])
         (define ugly-gensym? ; gensym w/no pretty name
           (lambda (x)
             (and (gensym? x)
                  (let ([name ($symbol-name x)])
                    (or (not (pair? name)) (not (cdr name)))))))
         (if (and sexpr (and (pair? sexpr) (not (ugly-gensym? (car sexpr)))))
             (let ([ctxt (make-call-context (length e*))])
               (let ([e (Expr e ctxt)])
                 (if (call-context-err ctxt)
                     (argcnt-error preinfo e e*)
                     `(call ,preinfo ,e ,e* ...))))
             `(call ,preinfo ,(Expr e #f) ,e* ...)))]
      [(case-lambda ,preinfo (clause (,x** ...) ,interface* ,[body* #f -> body*]) ...)
       (check! ctxt interface*)
       `(case-lambda ,preinfo (clause (,x** ...) ,interface* ,body*) ...)]
      [(letrec ([,x* ,e*] ...) ,body)
       (with-record-lambda x* e*
         `(letrec ([,x* ,(map (lambda (e) (Expr e #f)) e*)] ...)
            ,(Expr body ctxt)))]
      [,pr (let ([arity (primref-arity pr)]) (when arity (check! ctxt arity))) pr]
      [(record-ref ,rtd ,type ,index ,[e #f -> e])
       `(call ,(make-preinfo) ,(lookup-primref 3 '$object-ref)
          (quote ,type) ,e (quote ,(record-field-offset rtd index)))]
      [(record-set! ,rtd ,type ,index ,[e1 #f -> e1] ,[e2 #f -> e2])
       `(call ,(make-preinfo) ,(lookup-primref 3 '$object-set!)
          (quote ,type) ,e1 (quote ,(record-field-offset rtd index)) ,e2)]
      [(record ,rtd ,[rtd-expr #f -> rtd-expr] ,[e* #f -> e*] ...)
       (let ([rtd (maybe-remake-rtd rtd)])
         (let ([fld* (rtd-flds rtd)] [rec-t (make-prelex*)])
           (safe-assert (fx= (length e*) (length fld*)))
           (let ([filler* (fold-right
                            (lambda (fld e filler*)
                              (let ([type (fld-type fld)])
                                (if (eq? (filter-foreign-type type) 'scheme-object)
                                    filler*
                                    (cons
                                      `(call ,(make-preinfo) ,(lookup-primref 3 '$object-set!)
                                         (quote ,type) (ref #f ,rec-t) (quote ,(fld-byte fld)) ,e)
                                      filler*))))
                            '() fld* e*)])
             (if (null? filler*)
                 `(call ,(make-preinfo) ,(lookup-primref 3 '$record) ,rtd-expr ,e* ...)
                 (begin
                   (set-prelex-referenced! rec-t #t)
                   (set-prelex-multiply-referenced! rec-t #t)
                   `(call ,(make-preinfo)
                      (case-lambda ,(make-preinfo-lambda)
                        (clause (,rec-t) 1 ,(build-sequence filler* `(ref #f ,rec-t))))
                      (call ,(make-preinfo) ,(lookup-primref 3 '$record) ,rtd-expr
                        ,(map (lambda (arg) (cond [(eqv? arg 0) `(quote 0)] [else arg]))
                           (make-record-call-args fld* (rtd-size rtd) e*))
                        ...)))))))]
      [(cte-optimization-loc ,box ,[e #f -> e]) e]
      [(immutable-list (,e* ...) ,[e]) e]
      [(moi) ir]
      [(pariah) ir]
      [(profile ,src) ir]
      [else (sorry! who "unhandled record ~s" ir)]))

  (lambda (x) (cpcheck x))))