Commit 9f8b6e77 authored by Andreas Fuchs's avatar Andreas Fuchs

switch from bzr

parents
;;; -*- Mode: Lisp -*-
(cl:defpackage #:asdf-dependency-grovel.system
(:use :asdf :cl))
(cl:in-package #:asdf-dependency-grovel.system)
(defsystem asdf-dependency-grovel
:components ((:file "package")
(:file "variables" :depends-on ("package"))
(:file "grovel" :depends-on ("package" "variables"))
(:file "asdf-ops" :depends-on ("package" "variables" "grovel"))))
\ No newline at end of file
(cl:in-package #:asdf-dependency-grovel)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass instrumented-cl-source-file (asdf:cl-source-file) ()))
(defmethod asdf:output-files :around ((op asdf:compile-op) (comp instrumented-cl-source-file))
"Put instrumented FASL files in a temporary directory relative
to the base of the system."
(let* ((output-file (car (call-next-method)))
(system-base-dir *default-pathname-defaults*)
(dir-component (subseq (pathname-directory output-file)
(or (mismatch (pathname-directory output-file)
(pathname-directory system-base-dir)
:test #'equal)
(length (pathname-directory output-file))))))
(list
(if (and (boundp '*old-macroexpand-hook*)
*old-macroexpand-hook*)
(merge-pathnames (make-pathname :directory `(,@(pathname-directory system-base-dir)
,(format nil "asdf-dependency-grovel-tmp-~A"
*grovel-dir-suffix*)
,@dir-component)
:defaults output-file)
system-base-dir)
output-file))))
(defmethod asdf:perform :around ((op asdf:load-op) (comp instrumented-cl-source-file))
(let ((*current-component* comp))
(call-next-method)))
(defmethod asdf:perform :around ((op asdf:compile-op) (comp instrumented-cl-source-file))
(let* ((*current-component* comp))
(call-next-method)))
;;; TODO for asdf-component/op:
;;; * ignore component-name. I have no idea what it /should/ indicate.
(defclass component-file (asdf:source-file)
((load-system :initarg :load-system)
(merge-systems :initarg :merge-systems)
(additional-dependencies :initarg :additional-dependencies :initform nil)
(component-name-translation :initarg :component-name-translation :initform nil)
(cull-redundant :initarg :cull-redundant :initform nil)
(verbose :initarg :verbose :initform t)
(output-file :initarg :output-file)))
(defclass dependency-op (asdf:operation)
())
(defmethod asdf:source-file-type ((c component-file) (s asdf:module))
"asd")
(defmethod asdf:output-files ((op dependency-op) (c component-file))
(list
(merge-pathnames (slot-value c 'output-file)
(asdf:component-pathname c))))
(defmethod asdf:input-files ((op dependency-op) (c component-file))
(asdf:component-pathname c))
(defmethod asdf:operation-done-p ((op dependency-op) (comp component-file))
nil)
(defmethod asdf:perform ((op dependency-op) (c component-file))
(with-open-file (clim-components (merge-pathnames (slot-value c 'output-file)
(asdf:component-pathname c))
:direction :output
:if-does-not-exist :create :if-exists :supersede)
(with-slots (load-system merge-systems
component-name-translation cull-redundant verbose
additional-dependencies) c
(grovel-dependencies load-system clim-components
:interesting (mapcar #'asdf:find-system merge-systems)
:component-name-translation component-name-translation
:additional-dependencies additional-dependencies
:cull-redundant cull-redundant
:verbose verbose))))
\ No newline at end of file
;;; ADSF dependency groveler using macroexpand-hook. Fairly precise,
;;; at least for the mcclim system.
;;; TODO:
;; * handle more def*:
;; * defvar & defparameter - fails because of special declarations.
;; if it worked, it would be the same as defconstant.
;; * define-compiler-macro - argh. seriously, no idea. if you use
;; this at compile/load time, sorry.
;; * deftype - we can signal that it was provided, but have to walk
;; declarations in def* and generally almost /everwhere/. not fun.
;; * more package games: :use, :import-from, :shadow?
(cl:in-package #:asdf-dependency-grovel)
;;; macroexpand hook and helper functions/macros
(defun canonical-package-name (package-designator)
(intern (typecase package-designator
(package (package-name package-designator))
(t (string package-designator)))
:asdf-dependency-grovel.packages))
(defun signal-macroexpansion (hook name macro-type &optional (component *current-component*))
(when (and hook component)
(funcall hook name macro-type component)))
(defun signal-symbol-use-in-form (form)
(labels ((signal-for-symbol (sym)
(unless (or (null (symbol-package sym))
(member (symbol-package sym)
(mapcar #'find-package '(:keyword :cl))))
(signal-macroexpansion *user-hook* (canonical-package-name (symbol-package sym)) 'defpackage))))
(cond ((symbolp form) (signal-for-symbol form))
((consp form)
(loop for (car . cdr) on form
do (signal-symbol-use-in-form car)
if (symbolp cdr)
do (signal-for-symbol cdr))))))
(defun signal-symbol-macroexpansion (name expansion)
(signal-macroexpansion *user-hook* name 'define-symbol-macro)
expansion)
(defsetf signal-symbol-macroexpansion (name expression) (new-value)
`(progn
(signal-macroexpansion *user-hook* ',name 'define-symbol-macro)
(setf ,expression ,new-value)))
(defmacro symbol-macroify (operator name &rest args &environment env)
(let ((new-name (gentemp)))
`(progn
(define-symbol-macro ,name ,new-name)
,(macroexpand-1 `(,operator ,new-name ,@args) env))))
(defmacro define-symbol-alias (new-symbol ansi-symbol)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(when (and (boundp '*symbol-translations*) (hash-table-p *symbol-translations*))
(setf (gethash ',new-symbol *symbol-translations*) ',ansi-symbol))))
(defun unalias-symbol (form)
(if (boundp '*symbol-translations*)
(or (gethash form *symbol-translations*)
form)
form))
(defun instrument-defun-body (body form)
"Insert FORM into list of defun body forms BODY such that the
return value of BODY is the same as it would be without FORM,
keeping declarations intact."
`(,@
(when (stringp (first body))
(list (pop body)))
,@(loop for (elt . body) on (or body (list nil))
if (or (and (listp elt)
(not (eql (first elt) 'declare)))
(not (listp elt)))
collect form
and collect elt
and append body
and do (loop-finish)
if (null body)
collect elt
and collect form
and collect nil
and do (loop-finish)
collect elt)))
(defun instrumenting-macroexpand-hook (fun form env)
(when (listp form)
(case (unalias-symbol (first form))
((defmacro define-method-combination)
(signal-macroexpansion *provider-hook* (second form) (first form)))
((defsetf define-setf-expander)
(signal-macroexpansion *provider-hook* (second form) 'setf))
((setf)
(when (listp (second form))
(signal-macroexpansion *user-hook* (first (second form)) 'setf)))
((defgeneric)
(signal-macroexpansion *provider-hook* (second form) 'defgeneric)
(let ((method-combination (second (assoc :method-combination (nthcdr 3 form)))))
(when method-combination
(signal-macroexpansion *user-hook* method-combination 'define-method-combination))))
((defmethod)
(signal-macroexpansion *user-hook* (second form) 'defgeneric)
;; walk arg list and signal use of specialized-on
;; classes, and instrument function body.
(let* ((*macroexpand-hook* *old-macroexpand-hook*)
(name (second form))
(new-expansion
`(defmethod ,name
,@(loop for (elt . body) on (nthcdr 2 form)
if (not (listp elt))
collect elt into modifiers
else
do (signal-macroexpansion *provider-hook* `(,name ,@modifiers ,elt) 'defmethod)
and do
(loop for arg in elt
when (and (listp arg)
(symbolp (second arg)))
do (signal-macroexpansion *user-hook* (second arg) 'defclass))
and collect elt into modifiers
and collect elt
and append (instrument-defun-body body
`(signal-macroexpansion
*user-hook*
'(,name ,@modifiers)
'defmethod))
and do (loop-finish)
collect elt))))
;; (format *debug-io* "~&~S becomes:~&~S~%~%" form new-expansion)
(return-from instrumenting-macroexpand-hook
(funcall *old-macroexpand-hook* fun new-expansion env))))
((defclass define-condition)
(signal-macroexpansion *provider-hook* (second form) (first form))
;; signal use of direct
;; superclasses/superconditions. Note that we
;; declare a dependency only if the direct
;; superclass is already defined through the
;; current system definition.
(loop for superclass in (third form)
do (signal-macroexpansion *user-hook* superclass (first form))))
((defstruct)
(signal-macroexpansion *provider-hook* (second form) 'defclass))
((defpackage)
(signal-macroexpansion *provider-hook* (canonical-package-name (second form)) 'defpackage)
(loop for nickname in (rest (assoc :nicknames (nthcdr 2 form)))
do (signal-macroexpansion *provider-hook* nickname 'defpackage)))
((in-package)
(signal-macroexpansion *user-hook* (canonical-package-name (second form)) 'defpackage))
((defconstant)
(signal-macroexpansion *provider-hook* (second form) (first form))
(return-from instrumenting-macroexpand-hook
(let ((*macroexpand-hook* *old-macroexpand-hook*))
(funcall *old-macroexpand-hook* (macro-function 'symbol-macroify)
`(symbol-macroify ,@form) env))))
((define-symbol-macro)
(destructuring-bind (def name expansion) form
(signal-macroexpansion *provider-hook* name def)
(return-from instrumenting-macroexpand-hook
(let ((*macroexpand-hook* *old-macroexpand-hook*))
(funcall *old-macroexpand-hook* fun
`(,def ,name (signal-symbol-macroexpansion ',name ,expansion))
env)))))
((defun)
(destructuring-bind (defun name arg-list &rest maybe-body) form
(signal-macroexpansion *provider-hook* name (first form))
(let ((*macroexpand-hook* *old-macroexpand-hook*))
(return-from instrumenting-macroexpand-hook
(funcall *old-macroexpand-hook* fun
`(,defun ,name ,arg-list
,@(instrument-defun-body maybe-body
`(signal-macroexpansion *user-hook* ',name 'defun)))
env)))))
(otherwise (signal-macroexpansion *user-hook* (first form) 'defmacro))))
(signal-symbol-use-in-form form)
(funcall *old-macroexpand-hook* fun form env))
;;; The actual groveling part.
(defun enough-component-spec (c &optional pn-p)
(if (equal (parse-namestring (enough-namestring (asdf:component-pathname c)))
(make-pathname :name (asdf:component-name c) :type "lisp"))
(format nil "~S" (asdf:component-name c))
(let ((pn (parse-namestring (enough-namestring (asdf:component-pathname c)))))
(format nil "~S~:[~; :pathname #.(make-pathname :directory '~S :name ~S :type \"lisp\")~%~]"
(enough-namestring (make-pathname :type nil :defaults (asdf:component-pathname c)))
pn-p
(pathname-directory pn)
(pathname-name pn)))))
(defun system-file-components (system)
(loop for component in (asdf:module-components system)
if (typep component 'asdf:module)
append (system-file-components component)
else
collect component))
(defun grovel-dependencies (system stream &key
interesting override-dependencies additional-dependencies verbose
component-name-translation cull-redundant)
(let* ((system (asdf:find-system system))
(providers (make-hash-table :test #'equal))
(dependencies (make-hash-table :test #'eql))
(*old-macroexpand-hook* *macroexpand-hook*)
(*macroexpand-hook* #'instrumenting-macroexpand-hook)
(*symbol-translations* (make-hash-table))
(*default-pathname-defaults* (truename
(make-pathname :type nil :name nil
:defaults (asdf:component-pathname system))))
(*grovel-dir-suffix* (get-universal-time)))
(labels ((interestingp (component)
(member (asdf:component-system component) interesting :test #'eql))
(component-name (component &optional pn-p)
(or (let ((translated-name (assoc (enough-component-spec component) component-name-translation
:test #'equal)))
(if pn-p
(third translated-name)
(second translated-name)))
(enough-component-spec component pn-p)))
(redundantp (from to)
(labels ((redundantp-1 (from-1)
(let ((from-deps (gethash from-1 dependencies)))
(cond ((and (member to from-deps) (not (eql from from-1))) t)
(t (dolist (from-dep from-deps)
(when (redundantp-1 from-dep)
(return-from redundantp t)))
nil)))))
(redundantp-1 from)))
(new-dep (from to-components)
(when (and (interestingp from)
(some #'interestingp to-components))
(setf (gethash from dependencies)
(remove-duplicates (append (remove-if-not #'interestingp to-components)
(gethash from dependencies)))))))
(let ((*provider-hook*
(lambda (name type component)
(pushnew component (gethash (list type name) providers))))
(*user-hook*
(lambda (name type component)
(cond ((and (gethash (list type name) providers)
(not (member component (gethash (list type name) providers))))
(new-dep component (gethash (list type name) providers)))))))
(let ((*compile-print* verbose)
(*compile-verbose* verbose)
;; (*break-on-signals* 'warning)
)
(asdf:oos 'asdf:load-op system :verbose verbose))
(let ((*print-case* :downcase))
(format stream "~@<;;; ~@;AUTO-GENERATED file from system definition of system ~A in ~
~A.
Instead of directly editing this file, please edit the system definition~P of~
~{ ~A~^ or~}, then re-generate this file.~:@>"
(asdf:component-name system)
(make-pathname :directory nil :defaults (asdf:component-pathname system))
(length interesting) (mapcar #'asdf:component-name interesting))
(format stream "~&(~%")
(dolist (system interesting)
(format stream "~&;; ex ~A~%" (asdf:component-name system))
(loop for component in (system-file-components system)
for 1-dependencies = (gethash component dependencies)
do (let ((*package* (find-package :keyword)))
(format stream "~& (~S ~A :depends-on ~:A)~%"
(if (eql (class-of component)
(find-class (or (asdf::module-default-component-class (asdf:component-parent component))
'asdf:cl-source-file)))
:file
(class-name (class-of component)))
(component-name component t)
`(,@(sort
`(,@(or (cdr (assoc (enough-component-spec component) override-dependencies
:test #'equal))
(mapcar #'component-name
(remove-if (lambda (comp)
(and cull-redundant (redundantp component comp)))
1-dependencies)))
,@(cdr (assoc (enough-component-spec component) additional-dependencies
:test #'equal)))
#'string<))))))
(format stream "~&)~%"))))))
(cl:defpackage #:asdf-dependency-grovel
(:use #:cl)
(:export #:component-file #:dependency-op #:instrumented-cl-source-file
#:define-symbol-alias))
(cl:defpackage #:asdf-dependency-grovel.packages
(:use))
\ No newline at end of file
(cl:defpackage :test-asdf-dependency-grovel
(:use :cl)
(:export #:test-result))
(cl:in-package :test-asdf-dependency-grovel)
(define-condition failed-component ()
((file :accessor failed-file :initarg :file)
(should :accessor failed-dependency :initarg :should)
(has :accessor actual-dependency :initarg :has)))
(defun canonicalize-name (name)
(subseq name (mismatch "u-" name) (position #\. name)))
(defun 1-component (&key file depends-on)
(when (eql 2 (mismatch "u-" file))
(let* ((name (canonicalize-name file))
(dependency (list (format nil "p-~A" name)))
(depends-on (remove "package" depends-on :test #'equal)))
(unless (equal dependency depends-on)
(error 'failed-component
:file file :should dependency
:has depends-on)))))
(load "test-serial.asd")
(asdf:oos 'asdf-dependency-grovel:dependency-op :asdf-dependency-grovel-test/generator)
(defun test-result ()
(with-open-file (f "groveled-components.lisp" :direction :input)
(let ((comps (read f))
(failed nil))
(loop for comp in comps
do (handler-case (apply #'1-component comp)
(failed-component (c)
(push (list (failed-file c) (failed-dependency c) (actual-dependency c))
failed))))
(if (null failed)
(format t "~&;;; ALL TESTS PASSED!~%")
(format t "~&;;; TESTS failed: ~:{~&;; ~A should have: ~S, has ~S~}~%" failed))
(length failed))))
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defclass test-defclass ()
())
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defconstant test-defconstant.1 1)
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defgeneric test-defgeneric ())
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(define-condition test-define-condition.1 () ())
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defun test-and (&rest operands)
(every #'identity operands))
(define-method-combination test-and.1 :identity-with-one-argument t)
(cl:in-package :asdf-dependency-grovel-test)
;;; from the define-setf-expander clhs example
(defun test-define-setf-expander.1 (x) (car (last x)))
(define-setf-expander test-define-setf-expander.1 (x &environment env)
"Set the last element in a list to the given value."
(multiple-value-bind (dummies vals newval setter getter)
(get-setf-expansion x env)
(let ((store (gensym)))
(values dummies
vals
`(,store)
`(progn (rplaca (last ,getter) ,store) ,store)
`(test-define-setf-expander.1 ,getter)))))
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defvar *things* (list 'alpha 'beta 'gamma))
(define-symbol-macro test-symbol-macro.1 (first *things*))
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defmacro test-defmacro.1 ()
`(print 'yay))
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defgeneric test-defmethod.1 (x))
(defmethod test-defmethod.1 (x) (declare (ignore x)))
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defpackage test-defpackage (:use :cl))
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defun test-defsetf.1 (l)
(first l))
(defsetf test-defsetf.1 rplaca)
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defstruct test-defstruct)
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defun test-defun.1 (x) (declare (ignore x)))
\ No newline at end of file
(cl:defpackage :asdf-dependency-grovel-test
(:use :cl))
\ No newline at end of file
#!/bin/sh
cd `dirname $0`
sbcl --load grovel-tests.lisp --eval '(sb-ext:quit :unix-status (test-asdf-dependency-grovel:test-result))'
STATUS=$?
rm -rf asdf-dependency-grovel-tmp-* groveled-components.lisp
exit $STATUS
\ No newline at end of file
;; -*- Mode: Lisp -*-
(cl:in-package :cl-user)
;; load groveler, for the component type, etc.
(eval-when (:load-toplevel :execute)
(asdf:oos 'asdf:load-op :asdf-dependency-grovel))
(defpackage :asdf-dependency-grovel-test.system
(:use :cl :asdf :asdf-dependency-grovel))
(in-package :asdf-dependency-grovel-test.system)
(defsystem :asdf-dependency-grovel-test/generator
:components ((component-file :asdf-dependency-grovel-test/serial
:load-system :asdf-dependency-grovel-test/serial
:merge-systems (:asdf-dependency-grovel-test/serial)
:output-file "groveled-components.lisp"
:cull-redundant nil
:verbose nil)))
(defsystem :asdf-dependency-grovel-test/serial
:default-component-class instrumented-cl-source-file
:serial t
:components (
(:file "package")
;; simple stuff
(:file "p-defmacro")
(:file "p-define-method-combination")
;; setf
(:file "p-define-setf-expander")
(:file "p-defsetf")
;; clos
(:file "p-defclass")
(:file "p-defstruct")
(:file "p-defgeneric")
(:file "p-defmethod")
(:file "p-define-condition")
;; package system
(:file "p-defpackage")
;; defunoids / instrumented stuff
(:file "p-defun")
(:file "p-define-symbol-macro")
(:file "p-defconstant")
;; users
;; simple stuff
(:file "u-defmacro")
(:file "u-define-method-combination")
;; setf
(:file "u-define-setf-expander")
(:file "u-defsetf")
;; clos
(:file "u-defclass.defclass")
(:file "u-defclass.defmethod")
(:file "u-defstruct.defmethod")
(:file "u-defgeneric")
(:file "u-defmethod")
(:file "u-define-condition")
;; package system
(:file "u-defpackage")
(:file "u-defpackage.1")
;; defunoids / instrumented stuff
(:file "u-defun")
(:file "u-define-symbol-macro")
(:file "u-defconstant")))
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defclass test-subclass (test-defclass)
())
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defgeneric test-specialized-method (a))
(defmethod test-specialized-method ((a test-defclass)))
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defvar test-defconstant-user.1 test-defconstant.1)
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defmethod test-defgeneric ()
1)
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(define-condition test-define-subcondition.1 (test-define-condition.1)
())
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defgeneric test-and-method-combination-gf.1 (operand)
(:method-combination test-and.1))
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar a (list 'a 'b 'c 'd))
(setf (test-define-setf-expander.1 a) 3))
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(eval-when (:compile-toplevel :load-toplevel :execute)
(print test-symbol-macro.1))
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(test-defmacro.1)
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(eval-when (:compile-toplevel :load-toplevel :execute)
(test-defmethod.1 1))
\ No newline at end of file
(cl:defvar test-defpackage::a 1)
(cl:in-package :test-defpackage)
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (test-defsetf.1 (list 'a 'b)) 1))
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defgeneric test-specialized-method.on-struct (a))
(defmethod test-specialized-method.on-struct ((a test-defstruct)))
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(eval-when (:compile-toplevel :load-toplevel :execute)
(test-defun.1 1))
\ No newline at end of file
(cl:in-package #:asdf-dependency-grovel)
(defvar *provider-hook* nil)
(defvar *user-hook* nil)
(defvar *old-macroexpand-hook* nil
"When the override macroexpand hook is active, this is bound to
the old value of *macroexpand-hook*.")
(defvar *current-component* nil
"The currently loaded/compiled ASDF component")
(defvar *symbol-translations* nil
"Hash table containing patched-symbol -> ansi-symbol translations")
(defvar *grovel-dir-suffix* nil
"Bound to a value that is unique once per operating on each
dependency-groveling system.")
\ No newline at end of file
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment