Re: defsystem ?

[moeller@informatik.uni-hamburg.de (Ralf Moeller)]

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.

Ralf

;;; -*- 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
                         (&key
                           (pretty-name (symbol-name name))
                           default-pathname
                           (subsystem nil))
                         components)
  #+(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)
                   nil)))
           #+(or :Genera :mcl :Lispworks)
           (flatten-serial-parallel-descriptions
             (description)
             (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)
          (systems-depending-on
            (remove-if-not #'symbolp
                           (flatten-serial-parallel-descriptions
                             components))))
      
      (unless logical-host
        (error "Systems must be given a logical pathname as default pathname."))
      
      `(progn
         (load-logical-pathname-translations ,logical-host)
         #+:Allegro
         (excl:defsystem ,name
                         (:default-pathname ,default-pathname
                          :pretty-name ,pretty-name)
                         ,components)

         #+:Lispworks
         (lw:defsystem ,name
                       (:default-pathname ,(string-upcase default-pathname))
                       :members
                       ,(mapcar #'(lambda (component)
                                    (if (symbolp component)
                                        `(,component :type :system)
                                        component))
                                (flatten-serial-parallel-descriptions
                                  components))
                       :rules
                       ((:in-order-to :compile :all
                                      (:requires (:load :previous)))))

         #+:Genera
         (,(if subsystem
               'sct:defsubsystem
               'sct:defsystem)
          ,name
          (:default-pathname ,default-pathname
           :pretty-name ,pretty-name)
          ,@(mapcar #'(lambda (system)
                        `(:module ,system (,system) (:type :system)))
                    systems-depending-on)
          ,components)

         #+:mcl
         (cc:defunit ,name
                     (:depends-on . ,systems-depending-on)
                     (:source-pathname ,default-pathname)
                     (:binary-pathname ,default-pathname)       ; not default
                     (:components . ,(remove-if
                                       #'symbolp
                                       (flatten-serial-parallel-descriptions
                                         components))))))))




#|


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

|#