[cells-gtk-cvs] CVS update: root/asdf.lisp root/load.lisp

[Kenny Tilton]

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 at 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