Update of /project/cells-gtk/cvsroot/root In directory common-lisp.net:/tmp/cvs-serv13216

Modified Files: asdf.lisp load.lisp Log Message: Port to AllegroCl and Lispworks on win32 using UFFI Date: Sun Dec 5 07:33:21 2004 Author: ktilton

Index: root/asdf.lisp diff -u root/asdf.lisp:1.1 root/asdf.lisp:1.2 --- root/asdf.lisp:1.1 Fri Nov 19 00:39:51 2004 +++ root/asdf.lisp Sun Dec 5 07:33:21 2004 @@ -1,4 +1,4 @@ -;;; This is asdf: Another System Definition Facility. $Revision: 1.1 $ +;;; This is asdf: Another System Definition Facility. $Revision: 1.2 $ ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; cclan-list@lists.sf.net. But note first that the canonical @@ -107,7 +107,7 @@

(in-package #:asdf)

-(defvar *asdf-revision* (let* ((v "$Revision: 1.1 $") +(defvar *asdf-revision* (let* ((v "$Revision: 1.2 $") (colon (or (position #: v) -1)) (dot (position #. v))) (and v colon dot @@ -794,6 +794,17 @@

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; invoking operations + +(defun opxx (operation-class system &rest args) + (let* ((op (apply #'make-instance operation-class + :original-initargs args args)) + (*verbose-out* + (if (getf args :verbose t) + *trace-output* + (make-broadcast-stream))) + (system (if (typep system 'component) system (find-system system))) + (steps (traverse op system))) + (print steps)))

(defun operate (operation-class system &rest args) (let* ((op (apply #'make-instance operation-class

Index: root/load.lisp diff -u root/load.lisp:1.1 root/load.lisp:1.2 --- root/load.lisp:1.1 Fri Nov 19 00:39:51 2004 +++ root/load.lisp Sun Dec 5 07:33:21 2004 @@ -1,16 +1,50 @@ -(defparameter *utils-kt-path* "../utils-kt/") -(defparameter *cells-path* "../cells/") +(in-package :cl-user)

-#-asdf (load (make-pathname :name "asdf" :type "lisp")) +#-asdf +(eval-when (compile load eval) + #+lispworks + (setq *HANDLE-EXISTING-DEFPACKAGE* '(:modify))

-(pushnew *utils-kt-path* asdf:*central-registry*) -(pushnew *cells-path* asdf:*central-registry*) -(pushnew "./gtk-ffi/" asdf:*central-registry*) -(pushnew "./cells-gtk/" asdf:*central-registry*) -(pushnew "./cells-gtk/test-gtk/" asdf:*central-registry*) + (load (make-pathname :directory '(:absolute "000000" "root") + :name "asdf" :type "lisp")))

-(asdf:operate 'asdf:load-op :cells-gtk :force nil) -(asdf:operate 'asdf:load-op :test-gtk :force nil) +(progn ;; setup + (defparameter *utils-kt-path* "/cell-cultures/utils-kt/") + (defparameter *cells-path* "/cell-cultures/cells/") + (defparameter *cells-gtk-root* + (make-pathname :directory '(:absolute "000000" "root"))) + + (push (make-pathname :directory '(:absolute "000000" "uffi")) + asdf:*central-registry*) + + (push *utils-kt-path* asdf:*central-registry*) + (push *cells-path* asdf:*central-registry*) + (push (make-pathname :directory '(:absolute "cell-cultures" "ffi-extender")) + asdf:*central-registry*) + + (push (merge-pathnames + (make-pathname :directory '(:relative "gtk-ffi")) + *cells-gtk-root*) + asdf:*central-registry*) + + (push (merge-pathnames + (make-pathname :directory '(:relative "cells-gtk")) + *cells-gtk-root*) + asdf:*central-registry*) + + (push (merge-pathnames + (make-pathname :directory '(:relative "cells-gtk" "test-gtk")) + *cells-gtk-root*) + asdf:*central-registry*)) + +;(Asdf:operate 'asdf:load-op :utils-kt :force t) +;(Asdf:operate 'asdf:load-op :cells :force t) +;(Asdf:operate 'asdf:load-op :uffi :force t) +;(Asdf:operate 'asdf:load-op :ffi-extender :force t) +;(Asdf:operate 'asdf:load-op :gtk-ffi :force nil) +;(Asdf:operate 'asdf:load-op :cells-gtk :force nil) +(Asdf:operate 'asdf:load-op :test-gtk :force nil) + +#+test +(test-gtk::gtk-demo)

-(defun gtk-demo () - (cells-gtk:start-app 'test-gtk::test-gtk)) \ No newline at end of file