;;;; -*- 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>