From 4a6a10eda91d50d929d6e95285dddc7b7cdc553c Mon Sep 17 00:00:00 2001 From: Daniel Barlow <> Date: Tue, 30 Apr 2002 17:22:51 +0000 Subject: [PATCH] Several changes * If some component of *central-registry* is a function or a symbol for which fboundp returns true, it will be funcalled with the system name string as an argument, and should return a directory in which to look for the system definition. This allows much more flexibility in the location of .asd files * New component type 'system' is functionally identical to module, but has attributes for author name, licence, description etc, which can be used by programs that make platform packages * Much shuffling of parts of the file so that it compiles without any warnings about forward declarations * The behaviour when compile-file returns non-NIL in its secondary values (failure-p and warnings-p) can now be customized: new compile-op initargs :on-warnings and :on-failure take values (or :warn :error :ignore). If unspecified, these default to *compile-file-{failure,warnings}-behaviour* * A new 'properties' attribute to component which can be used to communicate extra optional information between system authors and platform package creation programs --- README | 113 ++++++++---- asdf.lisp | 371 +++++++++++++++++++++----------------- cclan.lisp | 3 +- systems/db-sockets.system | 17 +- 4 files changed, 298 insertions(+), 206 deletions(-) diff --git a/README b/README index 44ce46df..1030ca93 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ -$Id: README,v 1.18 2002/03/06 23:58:34 dan_b Exp $ -*- Text -*- +$Id: README,v 1.19 2002/04/30 17:22:51 dan_b Exp $ -*- Text -*- asdf: another system definition facility @@ -11,10 +11,12 @@ maximum convenience you want to have it loaded whenever you start your Lisp implementation, by loading it from the startup script, or dumping a custom core, or something. -- The variable asdf:*central-registry* is a list of forms each of - which evaluates to a directory in which .asd files (system - definitions) may be found. Typically you might for example - have +- The variable asdf:*central-registry* is a list of system directory + designators. A ssytem directory designator is either a function + designator for a function of one argument, which when called with + the system name will return a directory to look for .asd files in, + or it is a form which evaluates to a directory to look in. + Typically you might for example have (*default-pathname-defaults* "/home/me/cl/systems/" "/usr/share/common-lisp/systems/") @@ -27,15 +29,16 @@ a custom core, or something. $ cd /home/me/cl/systems/ $ ln -s ~/src/foo/foo.asd . $ lisp - * (asdf :operate asdf:load-op 'foo) + * (asdf :operate 'asdf:load-op 'foo) - To write your own system definitions, look at the test systems in test/ , and read the rest of this. Ignore systems/ which is old and may go away when next I clean up - Syntax is similar to mk-defsystem 3 for straightforward systems, you - may only need to remove the :source-pathname option (and replace - it with :pathname if you aren't using symlinks in *central-registry*) + may only need to remove the :source-pathname option (and replace it + with :pathname if the asd file is not in the same place as the + system sources) - Join cclan-list@lists.sf.net for discussion, bug reports, questions, etc @@ -147,6 +150,19 @@ which is reported not to work on some implementations This is used by the test-system-version operation (see later). +**** *features* required + +Traditionally defsystem users have used reader conditionals to include +or exclude specific per-implementation files. This means that any +single implmentation cannot read the entire system, which becomes a +problem if it doesnb't wish to compile it, but instead for example to +create an archive file containing all the sources, as it will omit to +process the system-dependent sources for other systems. + +Each component in an asdf system may therefore specify features using +the same syntax as #+ does, and it will (somehow) be ignored for +certain operations unless the feature conditional matches + **** dependencies on its siblings (optional but often necessary) There is an excitingly complicated relationship between the initarg @@ -155,20 +171,18 @@ and the method that you use to ask about dependencies Dependencies are between (operation component) pairs. In your initargs, you can say -:in-order-to ((compile-op (load-op (and "a" "b")) (compile-op "c")) +:in-order-to ((compile-op (load-op "a" "b") (compile-op "c")) (load-op (load-op "foo"))) - before performing compile-op on this component, we must perform -load-op on both of "a" and "b" and compile-op on c, -- before performing load-op, we have to load "foo" +load-op on "a" and "b", and compile-op on c, - before performing +load-op, we have to load "foo" The syntax is approximately (this-op {(other-op required-components)}+) required-components := component-name - | (or required-components required-components) - | (and required-components required-components) | (required-components required-components) component-name := string @@ -177,21 +191,8 @@ component-name := string The last case in required-components is a shorthand for the 'and' form, as and is usually the common case -The dependency mechanism can also be used to introduce conditional -compilation based on features of the Lisp environment. A -dependency on (feature foo) is satisfied if foo is in the -*features* list - - -(:module "deps" - :if-component-dep-fails :try-next - (:file "sbcl-dep" - :in-order-to ((compile-op (feature :sbcl)))) - (:file "cmucl-dep" - :in-order-to ((compile-op (feature :cmu))))) - -[ This is on a par with what ACL defsystem does, though the and/or -stuff is of our own invention. mk-defsystem is less general: it has -an implied dependency +[ This is on a par with what ACL defsystem does. mk-defsystem is less +general: it has an implied dependency for all x, (load x) depends on (compile x) @@ -242,6 +243,19 @@ Note that the DEFSYSTEM operator (used to create a "top-level" system) does additional processing to set the filesystem location of the top component in that system. This is detailed elsewhere +**** properties (optional) + +Packaging systems often require information about files or systems +additional to that specified here. Programs that create vendor +packages out of asdf systems therefore have to create "placeholder" +information to satisfy these systems. Sometimes the creator of an +asdf system may know the additional information and wish to provide it +directly. + +component-properties is a symbol-value alist (plist?) which system +authors may set and package building rograms may query. asdf make sno +further specification of the contents of this slot. + ** Subclasses of component *** 'source-file' @@ -277,11 +291,18 @@ This has extra slots for The default operation knows how to traverse a module, so most operations will not need to provide methods specialised on modules. -A system object is usually a module. - The module may be subclassed to represent components such as foreign-language linked libraries or archive files. +*** system, subclasses module + +A system is a module with a few extra attributes for documentation +purposes. In behaviour, it's usually identical. + +Users can create new classes for their systems: the default defsystem +macro takes a :classs keyword argument. + + ** operation An operation is instantiated whenever the user asks that an operation @@ -308,6 +329,16 @@ oos is accepted as a synonym for operate *** standard operations +**** feature-dependent-op + +This is not intended to be instantiated directly, but other operations +may inherit from it. An instance of feature-dependent-op will ignore +any components which have a `features' attribute, unless the feature +combination it designates is satisfied by *features* + +See the earlier explanation about the component features attribute for +more information + **** compile-op &key proclamations If proclamations are supplied, they will be proclaimed. This is a @@ -507,8 +538,8 @@ interactively re-evaluates that form * Error handling It is an error to define a system incorrectly: an implementation may -detect this and signal a SYSTEM-DEFINITION-ERROR or generalised -instance thereof +detect this and signal a generalised instance of +SYSTEM-DEFINITION-ERROR Operations may go wrong (for example when source files contain errors). These are signalled using generalised instances of @@ -521,6 +552,10 @@ OPERATION-ERROR * Outstanding spec questions, things to add +** packaging systems + +*** manual page component? + ** style guide for .asd files You should either use keywords or be careful with the package that you @@ -539,10 +574,22 @@ the existing syntax. Reinstate parse-option or something akin ** document all the error classes +** putting functions onto *central-registry* ? + +For the benefit of people who don't want to keep all their systems in +the same place, we could + +1) put functions onto *central-registry*. These would take the + syestem name as argument + +2) expose the system-definition-pathname function. Problem, it's + currently a function not a gf. What would it specialize on? + + * missing bits in implementation ** all of the above ** reuse the same scratch package whenever a system is reloaded from disk -** "and" and "or" dependencies are broken ** rules for system pathname defaulting are not yet implemented properly ** proclamations probably aren't + diff --git a/asdf.lisp b/asdf.lisp index c05b4d8e..50a81f2b 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -16,6 +16,9 @@ #:component #:module #:source-file #:c-source-file #:cl-source-file #:java-source-file #:static-file + #:doc-file + #:html-file + #:text-file #:source-file-type #:module ; components #:unix-dso @@ -45,6 +48,9 @@ (proclaim '(optimize (debug 3))) (declaim (optimize (debug 3))) +(defvar *compile-file-warnings-behaviour* :error) +(defvar *compile-file-failure-behaviour* :error) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; utility stuff @@ -57,7 +63,7 @@ and NIL NAME and TYPE components" (make-pathname :name nil :type nil :defaults pathname)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; problems +;; classes, condiitons (define-condition system-definition-error (error) ()) (define-condition formatted-system-definition-error (system-definition-error) @@ -66,32 +72,17 @@ and NIL NAME and TYPE components" (:report (lambda (c s) (apply #'format s (format-control c) (format-arguments c))))) -(defun sysdef-error (format &rest arguments) - (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) - (define-condition circular-dependency (system-definition-error) ((components :initarg :components))) - (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) (version :initform nil :reader missing-version :initarg :version) (parent :initform nil :reader missing-parent :initarg :parent))) -(defmethod print-object ((c missing-component) s) - (format s "Component ~S not found" (missing-requires c)) - (when (missing-version c) - (format s " or does not match version ~A" (missing-version c))) - (when (missing-parent c) - (format s " in ~A" (component-name (missing-parent c))))) - (define-condition missing-dependency (missing-component) ((required-by :initarg :required-by :reader missing-required-by))) -(defmethod print-object ((c missing-dependency) s) - (call-next-method) - (format s ", required by ~A" (missing-required-by c))) - (define-condition operation-error (error) ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) @@ -101,9 +92,6 @@ and NIL NAME and TYPE components" (define-condition compile-failed (operation-error) ()) (define-condition compile-warned (operation-error) ()) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; components - (defclass component () ((name :type string :accessor component-name :initarg :name :documentation "Component name, restricted to portable pathname characters") @@ -116,26 +104,37 @@ and NIL NAME and TYPE components" (parent :initarg :parent :initform nil :reader component-parent) ;; no direct accessor for pathname, we do this as a method to allow ;; it to default in funky ways if not supplied - (relative-pathname :initarg :pathname))) + (relative-pathname :initarg :pathname) + ;; XXX we should provide some atomic interface for updating the + ;; component properties + (properties :accessor component-properties :initarg :properties))) + +;;;; methods: conditions + +(defmethod print-object ((c missing-dependency) s) + (call-next-method) + (format s ", required by ~A" (missing-required-by c))) + +(defun sysdef-error (format &rest arguments) + (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) +;;;; methods: components + +(defmethod print-object ((c missing-component) s) + (format s "Component ~S not found" (missing-requires c)) + (when (missing-version c) + (format s " or does not match version ~A" (missing-version c))) + (when (missing-parent c) + (format s " in ~A" (component-name (missing-parent c))))) + +(defgeneric component-system (component) + (:documentation "Find the top-level system containing COMPONENT")) + (defmethod component-system ((component component)) - "Find the top-level system containing COMPONENT" (aif (component-parent component) (component-system it) component)) -(defgeneric component-pathname (component) - (:documentation "Extracts the pathname applicable for a particular component.")) - -(defun component-parent-pathname (component) - (aif (component-parent component) - (component-pathname it) - *default-pathname-defaults*)) - -(defmethod component-pathname ((component component)) - (let ((*default-pathname-defaults* (component-parent-pathname component))) - (merge-pathnames (component-relative-pathname component)))) - (defmethod print-object ((c component) (stream stream)) (print-unreadable-object (c stream :type t :identity t) (ignore-errors @@ -151,12 +150,125 @@ and NIL NAME and TYPE components" (default-component-class :accessor module-default-component-class :initform 'cl-source-file :initarg :default-component-class))) +(defgeneric component-pathname (component) + (:documentation "Extracts the pathname applicable for a particular component.")) + +(defun component-parent-pathname (component) + (aif (component-parent component) + (component-pathname it) + *default-pathname-defaults*)) + (defmethod component-relative-pathname ((component module)) (or (slot-value component 'relative-pathname) (make-pathname :directory `(:relative ,(component-name component)) :host (pathname-host (component-parent-pathname component))))) +(defmethod component-pathname ((component component)) + (let ((*default-pathname-defaults* (component-parent-pathname component))) + (merge-pathnames (component-relative-pathname component)))) + + +(defclass system (module) + ((description :accessor system-description :initarg :description) + (long-description :accessor long-description :initarg :long-description) + (author :accessor system-author :initarg :author) + (maintainer :accessor system-maintainer :initarg :maintainer) + (licence :accessor system-licence :initarg :licence))) + +;;; version-satisfies + +;;; with apologies to christophe rhodes ... +(defun split (string &optional max (ws '(#\Space #\Tab))) + (flet ((is-ws (char) (find char ws))) + (nreverse + (let ((list nil) (start 0) (words 0) end) + (loop + (when (and max (>= words (1- max))) + (return (cons (subseq string start) list))) + (setf end (position-if #'is-ws string :start start)) + (push (subseq string start end) list) + (incf words) + (unless end (return list)) + (setf start (1+ end))))))) + +(defmethod version-satisfies ((c component) version) + (unless (and version (slot-boundp c 'version)) + (return-from version-satisfies t)) + (let ((x (mapcar #'parse-integer + (split (component-version c) nil '(#\.)))) + (y (mapcar #'parse-integer + (split version nil '(#\.))))) + (labels ((bigger (x y) + (cond ((not y) t) + ((not x) nil) + ((> (car x) (car y)) t) + ((= (car x) (car y)) + (bigger (cdr x) (cdr y)))))) + (and (= (car x) (car y)) + (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; finding systems + +(defvar *defined-systems* (make-hash-table :test 'equal)) +(defun coerce-name (name) + (typecase name + (component (component-name name)) + (symbol (string-downcase (symbol-name name))) + (string name) + (t (sysdef-error "Invalid component designator ~A" name)))) + +(defvar *central-registry* + '(*default-pathname-defaults* + "/home/dan/src/sourceforge/cclan/asdf/systems/" + #+nil "telent:asdf;systems;")) + +(defun system-definition-pathname (system) + (let ((name (coerce-name system))) + (dolist (dir *central-registry*) + (let* ((defaults (if (and (symbolp dir) + (fboundp dir)) + (funcall dir name) + (eval dir))) + (file (and defaults + (make-pathname + :name name :case :local :type "asd" + :defaults defaults + :version :newest)))) + (if (and file (probe-file file)) + (return-from system-definition-pathname file)))) + nil)) + + +(defun find-system (name &optional (error-p t)) + (let* ((name (coerce-name name)) + (in-memory (gethash name *defined-systems*)) + (on-disk (system-definition-pathname name))) + (when (and on-disk + (or (not in-memory) + (< (car in-memory) (file-write-date on-disk)))) + (let ((*package* (make-package (gensym (package-name #.*package*)) + :use '("CL" "ASDF")))) + (format t ";;; Loading system definition from ~A into ~A~%" + on-disk *package*) + (load on-disk))) + (let ((in-memory (gethash name *defined-systems*))) + (if in-memory + (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) + (cdr in-memory)) + (if error-p (error 'missing-component :requires name)))))) + +(defun register-system (name system) + (format t "Registering ~A as ~A ~%" system name) + (setf (gethash (coerce-name name) *defined-systems*) + (cons (get-universal-time) system))) + +(defun system-registered-p (name) + (gethash (coerce-name name) *defined-systems*)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; finding components (defgeneric find-component (module name &optional version) (:documentation "Finds the component with name NAME present in the @@ -172,9 +284,11 @@ system.")) ;;; a component with no parent is a system (defmethod find-component ((module (eql nil)) name &optional version) - (let ((m (internal-find-system name))) + (let ((m (find-system name nil))) (if (and m (version-satisfies m version)) m))) +;;; component subclasses + (defclass source-file (component) ()) (defclass cl-source-file (source-file) ()) @@ -195,6 +309,8 @@ system.")) (component-system component)))))) (defclass static-file (source-file) ()) +(defclass doc-file (static-file) ()) +(defclass html-file (doc-file) ()) (defmethod source-file-type ((c static-file) (s module)) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -225,8 +341,10 @@ system.")) (defun node-for (o c) (cons (class-name (class-of o)) c)) +(defgeneric operation-ancestor (operation) + (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree")) + (defmethod operation-ancestor ((operation operation)) - "Recursively chase the operation's parent pointer until we get to the head of the tree" (aif (operation-parent operation) (operation-ancestor it) operation)) @@ -290,6 +408,7 @@ system.")) ;;; we enforce that function is a symbol to allow us to specialize on ;;; (eql 'perform) and (eql 'explain) for :before and :after +(defgeneric traverse (operation component symbol)) (defmethod traverse ((operation operation) (c component) (function symbol)) (labels ((do-one-dep (required-op required-c required-v) @@ -310,7 +429,9 @@ system.")) (dolist (d deps) (handler-case (do-dep op d) - (missing-dependency (c) (return-from found nil))) + (missing-dependency (c) + (declare (ignore c)) + (return-from found nil))) (error 'missing-dependency :version nil :required-by c :requires deps)))) (do-dep (op dep) @@ -326,6 +447,7 @@ system.")) (or (do-first-dep op (cdr dep))) (version (destructuring-bind (ignore name version-object) dep + (declare (ignore ignore)) (do-one-dep op name version-object))) ;; if we had a list with unrecognised car, assume 'and' (t (do-every-dep op dep)))) @@ -348,6 +470,7 @@ system.")) (error condition)) (setf error condition)) (:no-error (c) + (declare (ignore c)) (setf at-least-one t)))) (when (and (eq (module-if-component-dep-fails c) :try-next) (not at-least-one)) @@ -386,10 +509,11 @@ system.")) (defclass compile-op (operation) ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) - (fail-on-error-p :initarg :fail-on-error - :accessor operation-fail-on-error-p :initform t) - (fail-on-warning-p :initarg :fail-on-warning - :accessor operation-fail-on-warning-p :initform nil))) + (on-warnings :initarg :on-warnings :accessor operation-on-warnings + :initform *compile-file-warnings-behaviour*) + (on-failure :initarg :on-failure :accessor operation-on-failure + :initform *compile-file-failure-behaviour*))) + ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy @@ -398,10 +522,17 @@ system.")) (multiple-value-bind (output warnings-p failure-p) (compile-file source-file :output-file (car (output-files operation c))) - (when (and warnings-p (operation-fail-on-warning-p operation)) - (error 'compile-warned :component c :operation operation)) - (when (and failure-p (operation-fail-on-error-p operation)) - (error 'compile-failed :component c :operation operation))))) + (declare (ignore output)) + (when warnings-p + (case (operation-on-warnings operation) + (:warn (warn 'compile-warned :component c :operation operation)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil))) + (when failure-p + (case (operation-on-failure operation) + (:warn (warn 'compile-failed :component c :operation operation)) + (:error (error 'compile-failed :component c :operation operation)) + (:ignore nil)))))) (defmethod output-files ((operation compile-op) (c cl-source-file)) (list (compile-file-pathname (component-pathname c)))) @@ -431,41 +562,6 @@ system.")) (call-next-method))) -;;; version-satisfies -#| -(defclass test-version (operation) - ((minimum :initarg :minimum :initform "" - :accessor test-version-minimum))) -|# -;;; with apologies to christophe rhodes ... -(defun split (string &optional max (ws '(#\Space #\Tab))) - (flet ((is-ws (char) (find char ws))) - (nreverse - (let ((list nil) (start 0) (words 0) end) - (loop - (when (and max (>= words (1- max))) - (return (cons (subseq string start) list))) - (setf end (position-if #'is-ws string :start start)) - (push (subseq string start end) list) - (incf words) - (unless end (return list)) - (setf start (1+ end))))))) - -(defmethod version-satisfies ((c component) version) - (unless (and version (slot-boundp c 'version)) - (return-from version-satisfies t)) - (let ((x (mapcar #'parse-integer - (split (component-version c) nil '(#\.)))) - (y (mapcar #'parse-integer - (split version nil '(#\.))))) - (labels ((bigger (x y) - (cond ((not y) t) - ((not x) nil) - ((> (car x) (car y)) t) - ((= (car x) (car y)) - (bigger (cdr x) (cdr y)))))) - (and (= (car x) (car y)) - (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -481,92 +577,39 @@ system.")) "Alias of OPERATE function" (apply #'operate args)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; finding systems - -(defvar *defined-systems* (make-hash-table :test 'equal)) -(defun coerce-name (name) - (typecase name - (component (component-name name)) - (symbol (string-downcase (symbol-name name))) - (string name) - (t (sysdef-error "Invalid component designator ~A" name)))) - -(defvar *central-registry* - '(*default-pathname-defaults* - "/home/dan/src/sourceforge/cclan/asdf/systems/" - #+nil "telent:asdf;systems;")) - -(defun system-definition-pathname (system) - (let ((name (coerce-name system))) - (dolist (dir *central-registry*) - (let* ((defaults (eval dir)) - (file (make-pathname - :name name :case :local :type "asd" - :defaults defaults - :version :newest))) - (if (probe-file file) (return-from system-definition-pathname file)))) - nil)) - - -(defun internal-find-system (name) - (let* ((name (coerce-name name)) - (in-memory (gethash name *defined-systems*)) - (on-disk (system-definition-pathname name))) - (when (and on-disk - (or (not in-memory) - (< (car in-memory) (file-write-date on-disk)))) - (let ((*package* (make-package (gensym (package-name #.*package*)) - :use '("CL" "ASDF")))) - (format t ";;; Loading system definition from ~A into ~A~%" - on-disk *package*) - (load on-disk))) - (let ((in-memory (gethash name *defined-systems*))) - (if in-memory - (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) - (cdr in-memory)))))) - -(defun find-system (name) - (or (internal-find-system name) - (error 'missing-component :requires name))) - -(defun register-system (name system) - (format t "Registering ~A as ~A ~%" system name) - (setf (gethash (coerce-name name) *defined-systems*) - (cons (get-universal-time) system))) - -(defun system-registered-p (name) - (gethash (coerce-name name) *defined-systems*)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; syntax (defmacro defsystem (name &body options) - (destructuring-bind (&key pathname (class 'module) &allow-other-keys) options - `(progn - ;; system must be registered before we parse the body, otherwise - ;; we recur when trying to find an existing system of the same name - ;; to reuse options (e.g. pathname) from - (let ((s (system-registered-p ',name))) - (cond ((and s (eq (type-of (cdr s)) ',class)) - (setf (car s) (get-universal-time))) - (s - #+clisp - (sysdef-error "Cannot redefine the existing system ~A with a different class" s) - #-clisp - (change-class (cdr s) ',class)) - (t - (register-system (quote ,name) - (make-instance ',class :name ',name))))) - (parse-component-form nil (apply - #'list - :module (coerce-name ',name) - :pathname - (or ,pathname - (pathname-sans-name+type *load-truename*) - *default-pathname-defaults*) - ',options))))) - + (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options + (let ((component-options + (if (member :class options) + (remove :class options) + options))) + `(progn + ;; system must be registered before we parse the body, otherwise + ;; we recur when trying to find an existing system of the same name + ;; to reuse options (e.g. pathname) from + (let ((s (system-registered-p ',name))) + (cond ((and s (eq (type-of (cdr s)) ',class)) + (setf (car s) (get-universal-time))) + (s + #+clisp + (sysdef-error "Cannot redefine the existing system ~A with a different class" s) + #-clisp + (change-class (cdr s) ',class)) + (t + (register-system (quote ,name) + (make-instance ',class :name ',name))))) + (parse-component-form nil (apply + #'list + :module (coerce-name ',name) + :pathname + (or ,pathname + (pathname-sans-name+type *load-truename*) + *default-pathname-defaults*) + ',component-options)))))) + (defun class-for-type (parent type) (let ((class (find-class @@ -617,7 +660,7 @@ Returns the new tree (which probably shares structure with the old one)" ;; remove-keys form. important to keep them in sync components pathname default-component-class perform explain output-files operation-done-p - depends-on serialize in-order-to class + depends-on serialize in-order-to ;; list ends &allow-other-keys) options (declare (ignore serialize)) @@ -625,9 +668,7 @@ Returns the new tree (which probably shares structure with the old one)" (let* ((other-args (remove-keys '(components pathname default-component-class perform explain output-files operation-done-p - depends-on serialize in-order-to - ;; XXX I seem to need this - class) + depends-on serialize in-order-to) rest)) (ret (or (find-component parent name) diff --git a/cclan.lisp b/cclan.lisp index ca903efc..edbcf729 100644 --- a/cclan.lisp +++ b/cclan.lisp @@ -138,6 +138,7 @@ binary: binary-indep binary-arch .PHONY: build clean binary-indep binary-arch binary install configure " (component-name system) changelog-file-name))) +#+infix (defun write-debian-control (stream system) (format stream "Source: ~A Section: devel @@ -244,7 +245,7 @@ exit 0 ;; FIXME: I'm sure this is wrong (+ (* (truncate tz) 100) (mod (* tz 60) 60))))) - +#+infix (defun write-debian-changelog (stream system) (format stream "~A (~A-1) cclan; urgency=low diff --git a/systems/db-sockets.system b/systems/db-sockets.system index 6a2c0514..6ccd2c80 100644 --- a/systems/db-sockets.system +++ b/systems/db-sockets.system @@ -24,9 +24,9 @@ (princ (list filename output-file real-output-file tmp-c-source tmp-a-dot-out tmp-constants)) (terpri) - #+nil - (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SOCKETS")) + (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "DB-SOCKETS-SYSTEM")) filename tmp-c-source :sockets-internal) + #+nil (c-constants-extract filename tmp-c-source :sockets-internal) (and (= (run-shell-command @@ -66,10 +66,11 @@ (module-components dso))))) (error 'operation-error :operation operation :component dso)))) +;; XXX this is overridden later (defmethod perform ((operation load-op) (dso unix-dso)) (let ((dso-name (unix-name (car (output-files (make-instance 'compile-op) dso))))) - #+sbcl (sb-sys::load-1-foreign dso-name) + #+sbcl (sb-alien:load-1-foreign dso-name) #+cmu (system::load-object-file dso-name))) @@ -94,14 +95,16 @@ (perform co c) (let ((filename (car (output-files co c)))) #+cmu (system::load-object-file filename) - #+sbcl (sb-sys::load-1-foreign filename)))) + #+sbcl (sb-alien:load-1-foreign filename)))) (defsystem db-sockets :components ((:file "defpackage" :depends-on ("rt")) (:file "split" :depends-on ("defpackage")) - (:unix-dso "alien" - :components ((:file "undefs.c") - (:file "get-h-errno.c"))) + (:file "array-data" :depends-on ("defpackage")) + q (:unix-dso "alien" + :pathname "." + :components ((:c-source-file "undefs") + (:c-source-file "get-h-errno"))) (:file "malloc" :depends-on ("defpackage")) (:file "foreign-glue" :depends-on ("defpackage" "malloc")) (:constants-file "constants" -- GitLab