Newer
Older
;;;;; Syntax and Semantics of Lisp grains, including build.xcvb files
#+xcvb (module (:depends-on ("grain-registry" "extract-target-properties")))
(in-package :xcvb)
(declaim (optimize (speed 2) (safety 3) (debug 3) (compilation-speed 0)))
(defun create-module-from-declaration (form &key keys build-p)
"Takes a module declaration FORM and returns a grain object for that module."
(apply #'make-instance (parse-module-declaration form :keys keys :build-p build-p)))
(defun parse-module-declaration (form &key keys build-p)
"Takes a module declaration FORM and returns a grain object for that module."
(let ((class (module-form-p form))
(pathname (getf keys :pathname)))
(unless class
(error "Invalid or missing module declaration~@[ in ~S~]" pathname))
(when build-p
(unless (eq class 'lisp-file-grain)
(error "Invalid build module declaration~@[ in ~S~]" pathname))
(setf class 'build-module-grain))
(destructuring-bind ((&rest form-keys &key &allow-other-keys) &rest extension-forms)
(cdr form)
(loop :for (key nil rest-keys) :on form-keys :by #'cddr :do
(cond
((getf keys key)
(error "While parsing module form ~S~@[ in ~S~], invalid key ~S provided"
form pathname key))
((getf keys rest-keys)
(error "While parsing module form ~S~@[ in ~S~], duplicate key ~S provided"
form pathname key))))
(log-format-pp 10
" Constructing grain of class ~A with~% ~S~%" class
`(:extension-forms ,extension-forms :computation nil
,(append keys form-keys)))
(list* class
:extension-forms extension-forms
:computation nil
(append keys form-keys)))))
Francois-Rene Rideau
committed
(defun read-module-declaration (path)
(let ((*features* (list :xcvb)))
(read-first-file-form path :package :xcvb-user)))
(defun grain-from-file-declaration (path &key build-p)
(log-format 10 " Creating grain from declarations in file at ~S~%" path)
Francois-Rene Rideau
committed
(read-module-declaration path)
(defun module-form-p (form)
"Returns whether or not the given form is a valid xcvb:module form"
(and (consp form)
(listp (cdr form))
(listp (cadr form))
(cdr (assoc (car form) *module-classes*))))
Francois-Rene Rideau
committed
(defmethod shared-initialize :after
((grain lisp-module-grain) slot-names &rest initargs &key &allow-other-keys)
(declare (ignore slot-names initargs))
(compute-fullname grain)
(validate-fullname grain)
(values))
(defmethod shared-initialize :after
((grain loadable-file-grain) slot-names &rest initargs &key &allow-other-keys)
(declare (ignore slot-names initargs))
(validate-fullname grain)
(values))
Francois-Rene Rideau
committed
(defmethod grain-vp :before ((grain file-grain))
(unless (slot-boundp grain 'vp)
(setf (slot-value grain 'vp) (default-vp-for grain))))
;;; Lisp Grains
(defmethod finalize-grain :around (grain)
(unless (grain-finalized-p grain) ;; only do it once per grain
(setf (grain-finalized-p grain) :in-progress)
(call-next-method)
(setf (grain-finalized-p grain) t))
Francois-Rene Rideau
committed
grain)
(defmethod finalize-grain ((grain lisp-module-grain))
(handle-extension-forms grain)
(macrolet ((normalize (deps)
`(normalize-dependencies grain ,deps ,(keywordify deps))))
(with-slots (build-depends-on compile-depends-on load-depends-on
cload-depends-on depends-on
build-dependencies compile-dependencies cload-dependencies load-dependencies)
grain
(let ((common-dependencies (normalize depends-on)))
(setf compile-dependencies
(append (mapcar #'compiled-dependency common-dependencies)
(normalize compile-depends-on))
cload-dependencies
(if (slot-boundp grain 'cload-depends-on)
(append (mapcar #'compiled-dependency common-dependencies)
(normalize cload-depends-on))
compile-dependencies)
load-dependencies
(append common-dependencies
(normalize load-depends-on))
build-dependencies
Francois-Rene Rideau
committed
(append (unless (member (effective-encoding grain) '(:utf-8 nil))
(normalize '((:build "/asdf-encodings"))))
(if (slot-boundp grain 'build-depends-on)
(normalize build-depends-on)
(build-dependencies (grain-parent grain)))))))))
Francois-Rene Rideau
committed
(defun normalize-supersedes-asdf (n x)
(etypecase x
(string
(list (coerce-asdf-system-name x) n))
((cons string (cons string null))
(portable-pathname-from-string (second x) :allow-absolute nil) ; check validity
(list (coerce-asdf-system-name (first x)) (strcat n "/" (second x))))))
(defmethod finalize-grain :after ((grain build-module-grain))
Francois-Rene Rideau
committed
(with-slots (supersedes-asdf asdf-supersessions) grain
(setf asdf-supersessions
(mapcar/ #'normalize-supersedes-asdf (fullname grain) supersedes-asdf))))
;; Lisp grain extension form for generating Lisp files.
(define-simple-dispatcher handle-extension-form #'handle-extension-form-atom)
(defun handle-extension-form (grain extension-form)
(handle-extension-form-dispatcher grain extension-form))
(defun handle-extension-form-atom (grain extension-form)
(declare (ignore grain))
(error "handle-extension-form-atom: Extension form ~a is invalid.
Only currently support :generate and :executable extension form."
(defmethod print-object ((g lisp-generator) stream)
(with-output (stream)
(print-unreadable-object (g stream :type t)
(format stream ":build ~A :targets ~A :dependencies ~A"
(fullname (generator-build g))
(mapcar #'fullname (generator-targets g))
(define-handle-extension-form :generate (build generate &key depends-on)
(unless generate
(error "Files to be generated not specified."))
(error "Generators not specified."))
(let* ((targets
(mapcar (lambda (target)
(destructuring-bind (type name &rest keys &key &allow-other-keys) target
Francois-Rene Rideau
committed
(unless (eq type :lisp)
(error "Only know how to generate lisp modules."))
`(module ,keys)
:keys `(:fullname (:lisp ,(strcat (fullname build) "/" name))
:parent ,build
;;; TODO: use :obj rather than :src, after mapping file is defined
:vp ,(make-vp :src (fullname build) "/" name "." "lisp")))))
generate))
(generator
(make-instance 'lisp-generator
:build build
:dependencies (normalize-dependencies build depends-on :depends-on))))
(loop :for target :in targets :do
(setf (registered-grain (fullname target)) target)
(setf (grain-generator target) generator))))
(defmethod run-generator (env (generator lisp-generator))
(let* ((dependencies (generator-dependencies generator))
(targets (generator-targets generator))
(grain (first targets)))
(unless targets
(error "no targets"))
(unless dependencies
(error "run-generator: Need dependencies to generate files ~S.~%"
(mapcar #'fullname targets)))
(dolist (target targets)
(slot-makunbound target 'computation))
(pre-image-for env grain)
(build-command-for* env dependencies)
(make-computation
env
:outputs targets
:inputs (traversed-dependencies env)
:command
`(:xcvb-driver-command
,(image-setup env)
,@(traversed-build-commands env)))))
(define-handle-extension-form :executable (build name &key depends-on pre-image-dump post-image-restart entry-point)
(let* ((target (make-instance 'executable-grain
:parent build
:fullname `(:executable ,(strcat (fullname build) "/" name))))
(generator
(make-instance 'executable-generator
:build build
:target target
:pre-image-dump pre-image-dump
:post-image-restart post-image-restart
:entry-point entry-point
:depends-on depends-on)))
(setf (registered-grain (fullname target)) target)
(setf (grain-generator target) generator))
(values))
(defmethod run-generator (env (generator executable-generator))
(let* ((build (generator-build generator))
(target (generator-target generator))
(fullname (fullname target))
(name (progn
(assert (single-arg-form-p :executable fullname))
(second fullname)))
(depends-on (generator-depends-on generator))
(dependencies
(if (eq depends-on :build)
(load-dependencies build)
(normalize-dependencies build depends-on :depends-on))))
(graph-for-image-grain
env name (build-pre-image-name build) dependencies
:executable t
:pre-image-dump (pre-image-dump generator)
:post-image-restart (post-image-restart generator)
:entry-point (entry-point generator))))
;;(define-handle-extension-form :in-package (grain files &key package) ...)
(let ((extension-forms (grain-extension-forms grain)))
(dolist (extension extension-forms)
(handle-extension-form grain extension))))
(defun make-grain-from-file (path &key build-p)
"Takes a PATH to a lisp file, and returns the corresponding grain."
Francois-Rene Rideau
committed
(grain-from-file-declaration path :build-p build-p))
(defmethod build-module-grain-for ((grain build-module-grain))
grain)
(defmethod build-module-grain-for ((grain executable-grain))
(grain-parent grain))
(defmethod build-module-grain-for ((grain lisp-file-grain))
(defmethod build-module-grain-for ((grain source-grain))
(registered-build (source-grain-in grain)))
(defmethod load-dependencies :before ((grain lisp-module-grain))
(finalize-grain grain))
(defmethod cload-dependencies :before ((grain lisp-module-grain))
(finalize-grain grain))
(defmethod compile-dependencies :before ((grain lisp-module-grain))
(finalize-grain grain))
(defmethod build-dependencies :before ((grain lisp-module-grain))
(finalize-grain grain))
Francois-Rene Rideau
committed
(defun build-starting-dependencies-p (dependencies)
(and (consp dependencies)
(consp (car dependencies))
(eq :build (caar dependencies))
Francois-Rene Rideau
committed
(cadar dependencies)))
Francois-Rene Rideau
committed
(defun base-image-name ()
(when (or *use-base-image* (registered-grain `(:image "/_")))
"/_"))
Francois-Rene Rideau
committed
(defun build-pre-image-name (grain &optional traversed)
(check-type grain lisp-module-grain)
Francois-Rene Rideau
committed
(when (member grain traversed)
Francois-Rene Rideau
committed
(error "Circular build dependency ~S"
Francois-Rene Rideau
committed
(member grain (reverse traversed))))
(finalize-grain grain)
Francois-Rene Rideau
committed
(let* ((dependencies (build-dependencies grain))
(build-module-grain
Francois-Rene Rideau
committed
(cond
((build-module-grain-p grain) grain)
Francois-Rene Rideau
committed
((or (not (slot-boundp grain 'build-depends-on))
(equal dependencies
(build-dependencies (grain-parent grain))))
(grain-parent grain))
(t nil)))
(pre-image-p (when build-module-grain (build-pre-image build-module-grain)))
(starting-build-name (build-starting-dependencies-p dependencies))
(starting-build
(when starting-build-name
Francois-Rene Rideau
committed
(registered-build starting-build-name :ensure-build t)))
(starting-build-image-name
(when starting-build
(build-image-name starting-build))))
Francois-Rene Rideau
committed
((null dependencies)
(if pre-image-p "/_" (base-image-name)))
((and starting-build-image-name (null (cdr dependencies)))
starting-build-image-name)
(strcat "/_pre" (fullname build-module-grain)))
(starting-build-image-name ; and (not pre-image-p)
starting-build-image-name)
(starting-build
(build-pre-image-name starting-build (cons build-module-grain traversed)))
Francois-Rene Rideau
committed
(t ; (not pre-image-p)
(base-image-name)))))
(defun build-post-image-name (build-module-grain)
;; The closest build on top of which to load files to reach the state post loading the build.
;; If the build has an image, that's it. Otherwise, it's its pre-image.
(check-type build-module-grain build-module-grain)
(finalize-grain build-module-grain)
(if (build-image build-module-grain)
(build-image-name build-module-grain)
(build-pre-image-name build-module-grain)))
(defun build-image-name (build-module-grain)
(check-type build-module-grain build-module-grain)
(let ((image (build-image build-module-grain)))
(etypecase image
(null nil)
((eql t) (fullname build-module-grain)))))
(defun make-asdf-grain (&key name implementation)
(make-instance
'asdf-grain
:implementation implementation
:name name
:fullname `(:asdf ,name)))
Francois-Rene Rideau
committed
(defun make-require-grain (&key name)
(setf name (string name))
Francois-Rene Rideau
committed
(make-instance
'require-grain
:name name
:fullname `(:require ,name)))
(defmethod build-dependencies ((grain asdf-grain))
nil)
(defmethod load-dependencies ((grain asdf-grain))
nil)
Francois-Rene Rideau
committed
(defmethod grain-computation ((grain asdf-grain))
nil)
(defmethod build-dependencies ((grain require-grain))
nil)
(defmethod load-dependencies ((grain require-grain))
nil)
(defmethod grain-computation ((grain require-grain))
nil)
(defmethod build-dependencies ((grain loadable-file-grain))
(declare (ignorable grain))
(defun lisp-module-grain-p (x)
(typep x 'lisp-module-grain))
(defun build-module-grain-p (x)
(typep x 'build-module-grain))
(defun file-grain-p (x)
(typep x 'file-grain))
(defun lisp-file-grain-p (x)
(typep x 'lisp-file-grain))
(defun asdf-grain-p (x)
(typep x 'asdf-grain))
(defun require-grain-p (x)
(typep x 'require-grain))
(defun image-grain-p (x)
(typep x 'image-grain))
(defun executable-grain-p (x)
(typep x 'executable-grain))
(defun world-grain-p (x)
(typep x 'world-grain))
Francois-Rene Rideau
committed
(defmethod print-object ((g file-grain) stream)
(with-output (stream)
(print-unreadable-object (g stream :type t)
(format stream "~@<~S~@[ ~S~]~>"
(grain-vp g) (when (slot-boundp g 'pathname) (grain-pathname g))))))
Francois-Rene Rideau
committed
(defun coerce-asdf-system-name (name)
"This function take the name of an asdf-system, and
converts it to a string representation that can universally be used to refer to that system.
Modeled after the asdf function coerce-name"
(string-downcase
(typecase name
#+asdf (asdf:component (asdf:component-name name))
(symbol (symbol-name name))
(string name)
(asdf-grain (asdf-grain-system-name name))
(t (simply-error 'syntax-error "~@<invalid asdf system designator ~A~@:>" name)))))
(defmethod print-object ((x grain) stream)
(if (member (type-of x) *print-concisely*)
(print-unreadable-object (x stream :type t :identity nil)
(when (slot-boundp x 'fullname)
(format stream "~S" (slot-value x 'fullname))))
(call-next-method)))
(defmethod included-dependencies ((image image-grain))
(included-dependencies (image-world image)))
(defmethod (setf included-dependencies) (grain-set (image image-grain))
(setf (included-dependencies (image-world image)) grain-set))
(defmethod image-setup ((image image-grain))
(image-setup (image-world image)))
(defmethod image-setup ((world world-grain))
(getf (cdr (fullname world)) :setup))
(defmethod build-commands-r ((world world-grain))
(getf (cdr (fullname world)) :commands-r))
(defgeneric all-build-commands-r (env grain))
(defmethod all-build-commands-r (env (image image-grain))
(all-build-commands-r env (image-world image)))
(defmethod all-build-commands-r (env (world world-grain))
(destructuring-bind (&key image load) (image-setup world)
(remove-duplicates
(append
(build-commands-r world)
(when load
(loop :for l :in (reverse load)
:for dep = (tweak-dependency env l)
;;:do (grain-for env dep)
:collect `(:load-file ,dep)))
(when image
(all-build-commands-r env (registered-grain image))))
:test 'equal)))
(defun canonicalize-image-setup (setup)
(destructuring-bind (&key image load) setup
(append
(when image `(:image ,image))
(when load `(:load ,load)))))
(defun make-world-name (setup commands-r)
`(:world :setup ,(canonicalize-image-setup setup)
:commands-r ,commands-r))
(defun fullname-pathname (fullname)
(grain-pathname (registered-grain fullname)))
Francois-Rene Rideau
committed
(defgeneric default-vp-for (x))
(defmethod default-vp-for (grain)
(default-vp-for-fullname nil (fullname grain)))
Francois-Rene Rideau
committed
(defmethod default-vp-for ((x lisp-file-grain))
Francois-Rene Rideau
committed
(let* ((build (grain-parent x))
(bname (fullname build))
(bpath (grain-pathname build))
Francois-Rene Rideau
committed
(pathname (grain-pathname x))
(suffix (progn
(assert (string-prefix-p (strcat bname "/") lname))
(subseq lname (1+ (length bname))))))
Francois-Rene Rideau
committed
(assert (equal pathname (subpathname bpath (strcat suffix ".lisp"))))
Francois-Rene Rideau
committed
(make-vp :src bname "/" suffix "." "lisp")))
(define-simple-dispatcher default-vp-for-fullname #'default-vp-for-fullname-atom)
(defun default-vp-for-fullname (env name)
(default-vp-for-fullname-dispatcher env name))
(defun default-vp-for-fullname-atom (env name)
(declare (ignore env))
(assert (registered-build name))
(make-vp :src name "/build.xcvb"))
(defun vp-for-name-extension (name extension &optional (zone :obj))
(make-vp zone name "." extension))
(define-default-vp-for-fullname :image (env name)
(declare (ignore env))
(vp-for-name-extension name "image"))
(define-default-vp-for-fullname :executable (env name)
(declare (ignore env))
#+os-unix (make-vp :obj name) ;; TODO: create a zone :install for end products?
#+os-windows (vp-for-name-extension name "exe"))
(define-default-vp-for-fullname :static-library (env name)
(declare (ignore env))
(vp-for-name-extension name "a"))
(define-default-vp-for-fullname :dynamic-library (env name)
(declare (ignore env))
#+os-unix (vp-for-name-extension name "so") ; or should we use "fas" at the risk of clashes?
#+os-windows (vp-for-name-extension name "dll"))
(define-default-vp-for-fullname :manifest (env name)
(declare (ignore env))
(vp-for-name-extension name "manifest"))
(define-default-vp-for-fullname :fasl (env name)
(declare (ignore env))
;; Note: at least ecl and lispworks recognize files based on the type,
;; which at least on lispworks varies depending on the target platform.
(vp-for-name-extension name *fasl-type*))
(define-default-vp-for-fullname :cfasl (env name)
(declare (ignore env))
(vp-for-name-extension name (strcat "c" *fasl-type*)))
(define-default-vp-for-fullname :lisp-object (env name)
(declare (ignore env))
(vp-for-name-extension name "o"))
(define-default-vp-for-fullname :source (env sub &key in)
(declare (ignore env))
(assert (equal in (fullname (registered-build in :ensure-build t))))
(make-vp :src in "/" sub))
(defmethod effective-around-compile ((lisp lisp-file-grain))
(if (slot-boundp lisp 'around-compile)
(around-compile lisp)
(let ((build (build-module-grain-for lisp)))
(if (slot-boundp build 'around-compile)
(around-compile build)
nil))))
Francois-Rene Rideau
committed
(defmethod effective-encoding ((lisp lisp-module-grain))
(or (specified-encoding lisp)
(specified-encoding (build-module-grain-for lisp))
Francois-Rene Rideau
committed
#|:utf-8|# ;; default
))
(defmethod fullname ((grain asdf-grain))
`(:asdf ,(asdf-grain-system-name grain)))