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
This diff is collapsed.
(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