;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               too-early.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    A proof-of-concept-so-far tracing CL package.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2012-04-19 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;;    AGPL3
;;;;
;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
;;;;
;;;;    This program is free software: you can redistribute it and/or modify
;;;;    it under the terms of the GNU Affero General Public License as published by
;;;;    the Free Software Foundation, either version 3 of the License, or
;;;;    (at your option) any later version.
;;;;
;;;;    This program is distributed in the hope that it will be useful,
;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;;    GNU Affero General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU Affero General Public License
;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
;;;;

(defpackage "COM.INFORMATIMAGO.COMMON-LISP.TRACING-COMMON-LISP"
  (:nicknames "TRACING-COMMON-LISP" "TRACING-CL" "TOO-EARLY")
  (:use "COMMON-LISP"
        "COM.INFORMATIMAGO.COMMON-LISP.LISP-SEXP.SOURCE-FORM")
  (:shadow "LET" "LET*" "SETQ" "SETF"))
(in-package "COM.INFORMATIMAGO.COMMON-LISP.TRACING-COMMON-LISP")


(defmacro trace-places (op &rest places)
  `(progn
     ,@(mapcar (lambda (place)
                 `(format *trace-output*
                         "~&After ~8S  ~12S = ~S~%" ',op
                         ',(if (listp place) (first place) place)
                         ,(if (listp place) (second place) place)))
               places)))


(defmacro LET (bindings &body body)
  `(cl:let ,bindings
     (trace-places cl:let ,@(mapcar (lambda (binding) (if (listp binding) (first binding) binding))
                                    bindings))
     ,@body))


(defmacro LET* (bindings &body body)
  (if (null bindings)
      `(progn ,@body)
      `(cl:let (,(first bindings))
         (trace-places cl:let* ,(if (listp (first bindings)) (first (first bindings)) (first bindings)))
         (let* ,(cdr bindings)
           ,@body))))


(defmacro SETQ (&rest var-vals)
  (if (null var-vals)
      `(cl:setq)
      (destructuring-bind (var val &rest others) var-vals
        (if others
            `(progn
               (cl:setq ,var ,val)
               (trace-places cl:setq ,var)
               (setq ,@others))
            `(prog1
                 (cl:setq ,var ,val)
               (trace-places cl:setq ,var))))))


(defmacro SETF (&rest place-vals)
  (flet ((gen-setf (place val)
           (multiple-value-bind (dummies vals new setter getter) (get-setf-expansion place)
             (when (cdr new) (error "Can't expand ~S" place))
             `(cl:let* (,@(mapcar #'list dummies vals)
                     (,(car new) ,getter))
                (multiple-value-prog1
                    (cl:setf ,setter ,val)
                  (trace-places cl:setf ,(list place getter)))))))
    (if (null place-vals)
        `(cl:setf)
        (destructuring-bind (place val &rest others) place-vals
          (if others
              `(progn
                 ,(gen-setf place val)
                 (setf ,@others))
              (gen-setf place val))))))



(defun make-argument-list (lambda-list)
  (cl:let ((lambda-list (parse-lambda-list lambda-list)))
    (values (append
             (mapcar (function parameter-name) (lambda-list-mandatory-parameters lambda-list))
             (mapcar (function parameter-name) (lambda-list-optional-parameters lambda-list))
             (cond
               ((lambda-list-keyword-parameters lambda-list)
                (mapcan (lambda (parameter)
                          (list (ENSURE-PARAMETER-KEYWORD parameter) (parameter-name parameter)))
                        (lambda-list-keyword-parameters lambda-list)))

               (t '())))
            (when (lambda-list-rest-parameter-p lambda-list)
              (parameter-name (lambda-list-rest-parameter lambda-list)))
            (append
             (mapcar (function parameter-name) (lambda-list-mandatory-parameters lambda-list))
             (mapcar (function parameter-name) (lambda-list-optional-parameters lambda-list))
             (cond
               ((lambda-list-keyword-parameters lambda-list)
                (mapcan (lambda (parameter)
                          (list (ENSURE-PARAMETER-KEYWORD parameter) (parameter-name parameter)))
                        (lambda-list-keyword-parameters lambda-list)))
               ((lambda-list-rest-parameter-p lambda-list)
                (list (parameter-name (lambda-list-rest-parameter lambda-list))))
               (t '()))))))


(defun make-test-call (defun-form bindings)
  (if (and (listp defun-form)
           (eq 'defun (first defun-form))
           (symbolp (second defun-form))
           (listp (third defun-form)))
      `(cl:let ,bindings
         ,(multiple-value-bind (arguments rest) (make-argument-list (third defun-form))
                               (if rest
                                   `(apply (function ,(second defun-form)) ,@arguments ,rest)
                                   `(,(second defun-form) ,@arguments))))
      `(progn)))

(declaim (inline make-test-call))


(defun eval-and-trace (defun-text &optional bindings)
  (cl:multiple-value-bind (form error)
      (ignore-errors (values
                      (cl:let* ((*package* (find-package "TRACING-CL")))
                        (read-from-string defun-text))))
    (or error
        (cl:multiple-value-bind (results error)
            (ignore-errors (multiple-value-list (eval form)))
          (if error
              (values error nil
                      (nth-value 2 (make-argument-list (third form))))
              (values nil results
                      (nth-value 2 (make-argument-list (third form)))
                      (ignore-errors (multiple-value-list (eval (make-test-call form bindings))))))))))


;; (eval-and-trace "(defun f (x) (if (zerop x) x (* x (f (1- x)))))")
;; nil
;; (f)
;; (x)
;; nil
;;
;; (eval-and-trace "(defun f (x) (if (zerop x) x (* x (f (1- x)))))"
;;                 '((x 42)))
;; nil
;; (f)
;; (x)
;; (0)
;;
;; (eval-and-trace "(defun f (x) (if (zerop x) 1 (* x (f (1- x)))))"
;;                 '((x 42)))
;; nil
;; (f)
;; (x)
;; (1405006117752879898543142606244511569936384000000000)


;; (eval-and-trace "(defun g (a b) (let ((c (+ a b))) (* c c)))")
;; ;Compiler warnings :
;; ;   In an anonymous lambda form: Undeclared free variable a
;; ;   In an anonymous lambda form: Undeclared free variable b
;; nil
;; (g)
;; (a b)
;; nil
;;
;; (eval-and-trace "(defun g (a b) (let ((c (+ a b))) (* c c)))"
;;                 '((a 2) (b 3)))
;;
;; After common-lisp:let,  c            = 5
;; nil
;; (g)
;; (a b)
;; (5)


;; tracing-common-lisp>  (eval-and-trace "(defun f (x) (if (zerop x) 1 (let ((r (* x (f (1- x))))) r)))"
;;                                       '((x 10)))
;; After common-lisp:let  r            = 1
;; After common-lisp:let  r            = 2
;; After common-lisp:let  r            = 6
;; After common-lisp:let  r            = 24
;; After common-lisp:let  r            = 120
;; After common-lisp:let  r            = 720
;; After common-lisp:let  r            = 5040
;; After common-lisp:let  r            = 40320
;; After common-lisp:let  r            = 362880
;; After common-lisp:let  r            = 3628800
;; nil
;; (f)
;; (x)
;; (3628800)
;; tracing-common-lisp>
ViewGit