July 2004 - cells-cvs@common-lisp.net - mailman3.common-lisp.net

[cells-cvs] CVS update: cell-cultures/celtic/celtic.lisp
by Thomas F. Burdick 05 Jul '04

05 Jul '04

Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv19339/celtic Modified Files: celtic.lisp Log Message: Changes for SBCL Date: Mon Jul 5 12:29:30 2004 Author: tburdick Index: cell-cultures/celtic/celtic.lisp diff -u cell-cultures/celtic/celtic.lisp:1.3 cell-cultures/celtic/celtic.lisp:1.4 --- cell-cultures/celtic/celtic.lisp:1.3 Sun Jul 4 11:59:43 2004 +++ cell-cultures/celtic/celtic.lisp Mon Jul 5 12:29:30 2004 @@ -56,7 +56,9 @@ (error "Cannot create process.")) proc ) - #+:sbcl (let ((proc (sb-ext:run-program program args :input :stream :output :stream :wait wt))) + #+:sbcl (let ((proc (sb-ext:run-program + program args :search t + :input :stream :output :stream :wait wt))) (unless proc (error "Cannot create process.")) (make-two-way-stream @@ -83,8 +85,7 @@ ;;; start wish and set *w* (defun tk-start () - #+:sbcl (setf *w* (do-execute "/usr/bin/wish" '("-name" "Cells-LTk"))) - #-:sbcl (setf *w* (do-execute "wish84" '("-name" "Visual Apropos")))) + (setf *w* (do-execute "wish" '("-name" "Visual Apropos")))) (defun tk-send (text) "send a string to wish"

1 0

[cells-cvs] CVS update: cell-cultures/asdf-registry/create-symlinks.sh
by Thomas F. Burdick 05 Jul '04

05 Jul '04

Update of /project/cells/cvsroot/cell-cultures/asdf-registry In directory common-lisp.net:/tmp/cvs-serv5212/asdf-registry Modified Files: create-symlinks.sh Log Message: Added celtic and clyde. Date: Mon Jul 5 12:26:44 2004 Author: tburdick Index: cell-cultures/asdf-registry/create-symlinks.sh diff -u cell-cultures/asdf-registry/create-symlinks.sh:1.1 cell-cultures/asdf-registry/create-symlinks.sh:1.2 --- cell-cultures/asdf-registry/create-symlinks.sh:1.1 Tue Jun 29 18:08:33 2004 +++ cell-cultures/asdf-registry/create-symlinks.sh Mon Jul 5 12:26:44 2004 @@ -1,61 +1,65 @@ +rm -f asdf-aclproj.asd; if [ -d ../asdf-aclproj ]; then echo Adding asdf-aclproj.asd; - rm -f asdf-aclproj.asd; ln -s ../asdf-aclproj/asdf-aclproj.asd asdf-aclproj.asd; fi +rm -f cello.asd cellocore.asd; if [ -d ../cello ]; then echo Adding cello.asd; - rm -f cello.asd; ln -s ../cello/cello.asd cello.asd; echo Adding cellocore.asd; - rm -f cellocore.asd; ln -s ../cello/cellocore.asd cellocore.asd; fi +rm -f cellodemo.asd; if [ -d ../cellodemo ]; then echo Adding cellodemo.asd; - rm -f cellodemo.asd; ln -s ../cellodemo/cellodemo.asd cellodemo.asd; fi +rm -f cells.asd cells-test.asd; if [ -d ../cells ]; then echo Adding cells.asd; - rm -f cells.asd; ln -s ../cells/cells.asd cells.asd; echo Adding cells-test.asd; - rm -f cells-test.asd; - ln -s ../cells/cells-test.asd cells-test.asd; + ln -s ../cells/cells-test/cells-test.asd cells-test.asd; fi +rm -f celtic.asd; +if [ -d ../celtic ]; then + echo Adding celtic.asd; + ln -s ../celtic/celtic.asd celtic.asd; +fi + +rm -f clyde.asd; +if [ -d ../clyde ]; then + echo Adding clyde.asd; + ln -s ../clyde/clyde.asd clyde.asd; +fi + +rm -f cl-magick.asd; if [ -d ../cl-magick ]; then echo Adding cl-magick.asd; - rm -f cl-magick.asd; ln -s ../cl-magick/cl-magick.asd cl-magick.asd; fi +rm -f cl-openal.asd; if [ -d ../cl-openal ]; then echo Adding cl-openal.asd; - rm -f cl-openal.asd; ln -s ../cl-openal/cl-openal.asd cl-openal.asd; fi +rm -f cl-opengl.asd; if [ -d ../cl-opengl ]; then echo Adding cl-opengl.asd; - rm -f cl-opengl.asd; ln -s ../cl-opengl/cl-opengl.asd cl-opengl.asd; fi +rm -f ffi-extender.asd; if [ -d ../ffi-extender ]; then echo Adding ffi-extender.asd; - rm -f ffi-extender.asd; ln -s ../ffi-extender/ffi-extender.asd ffi-extender.asd; -fi - -if [ -d ../ide/cloucell ]; then - echo Adding cloucell.asd; - rm -f cloucell.asd; - ln -s ../ide/cloucell/cloucell.asd cloucell.asd; fi

1 0

[cells-cvs] CVS update: cell-cultures/asdf-aclproj/asdf-aclproj.lisp
by Thomas F. Burdick 05 Jul '04

05 Jul '04

Update of /project/cells/cvsroot/cell-cultures/asdf-aclproj In directory common-lisp.net:/tmp/cvs-serv29624/asdf-aclproj Modified Files: asdf-aclproj.lisp Log Message: Cleaned up the packages a bit. Date: Mon Jul 5 12:26:00 2004 Author: tburdick Index: cell-cultures/asdf-aclproj/asdf-aclproj.lisp diff -u cell-cultures/asdf-aclproj/asdf-aclproj.lisp:1.3 cell-cultures/asdf-aclproj/asdf-aclproj.lisp:1.4 --- cell-cultures/asdf-aclproj/asdf-aclproj.lisp:1.3 Wed Jun 30 20:48:54 2004 +++ cell-cultures/asdf-aclproj/asdf-aclproj.lisp Mon Jul 5 12:26:00 2004 @@ -22,19 +22,27 @@ ;;; A hack to load Allegro's .lpr project files with ASDF. ;;; -(defpackage :asdf-aclproj +(defpackage :asdf-aclproj-impl (:use :cl) - (:export #:lpr-project-file)) + (:export #:lpr-project-file + #:define-project + #:project + #:module + #:project-module)) -(in-package :asdf-aclproj) +(defpackage :asdf-aclproj + (:use :asdf-aclproj-impl) + (:export #:lpr-project-file)) (defpackage :asdf-aclproj-user (:use :cl) (:import-from :asdf-aclproj - asdf-aclproj::define-project - asdf-aclproj::project - asdf-aclproj::module - asdf-aclproj::project-module)) + #:define-project + #:project + #:module + #:project-module)) + +(in-package :asdf-aclproj-impl) ;;; ;;; Classes for ASDF

1 0

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/ide/cloucell In directory common-lisp.net:/tmp/cvs-serv5472/ide/cloucell Removed Files: 01-cell-basics.lisp cloucell.asd cloucell.lpr ct-item-stack.lisp ct-slot-stack.lisp edt-window.lisp inspection.lisp inspector-toolbar.lisp inspector-window.lisp object-inspector-01.lisp object-inspector-02.lisp outline.lisp slot-inspector.lisp structure-view.lisp Log Message: Date: Sun Jul 4 11:59:48 2004 Author: ktilton

1 0

[cells-cvs] CVS update: cell-cultures/clyde/clyde.lpr
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/clyde In directory common-lisp.net:/tmp/cvs-serv5472/clyde Added Files: clyde.lpr Log Message: Date: Sun Jul 4 11:59:48 2004 Author: ktilton

1 0

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/clyde/cloucell In directory common-lisp.net:/tmp/cvs-serv5472/clyde/cloucell Added Files: 01-cell-basics.lisp cloucell.asd cloucell.lpr ct-item-stack.lisp ct-slot-stack.lisp edt-window.lisp inspection.lisp inspector-toolbar.lisp inspector-window.lisp object-inspector-01.lisp object-inspector-02.lisp outline.lisp slot-inspector.lisp structure-view.lisp Log Message: Date: Sun Jul 4 11:59:46 2004 Author: ktilton

1 0

[cells-cvs] CVS update: cell-cultures/utils-kt/debug.lisp cell-cultures/utils-kt/defpackage.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/utils-kt In directory common-lisp.net:/tmp/cvs-serv5472/utils-kt Modified Files: debug.lisp defpackage.lisp Log Message: Date: Sun Jul 4 11:59:46 2004 Author: ktilton Index: cell-cultures/utils-kt/debug.lisp diff -u cell-cultures/utils-kt/debug.lisp:1.2 cell-cultures/utils-kt/debug.lisp:1.3 --- cell-cultures/utils-kt/debug.lisp:1.2 Tue Jun 29 01:58:49 2004 +++ cell-cultures/utils-kt/debug.lisp Sun Jul 4 11:59:45 2004 @@ -55,7 +55,7 @@ (assert (stringp ,(car os))) (call-trc t ,@os)) ;;,(car os) ,tgt ,@(cdr os))) (progn - (break :trcfailed) + ;;(break "trcfailed") (count-it :trcfailed))) (count-it :tgtnileval))))))) Index: cell-cultures/utils-kt/defpackage.lisp diff -u cell-cultures/utils-kt/defpackage.lisp:1.3 cell-cultures/utils-kt/defpackage.lisp:1.4 --- cell-cultures/utils-kt/defpackage.lisp:1.3 Wed Jun 30 14:02:12 2004 +++ cell-cultures/utils-kt/defpackage.lisp Sun Jul 4 11:59:46 2004 @@ -23,9 +23,13 @@ (in-package :cl-user) (defpackage :utils-kt - (:use #:common-lisp) + (:nicknames #:ukt) + (:use #:common-lisp + #-(or cormanlisp cmu sbcl) #:clos + #+sbcl #:sb-mop + #+mcl #:ccl) (:export - #:eko #:eko-if #:count-it #:trc #:maptimes #:bwhen #:bif #:xor + #:eko #:count-it #:count-of #:trc #:maptimes #:bwhen #:bif #:xor "WITH-DYNAMIC-FN" #:last1 #:packed-flat! #:with-metrics "TRUE" "SHORTC" #:intern$ #:defconstant-once "*COUNT*" "*STOP*" "*DBG*" "*TRCDEPTH*"

1 0

[cells-cvs] CVS update: cell-cultures/cl-opengl/cl-opengl.lisp cell-cultures/cl-opengl/gl-functions.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cl-opengl In directory common-lisp.net:/tmp/cvs-serv5472/cl-opengl Modified Files: cl-opengl.lisp gl-functions.lisp Log Message: Date: Sun Jul 4 11:59:45 2004 Author: ktilton Index: cell-cultures/cl-opengl/cl-opengl.lisp diff -u cell-cultures/cl-opengl/cl-opengl.lisp:1.1 cell-cultures/cl-opengl/cl-opengl.lisp:1.2 --- cell-cultures/cl-opengl/cl-opengl.lisp:1.1 Sat Jun 26 11:38:40 2004 +++ cell-cultures/cl-opengl/cl-opengl.lisp Sun Jul 4 11:59:45 2004 @@ -27,7 +27,8 @@ (defpackage #:cl-opengl (:nicknames #:ogl) (:use #:common-lisp #:uffi #:ffx) - (:export #:glut-get-window + (:export #:*ogl-listing-p* + #:glut-get-window #:glut-set-window #:glut-post-redisplay #:with-matrix Index: cell-cultures/cl-opengl/gl-functions.lisp diff -u cell-cultures/cl-opengl/gl-functions.lisp:1.1 cell-cultures/cl-opengl/gl-functions.lisp:1.2 --- cell-cultures/cl-opengl/gl-functions.lisp:1.1 Sat Jun 26 11:38:41 2004 +++ cell-cultures/cl-opengl/gl-functions.lisp Sun Jul 4 11:59:45 2004 @@ -22,7 +22,7 @@ (in-package #:cl-opengl) - +(defparameter *ogl-listing-p* nil) (defun-ogl :void "open-gl" "glFlush" ())

1 0

[cells-cvs] CVS update: cell-cultures/clyde/visual-apropos/visual-apropos.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/clyde/visual-apropos In directory common-lisp.net:/tmp/cvs-serv5472/clyde/visual-apropos Modified Files: visual-apropos.lisp Log Message: Date: Sun Jul 4 11:59:45 2004 Author: ktilton Index: cell-cultures/clyde/visual-apropos/visual-apropos.lisp diff -u cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.1 cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.2 --- cell-cultures/clyde/visual-apropos/visual-apropos.lisp:1.1 Sun Jun 27 16:52:25 2004 +++ cell-cultures/clyde/visual-apropos/visual-apropos.lisp Sun Jul 4 11:59:45 2004 @@ -21,12 +21,7 @@ #| do list -why some symbols show without classification? -close up list of symbols for gaps -add "String" with underscore for symbol entry -make symbol entry also a pop-up -get packages pop-up working and honored -make symbol list into proper listbox +at least show search in entry |# @@ -40,97 +35,224 @@ (defun vis-apropos () (make-be 'visual-apropos - :sub-symbol 'thread)) + :sub-symbol 'padding)) -(defmodel visual-apropos (frame) +(defmodel visual-apropos (frame-stack) ((symbols :initarg :symbols :initform nil :accessor symbols) (sub-symbol :initarg :sub-symbol :initform nil :accessor sub-symbol)) (:default-initargs - :layout (layout-stack) :symbols (c? (apropos-list (^sub-symbol))) + :pady 2 + :padx 4 + :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") :kids (c? (list (search-for-symbol) - (frame-row () - (frame-stack () - (exported-only) - (package-searching)) - (show-which-symbols)) + (frame-row + :padx 8 + :layout (pack-layout? "-side left -fill x") + :kids (c? (list + (frame-stack + :kids (c? (list + (checkbutton :md-name :exported-only + :text "Exported Only" + :underline 1 + :md-value (c-in nil) + :command (lambda (self) + (setf (^md-value) (not (^md-value))))) + (show-which-symbols)))) + (package-filtering)))) + (label :text (c? (format nil "Symbols containing ~a" + (sub-symbol .parent))) + :underline 4) (symbol-list))))) (defun search-for-symbol () - (frame-row () - (label :text "String:" - :underline 4) - (entry :md-name :search-string - :text (c? (symbol-name (md-value (upper self visual-apropos))))) - (button :text "Search" - :underline 0 - :command (lambda (self) - (setf (md-value (upper self visual-apropos)) - (md-value (fm^ :search-string))))))) - -(defun exported-only () - (checkbutton :md-name :exported-only - :text "Show Exported Symbols Only" - :md-value (c-in nil) - :command (lambda (self) - (setf (^md-value) (not (^md-value)))))) - -(defun package-searching () - (labelframe :text "Package(s) to Search" - :layout (layout-row) - :kids (c? (list - (checkbutton :md-name :all-pkgs - :text "All" - :md-value (c-in t) + (frame-row + :relief 'ridge + :padx 8 + :layout (pack-layout? "-side left -fill x -anchor nw") + :kids-layout (c? (format nil + "pack ~a -side left; pack ~a -side left -expand 1 -fill x; pack ~a -side right" + (path (kid1 self)) + (path (second (^kids))) + (path (third (^kids))))) + :kids (c? (list (label :text "String:" + :underline 4) + (entry :md-name :search-string + :text (c? (symbol-name (sub-symbol (upper self visual-apropos)))) + :width 64) + (button :text "Search" + :underline 0 :command (lambda (self) - (setf (^md-value) (not (^md-value))))) - (label :text "FNYI: Package pop-up menu"))))) + (setf (md-value (upper self visual-apropos)) + (md-value (fm^ :search-string))))))))) + +; --- symbol package filtering ------------------------------- + +(defun package-filtering () + (labelframe-row + :text " Package(s) to Search " + :layout (pack-layout? "-side left -fill x -expand 1") + :kids (c? (list + (checkbutton :md-name :all-pkgs + :text "All" + :underline 1 + :md-value (c-in t) + :command (lambda (self) + (setf (^md-value) (not (^md-value))))) + (scrolled-list + :md-name :in-package + :list-height 4 + :layout (pack-layout? "-side left -fill x -expand 1") + :enabled (c? (not (md-value (psib)))) + :list-items (c? (loop for p in (list-all-packages) + collecting (make-instance 'listbox-item + :md-value p + :item-text (down$ (package-name p)))))))))) + +; --- symbol binding filtering --------------------------------------- (defun show-which-symbols () (labelframe-selector :md-name :which-symbols - :text "Show" + :text " With bindings " :tk-variable 'which-symbols :layout (c? (format nil "pack ~a -side {left}~:{; grid ~a -column ~d -row ~d -sticky w~}" (path self) (mapcar (lambda (k) (list (path k)(floor (kid-no k) 2) (mod (kid-no k) 2))) (^kids)))) - :initial-selection (c? (fm-other :all)) - :selection (c-in nil) + :selection (c-in :any) :kids (c? (flet ((rb (n) (radiobutton :md-name n :text (string-capitalize (string n)) :tk-variable (tk-variable self) :value n - :layout nil :underline 0))) - (list (rb :all)(rb :functions)(rb :variables)(rb :classes)))))) + :layout nil + :underline 0))) + (list (rb :any)(rb :functions)(rb :variables)(rb :classes)))))) (defun symbol-list () - (canvas :md-name :symbol-list - :kids (c? (let ((root (upper self visual-apropos))) - (loop for symbol in (symbols root) - for n upfrom 0 - when (va-show-symbol-p self symbol) - collect - (make-instance 'symbol-indicator$ - :anchor "nw" - :md-value symbol - :coords (list 10 (* n 20)))))))) + (frame-stack :md-name :symbol-list + :layout (pack-layout? "-side top -expand 1 -fill both") + :width 64 + :background 'red + :kids (c? (list + (frame-row + :md-name :sym-sort + :md-value (c-in nil) + :relief 'groove + :layout (pack-layout? "-side top -fill x -anchor w") + :kids (c? (flet ((va-button (&rest args) + (apply 'make-instance 'va-sorter args))) + (list + (va-button :layout nil + :md-name :sym-sym :text "Symbol Name" :width 28) + (va-button :layout nil :padx 10 + :text "Package" + :sort-string-fn 'package-name) + (va-button :layout nil :text "Function") + (va-button :layout nil :text "Setf" + :sort-string-fn (lambda (fn) + (if fn "x" ""))) + (va-button :layout nil :text "Var" :padx 5) + (va-button :layout nil :text "Class") + (va-button :layout nil :text "Exp"))))) + (scrolled-list + :layout (pack-layout? "-side top -expand 1 -fill both") + :width 64 + :list-height nil + :background 'white + :md-value (c? (let ((root (upper self visual-apropos))) + (loop for s in (symbols root) + for n upfrom 0 + when (va-show-symbol-p self s) + collect + (list + (symbol-name s) + (symbol-package s) + (cond + ((special-operator-p s) "special") + ((macro-function s) "macro") + ((fboundp s) + (if (typep (fdefinition s) 'generic-function) + "gf" "func")) + (t "")) + (fboundp `(setf ,s)) + (when (boundp s) + (if (constantp s) "con" "var")) + (find-class s nil) + (exported-p s))))) + :list-items (c? (let ((sorter (let ((ss (fm^ :sym-sort))) + (or (md-value (fm^ :sym-sort)) + (kid1 ss))))) + (sort (loop for si in (^md-value) + collect (make-instance 'va-symbol-info + :md-value si)) + (sort-button-predicate sorter) + :key (sort-button-key sorter))))))))) + +(defmodel sort-button (button) + ((sort-button-predicate :initarg :sort-button-predicate :accessor sort-button-predicate + :initform #'string<) + (sort-button-key :initarg :sort-button-key :accessor sort-button-key + :initform #'identity))) + +(defmodel va-sorter (sort-button) + ((sort-string-fn :initform 'string :initarg :sort-string-fn :accessor sort-string-fn)) + (:default-initargs + :command (lambda (self) + (let* ((ss (fm^ :sym-sort))) + (if (eq self (or (md-value ss) (kid1 ss))) + (setf (sort-button-predicate self) + (if (eq (sort-button-predicate self) 'string<) + 'string> 'string<)) + (setf (md-value ss) self)))) + :sort-button-predicate (c-in 'string<) + :sort-button-key (c? (lambda (si) + (funcall (^sort-string-fn) + (elt (md-value si) (kid-no self))))))) + +(defmodel va-symbol-info (listbox-item) + () + (:default-initargs + :item-text (c? (destructuring-bind (sname pkg fn setf var class exp) + (^md-value) + (format nil "~(~a~) ~27,T~(~a~) ~36,T~a ~43,T~a ~46,T~a ~52,T~a ~57,T~a" + (if (< (length sname) 26) + sname + (conc$ (left$ sname 22) "...")) + (down$ (let ((nn (car (package-nicknames pkg)))) + (if (plusp (length nn)) + nn + (package-name pkg)))) + (or fn "") + (if setf "x" "") + (or var "") + (if class "x" "") + (if exp "x" "")))))) + +(defun exported-p (symbol) + (eq :external (symbol-status symbol))) (defun va-show-symbol-p (self symbol) (when (md-value (fm^ :exported-only)) - (unless (eq :external (symbol-status symbol)) + (unless (exported-p symbol) (return-from va-show-symbol-p nil))) - (let ((rb (selection (fm^ :which-symbols)))) - (when rb ;; not during initialization since echo of init-sel deferred (FIX) - (unless (ecase (md-name rb) - (:all t) + (let ((which (selection (fm^ :which-symbols)))) + (unless (ecase which + (:any t) (:functions (fboundp symbol)) (:classes (find-class symbol nil)) (:variables (boundp symbol))) - (return-from va-show-symbol-p nil)))) + (return-from va-show-symbol-p nil))) + (unless (or (md-value (fm^ :all-pkgs)) + (bIf (sel (selection (fm^ :in-package))) + (eq (symbol-package symbol) + (md-value (elt (list-items (fm^ :in-package)) sel))) + t)) + (return-from va-show-symbol-p nil)) + t) (defun symbol-status (sym)

1 0

[cells-cvs] CVS update: cell-cultures/cl-magick/wand-texture.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cl-magick In directory common-lisp.net:/tmp/cvs-serv5472/cl-magick Modified Files: wand-texture.lisp Log Message: Date: Sun Jul 4 11:59:44 2004 Author: ktilton Index: cell-cultures/cl-magick/wand-texture.lisp diff -u cell-cultures/cl-magick/wand-texture.lisp:1.1 cell-cultures/cl-magick/wand-texture.lisp:1.2 --- cell-cultures/cl-magick/wand-texture.lisp:1.1 Sat Jun 26 11:38:39 2004 +++ cell-cultures/cl-magick/wand-texture.lisp Sun Jul 4 11:59:44 2004 @@ -66,7 +66,7 @@ (pixels (wand-get-image-pixels (mgk-wand self) 0 0 (car (image-size self)) (cdr (image-size self))))) - (assert (not clo::*listingp*)) + ;; (assert (not *ogl-listing-p*)) (gl-bind-texture gl_texture_2d tx) (progn ;; useless?? @@ -92,7 +92,7 @@ &aux (sz (image-size self))) #+not (format t "~&wand-render tex ~a ~a ~a" (texture-name self) self :size sz :bbox (list left top right bottom)) - (assert clo::*listingp*) + ;;(assert *ogl-listing-p*) (with-attrib (gl_texture_bit);; gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit) (wand-texture-activate self) #+tilingworksbutslower

1 0