Newer
Older
Francois-Rene Rideau
committed
#+xcvb
(module (:depends-on ("utilities" "specials" "grain-interface" "external-commands")))
Francois-Rene Rideau
committed
(in-package :xcvb)
(define-simple-dispatcher text-for-xcvb-driver-command #'text-for-xcvb-driver-command-atom)
(defun text-for-xcvb-driver-command-atom (env foo)
Francois-Rene Rideau
committed
(error "Invalid xcvb-driver command atom ~S with environment ~S" foo env))
Francois-Rene Rideau
committed
(defun text-for-xcvb-driver-command (env clause)
(text-for-xcvb-driver-command-dispatcher env clause))
(define-text-for-xcvb-driver-command :load-file (env dep)
(format nil "(:load-file ~S)" (effective-namestring env dep)))
Francois-Rene Rideau
committed
(define-text-for-xcvb-driver-command :link-file (env dep)
(format nil "(:link-file ~S)" (effective-namestring env dep)))
Francois-Rene Rideau
committed
(define-text-for-xcvb-driver-command :require (env name)
(declare (ignore env))
(format nil "(:cl-require ~S)" name))
Francois-Rene Rideau
committed
(define-text-for-xcvb-driver-command :load-asdf (env name &key parallel)
(declare (ignore env))
(format nil "(:load-asdf ~(~S~)~@[ :parallel t~])" name parallel))
(define-text-for-xcvb-driver-command :initialize-asdf (env)
(declare (ignore env))
(format nil "(:initialize-asdf)"))
Francois-Rene Rideau
committed
(define-text-for-xcvb-driver-command :register-asdf-directory (env directory)
(declare (ignore env))
(format nil "(:register-asdf-directory ~S)" (namestring directory)))
(define-text-for-xcvb-driver-command :initialize-manifest (env manifest)
Francois-Rene Rideau
committed
(format nil "(:initialize-manifest ~S)"
(pseudo-effective-namestring env manifest)))
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
(define-text-for-xcvb-driver-command :load-manifest (env manifest)
(format nil "(:load-manifest ~S)"
(pseudo-effective-namestring env manifest)))
Francois-Rene Rideau
committed
(defun text-for-xcvb-driver-helper (env dependencies format &rest args)
(with-output-to-string (stream)
(format stream "(")
(apply #'format stream format args)
(dolist (dep dependencies)
(write-string (text-for-xcvb-driver-command env dep) stream))
(format stream ")")))
(define-text-for-xcvb-driver-command :compile-lisp (env name-options &rest dependencies)
(destructuring-bind (name &key around-compile encoding &aux (basename (second name)))
Francois-Rene Rideau
committed
(text-for-xcvb-driver-helper
env dependencies
":compile-lisp (~S ~S~@[ :cfasl ~S~]~@[ :lisp-object ~S~]~
~@[ :around-compile ~S~]~@[ :encoding ~S~])"
(effective-namestring env name)
(tempname-target (effective-namestring env `(:fasl ,basename)))
Peter Keller
committed
(tempname-target (effective-namestring env `(:cfasl ,basename))))
(when (target-ecl-p)
(tempname-target (effective-namestring env `(:lisp-object ,basename))))
around-compile encoding)))
Francois-Rene Rideau
committed
(define-text-for-xcvb-driver-command :create-image (env spec &rest dependencies)
(destructuring-bind (&key image executable pre-image-dump post-image-restart entry-point) spec
(let ((namestring (effective-namestring env image)))
(text-for-xcvb-driver-helper
env dependencies
":make-image (~S :output-name ~S ~:[~; :executable t~]~@[ :pre-image-dump ~S~]~@[ :post-image-restart ~S~]~@[ :entry-point ~S~])"
(tempname-target namestring)
(pathname-name namestring)
executable pre-image-dump post-image-restart entry-point))))
Francois-Rene Rideau
committed
(define-text-for-xcvb-driver-command :create-bundle (env spec &rest dependencies)
(destructuring-bind (&key bundle kind) spec
(let ((namestring (effective-namestring env bundle)))
(text-for-xcvb-driver-helper
env dependencies
":create-bundle (~S :output-name ~S :kind ~S)"
(tempname-target namestring) (pathname-name namestring) kind))))
Francois-Rene Rideau
committed
(defun lisp-invocation-for (env keys eval)
(destructuring-bind (&key image load) keys
(lisp-invocation-arglist
:image-path (if image (effective-namestring env image) *lisp-image-pathname*)
:cross-compile t
:load (mapcar/ #'effective-namestring env load)
:eval (tweak-features-around-eval-string eval))))
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
(defun compile-file-directly-shell-token (env name &key cfasl lisp-object)
Francois-Rene Rideau
committed
(quit-form
:code
(format nil "(multiple-value-bind (output warningp failurep) ~
(let ((*default-pathname-defaults* ~
(truename *default-pathname-defaults*))) ~
(handler-bind ~
(((or #+sbcl sb-c::simple-compiler-note #+ecl c::compiler-note ~
#+ecl c::compiler-debug-note #+ecl c::compiler-warning) ~
#'muffle-warning)) ~
(compile-file ~S :verbose nil :print nil ~
Peter Keller
committed
:output-file (merge-pathnames ~:[~S~;~:*~S~*~]) ~
~@[:emit-cfasl (merge-pathnames ~S)~] ~
~3:*~:[~;:system-p t) ~
(c::build-fasl (merge-pathnames ~S) ~
:lisp-files (list ~2:*(merge-pathnames ~S))~])))~
(if (or (not output) #-(or clisp ecl) warningp #-clisp failurep) 1 0))"
(effective-namestring env name)
Francois-Rene Rideau
committed
(when lisp-object
Peter Keller
committed
(tempname-target (effective-namestring env `(:lisp-object ,(second name)))))
(tempname-target (effective-namestring env `(:fasl ,(second name))))
(tempname-target (effective-namestring env `(:cfasl ,(second name))))))))
Francois-Rene Rideau
committed
(defgeneric grain-pathname-text (env grain))
(defmethod grain-pathname-text (env (grain file-grain))
(grain-namestring env grain))
Francois-Rene Rideau
committed
(defmethod grain-pathname-text (env (grain asdf-grain))
(declare (ignorable env grain))
nil)
Francois-Rene Rideau
committed
(defmethod grain-pathname-text (env (grain require-grain))
(declare (ignorable env grain))
nil)