[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Re: defsystem ?

I use the following macro for code that is to be compiled under different
Lisps. I prefer to have a macro that expands a system declaration into
vendor-specific forms (browsers, better integration into the Lisp,
logical pathnames supported).

The semantics of the defsystem is quite simple (subset
of the Allegro CL defsystem). It uses a serial-parallel dependency relation.
Files are strings and other systems are given as symbols.
If a component contains a macro (or defstruct etc.)
whose definition is changed, you currently
have to recompile the whole system (with recompilation enforced even
if the source is older than the fasl file).
A destination directory cannot be defined because the mapping can be
defined using logical pathnames.

Comments welcome. For MCL I used Guillaume Cartier's defunit system.


;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: CL-USER -*-

(cl:in-package :cl-user)

;;; ----------------------------------------------------------------------
;;; Portable system declaration expanding into vendor-specific versions.
;;; DEFINE System = DEFsystem Is Now Expanded System
;;; ----------------------------------------------------------------------

(defmacro define-system (name
                           (pretty-name (symbol-name name))
                           (subsystem nil))
  #+(or :Allegro :mcl :Lispworks)
  (declare (ignore subsystem #+(or :mcl :Lispworks) pretty-name))
  (labels ((host-substring (logical-pathname)
             (let ((position (position #\: logical-pathname)))
               (if position 
                   (subseq logical-pathname 0 position)
           #+(or :Genera :mcl :Lispworks)
             (if (consp description)
                 (mapcan #'flatten-serial-parallel-descriptions
                         (rest description))
                 (list description))))
    (unless default-pathname
      (error "A default pathname must be supplied in a system definition."))
    (let ((logical-host (host-substring default-pathname))
          #+(or :Genera :mcl)
            (remove-if-not #'symbolp
      (unless logical-host
        (error "Systems must be given a logical pathname as default pathname."))
         (load-logical-pathname-translations ,logical-host)
         (excl:defsystem ,name
                         (:default-pathname ,default-pathname
                          :pretty-name ,pretty-name)

         (lw:defsystem ,name
                       (:default-pathname ,(string-upcase default-pathname))
                       ,(mapcar #'(lambda (component)
                                    (if (symbolp component)
                                        `(,component :type :system)
                       ((:in-order-to :compile :all
                                      (:requires (:load :previous)))))

         (,(if subsystem
          (:default-pathname ,default-pathname
           :pretty-name ,pretty-name)
          ,@(mapcar #'(lambda (system)
                        `(:module ,system (,system) (:type :system)))

         (cc:defunit ,name
                     (:depends-on . ,systems-depending-on)
                     (:source-pathname ,default-pathname)
                     (:binary-pathname ,default-pathname)       ; not default
                     (:components . ,(remove-if


(define-system :test
  (:default-pathname "test:default;"
   :pretty-name "Test"
   :subsystem t)
  (:serial (:parallel :bar :bvyy) "test1" "test2"))