Skip to content
Snippets Groups Projects
asdf.lisp 46.7 KiB
Newer Older
						(pathname-sans-name+type
						 (resolve-symlinks 
						  *load-truename*)))
					      *default-pathname-defaults*))
				    ',component-options))))))
Daniel Barlow's avatar
 
Daniel Barlow committed
  

(defun class-for-type (parent type)
  (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
                              (find-symbol (symbol-name type) 
         (class (dolist (symbol (if (keywordp type)
                                    extra-symbols
                                    (cons type extra-symbols)))
                  (when (and symbol 
                             (find-class symbol nil)
                             (subtypep symbol 'component))
                    (return (find-class symbol))))))
    (or class
	(and (eq type :file)
	     (or (module-default-component-class parent)
		 (find-class 'cl-source-file)))
	(sysdef-error "~@<don't recognize component type ~A~@:>" type))))

(defun maybe-add-tree (tree op1 op2 c)
  "Add the node C at /OP1/OP2 in TREE, unless it's there already.
Returns the new tree (which probably shares structure with the old one)"
  (let ((first-op-tree (assoc op1 tree)))
    (if first-op-tree
	(progn
	  (aif (assoc op2 (cdr first-op-tree))
	       (if (find c (cdr it))
		   nil
		   (setf (cdr it) (cons c (cdr it))))
	       (setf (cdr first-op-tree)
		     (acons op2 (list c) (cdr first-op-tree))))
	  tree)
	(acons op1 (list (list op2 c)) tree))))
		
(defun union-of-dependencies (&rest deps)
  (let ((new-tree nil))
    (dolist (dep deps)
      (dolist (op-tree dep)
	(dolist (op  (cdr op-tree))
	  (dolist (c (cdr op))
	    (setf new-tree
		  (maybe-add-tree new-tree (car op-tree) (car op) c))))))
    new-tree))

(defun remove-keys (key-names args)
  (loop for ( name val ) on args by #'cddr
	unless (member (symbol-name name) key-names 
		       :key #'symbol-name :test 'equal)
	append (list name val)))

(defun parse-component-form (parent options)
  (destructuring-bind
Daniel Barlow's avatar
Daniel Barlow committed
	(type name &rest rest &key
	      ;; the following list of keywords is reproduced below in the
	      ;; remove-keys form.  important to keep them in sync
	      components pathname default-component-class
	      perform explain output-files operation-done-p
	      weakly-depends-on
Daniel Barlow's avatar
Daniel Barlow committed
	      ;; list ends
	      &allow-other-keys) options
    (declare (ignorable perform explain output-files operation-done-p)) 
    (check-component-input type name weakly-depends-on depends-on components in-order-to)

    (when (and parent
	     (find-component parent name)
	     ;; ignore the same object when rereading the defsystem
	     (not 
	      (typep (find-component parent name)
		     (class-for-type parent type))))	     
      (error 'duplicate-names :name name))
    
    (let* ((other-args (remove-keys
			'(components pathname default-component-class
			  perform explain output-files operation-done-p
			  weakly-depends-on
			  depends-on serial in-order-to)
			rest))
	   (ret
	    (or (find-component parent name)
		(make-instance (class-for-type parent type)))))
      (when weakly-depends-on
	(setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
      (when (boundp '*serial-depends-on*)
	(setf depends-on
	      (concatenate 'list *serial-depends-on* depends-on)))      
      (apply #'reinitialize-instance
	     ret
	     :name (coerce-name name)
	     :pathname pathname
	     :parent parent
	     other-args)
      (when (typep ret 'module)
	(setf (module-default-component-class ret)
	      (or default-component-class
		  (and (typep parent 'module)
		       (module-default-component-class parent))))
	(let ((*serial-depends-on* nil))
	  (setf (module-components ret)
		(loop for c-form in components
		      for c = (parse-component-form ret c-form)
		      collect c
		      if serial
		      do (push (component-name c) *serial-depends-on*))))

	;; check for duplicate names
	(let ((name-hash (make-hash-table :test #'equal)))
	  (loop for c in (module-components ret)
		do
		(if (gethash (component-name c)
			     name-hash)
		    (error 'duplicate-names
			   :name (component-name c))
		  (setf (gethash (component-name c)
				 name-hash)
			t)))))
      
      (setf (slot-value ret 'in-order-to)
	    (union-of-dependencies
	     in-order-to
	     `((compile-op (compile-op ,@depends-on))
	       (load-op (load-op ,@depends-on))))
	    (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
      
      (%remove-component-inline-methods ret rest)

(defun %remove-component-inline-methods (ret rest)
  (loop for name in +asdf-methods+
     do (map 'nil
	     ;; this is inefficient as most of the stored
	     ;; methods will not be for this particular gf n
	     ;; But this is hardly performance-critical
	     (lambda (m)
	       (remove-method (symbol-function name) m))
	     (component-inline-methods ret)))
  ;; clear methods, then add the new ones
  (setf (component-inline-methods ret) nil)
  (loop for name in +asdf-methods+
     for v = (getf rest (intern (symbol-name name) :keyword))
     when v do
     (destructuring-bind (op qual (o c) &body body) v
       (pushnew
	(eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
			  ,@body))
	(component-inline-methods ret)))))

(defun check-component-input (type name weakly-depends-on depends-on components in-order-to)
  "A partial test of the values of a component."
  (when weakly-depends-on (warn "We got one! XXXXX"))
  (unless (listp depends-on)
Kevin Rosenberg's avatar
Kevin Rosenberg committed
    (sysdef-error-component ":depends-on must be a list."
			    type name depends-on))
  (unless (listp weakly-depends-on)
    (sysdef-error-component ":weakly-depends-on must be a list."
			    type name weakly-depends-on))
Kevin Rosenberg's avatar
Kevin Rosenberg committed
  (unless (listp components)
    (sysdef-error-component ":components must be NIL or a list of components."
			    type name components))
  (unless (and (listp in-order-to) (listp (car in-order-to)))
    (sysdef-error-component ":in-order-to must be NIL or a list of components."
Kevin Rosenberg's avatar
Kevin Rosenberg committed
			   type name in-order-to)))

(defun sysdef-error-component (msg type name value)
  (sysdef-error (concatenate 'string msg
			     "~&The value specified for ~(~A~) ~A is ~W")
		type name value))
Daniel Barlow's avatar
Daniel Barlow committed

(defun resolve-symlinks (path)
  #-allegro (truename path)
  #+allegro (excl:pathname-resolve-symbolic-links path)
  )
Daniel Barlow's avatar
Daniel Barlow committed
;;; optional extras

;;; run-shell-command functions for other lisp implementations will be
;;; gratefully accepted, if they do the same thing.  If the docstring
;;; is ambiguous, send a bug report

Daniel Barlow's avatar
Daniel Barlow committed
(defun run-shell-command (control-string &rest args)
  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell, with
output to *VERBOSE-OUT*.  Returns the shell's exit code."
Daniel Barlow's avatar
Daniel Barlow committed
  (let ((command (apply #'format nil control-string args)))
    (format *verbose-out* "; $ ~A~%" command)
    (sb-ext:process-exit-code
Daniel Barlow's avatar
Daniel Barlow committed
     (sb-ext:run-program  
      #+win32 "sh" #-win32 "/bin/sh"
Daniel Barlow's avatar
Daniel Barlow committed
      (list  "-c" command)
      #+win32 #+win32 :search t
Daniel Barlow's avatar
Daniel Barlow committed
    (ext:process-exit-code
     (ext:run-program  
      "/bin/sh"
      (list  "-c" command)
    (excl:run-shell-command command :input nil :output *verbose-out*)
    
    #+lispworks
    (system:call-system-showing-output
     command
     :shell-type "/bin/sh"
    #+clisp				;XXX not exactly *verbose-out*, I know
    (ext:run-shell-command  command :output :terminal :wait t)

    #+openmcl
	       (ccl:external-process-status
		(ccl:run-program "/bin/sh" (list "-c" command)
    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
    (si:system command)
    #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl)
    (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
    ))

(defgeneric hyperdocumentation (package name doc-type))
(defmethod hyperdocumentation ((package symbol) name doc-type)
  (hyperdocumentation (find-package package) name doc-type))

(defun hyperdoc (name doc-type)
  (hyperdocumentation (symbol-package name) name doc-type))

(defun system-source-file (system-name)
  (let ((system (asdf:find-system system-name)))
    (make-pathname 
     :type "asd"
     :name (asdf:component-name system)
     :defaults (asdf:component-relative-pathname system))))

(defun system-source-directory (system-name)
  (make-pathname :name nil
                 :type nil
                 :defaults (system-source-file system-name)))

(defun system-relative-pathname (system pathname &key name type)
  (let ((directory (pathname-directory pathname)))
    (when (eq (car directory) :absolute)
      (setf (car directory) :relative))
    (merge-pathnames
     (make-pathname :name (or name (pathname-name pathname))
                    :type (or type (pathname-type pathname))
                    :directory directory)
     (system-source-directory system))))

Daniel Barlow's avatar
Daniel Barlow committed
(pushnew :asdf *features*)

#+sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)
  (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
    (pushnew :sbcl-hooks-require *features*)))

#+(and sbcl sbcl-hooks-require)
(progn
  (defun module-provide-asdf (name)
    (handler-bind ((style-warning #'muffle-warning))
      (let* ((*verbose-out* (make-broadcast-stream))
	     (system (asdf:find-system name nil)))
	(when system
	  (asdf:operate 'asdf:load-op name)
	  t))))
  (defun contrib-sysdef-search (system)
    (let ((home (sb-ext:posix-getenv "SBCL_HOME")))
      (when home
        (let* ((name (coerce-name system))
               (home (truename home))
               (contrib (merge-pathnames
                         (make-pathname :directory `(:relative ,name)
                                        :name name
                                        :type "asd"
                                        :case :local
                                        :version :newest)
                         home)))
          (probe-file contrib)))))
   '(let ((home (sb-ext:posix-getenv "SBCL_HOME")))
      (when home
        (merge-pathnames "site-systems/" (truename home))))
   *central-registry*)
  
  (pushnew
   '(merge-pathnames ".sbcl/systems/"
     (user-homedir-pathname))
   *central-registry*)
  
  (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
  (pushnew 'contrib-sysdef-search *system-definition-search-functions*))