Skip to content
Snippets Groups Projects
asdf.lisp 43.6 KiB
Newer Older
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
    (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))))
      
      (loop for (n v) in `((perform ,perform) (explain ,explain)
			   (output-files ,output-files)
			   (operation-done-p ,operation-done-p))
	    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 n) m))
		    (component-inline-methods ret))
	    when v
	    do (destructuring-bind (op qual (o c) &body body) v
		 (pushnew
		  (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
			  ,@body))
		  (component-inline-methods ret))))
      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))


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