Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv2729/utils-kt
Modified Files: datetime.lisp debug.lisp defpackage.lisp detritus.lisp flow-control.lisp strings.lisp utils-kt.lpr Added Files: core.lisp Log Message:
--- /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2006/07/06 22:10:03 1.3 +++ /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2007/11/30 16:51:20 1.4 @@ -197,5 +197,8 @@
(defun hyphenated-time-string () (substitute #- #: (ymdhmsh))) + +#+test +(hyphenated-time-string)
--- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2007/01/29 06:44:04 1.14 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2007/11/30 16:51:20 1.15 @@ -27,6 +27,7 @@ (defvar *stop* nil)
(defun utils-kt-reset () + (clock-off :ukt-reset) (setf *count* nil *stop* nil *dbg* nil) @@ -121,3 +122,21 @@ ,form-measured) ,@postlude))
+(export! clock clock-0 clock-off) + +(defvar *clock*) + +(defun clock-off (key) + (when (boundp '*clock*) + (print (list :clock-off key)) + (makunbound '*clock*))) + +(defun clock-0 (key &aux (now (get-internal-real-time))) + (setf *clock* (cons now now)) + (print (list :clock-initialized-by key))) + +(defun clock (&rest keys &aux (now (get-internal-real-time))) + (when (boundp '*clock*) + (print (list* :clock (- now (cdr *clock*)) :tot (- now (car *clock*)) :at keys)) + (setf (cdr *clock*) now))) + --- /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2006/09/05 18:40:48 1.6 +++ /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2007/11/30 16:51:20 1.7 @@ -17,6 +17,9 @@
(in-package :cl-user)
+(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *features* (delete :its-alive! *features*))) + (defpackage :utils-kt (:nicknames #:ukt) (:use #:common-lisp @@ -41,26 +44,3 @@ #+(and mcl (not openmcl-partial-mop)) #:class-slots ))
-(in-package :utils-kt) - -(defmacro eval-now! (&body body) - `(eval-when (:compile-toplevel :load-toplevel :execute) - ,@body)) - -(defmacro export! (&rest symbols) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (export ',symbols))) - -(defmacro define-constant (name value &optional docstring) - "Define a constant properly. If NAME is unbound, DEFCONSTANT -it to VALUE. If it is already bound, and it is EQUAL to VALUE, -reuse the SYMBOL-VALUE of NAME. Otherwise, DEFCONSTANT it again, -resulting in implementation-specific behavior." - `(defconstant ,name - (if (not (boundp ',name)) - ,value - (let ((value ,value)) - (if (equal value (symbol-value ',name)) - (symbol-value ',name) - value))) - ,@(when docstring (list docstring)))) --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2007/01/29 06:44:04 1.13 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2007/11/30 16:51:20 1.14 @@ -49,10 +49,7 @@ (defun xor (c1 c2) (if c1 (not c2) c2))
-(export! push-end collect collect-if) - -(defmacro push-end (item place ) - `(setf ,place (nconc ,place (list ,item)))) +(export! collect collect-if)
(defun collect (x list &key (key 'identity) (test 'eql)) (loop for i in list @@ -60,10 +57,22 @@ collect i))
(defun collect-if (test list) - (loop for i in list - when (funcall test i) - collect i)) + (remove-if-not test list)) + +(defun test-setup () + #-its-alive! + (ide.base::find-new-prompt-command + (cg.base::find-window :listener-frame))) + +#+test +(test-setup) + +(defun test-prep () + (test-setup)) +(defun test-init () + (test-setup))
+(export! test-setup test-prep test-init)
;;; --- FIFO Queue ----------------------------- @@ -142,7 +151,8 @@ do (bwhen (fname (pathname-name file)) (format t "~&~v,8t~a ~,40t~d" (1+ depth) fname lines)) summing lines))) - (format t "~&~v,8t~a ~,50t~d" depth (pathname-directory path) directory-lines) + (unless (zerop directory-lines) + (format t "~&~v,8t~a ~,50t~d" depth (pathname-directory path) directory-lines)) directory-lines))
((find (pathname-type path) '("cl" "lisp" "c" "h" "java") @@ -162,7 +172,14 @@ #+(or) (line-count (make-pathname :device "c" - :directory `(:absolute "0dev" "Algebra")) t) + :directory `(:absolute "0dev"))) + +#+(or) +(loop for d1 in '("cl-s3" "kpax" "puri-1.5.1" "s-base64" "s-http-client" "s-http-server" "s-sysdeps" "s-utils" "s-xml") + summing (line-count (make-pathname + :device "c" + :directory `(:absolute "1-devtools" ,d1)))) +
(export! tree-includes tree-traverse tree-intersect)
--- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2007/01/29 06:44:04 1.10 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2007/11/30 16:51:20 1.11 @@ -59,6 +59,10 @@ (defun tree-flatten (tree) (list-flatten! (copy-tree tree)))
+(export! push-end) +(defmacro push-end (item place ) + `(setf ,place (nconc ,place (list ,item)))) + (defun pair-off (list &optional (test 'eql)) (loop with pairs and copy = (copy-list list) while (cdr copy) @@ -184,8 +188,9 @@
(export! without-repeating)
- (let ((generators (make-hash-table :test 'equalp))) + (defun reset-without-repeating () + (setf generators (make-hash-table :test 'equalp))) (defun without-repeating (key all &optional (decent-interval (floor (length all) 2))) (funcall (or (gethash key generators) (setf (gethash key generators) --- /project/cells/cvsroot/cells/utils-kt/strings.lisp 2006/09/05 18:40:50 1.6 +++ /project/cells/cvsroot/cells/utils-kt/strings.lisp 2007/11/30 16:51:20 1.7 @@ -90,6 +90,9 @@ (defun left$ (s n) (subseq s 0 (max (min n (length s)) 0)))
+(export! cc$) +(defun cc$ (code) (string (code-char code))) + (defun mid$ (s offset length) (let* ((slen (length s)) (start (min slen (max offset 0))) --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2007/01/29 06:44:04 1.22 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2007/11/30 16:51:20 1.23 @@ -1,16 +1,10 @@ -;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.1 [Windows] (Sep 29, 2007 20:23)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
-(defpackage :COMMON-LISP - (:export #:list - #:make-instance - #:t - #:nil - #:quote)) - (define-project :name :utils-kt :modules (list (make-instance 'module :name "defpackage.lisp") + (make-instance 'module :name "core.lisp") (make-instance 'module :name "debug.lisp") (make-instance 'module :name "flow-control.lisp") (make-instance 'module :name "detritus.lisp") @@ -28,12 +22,13 @@ :runtime-modules nil :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") - :include-flags '(:local-name-info) - :build-flags '(:allow-debug :purify) + :include-flags (list :local-name-info) + :build-flags (list :allow-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil + :include-manifest-file-for-visual-styles t :default-command-line-arguments "+cx +t "Initializing"" - :additional-build-lisp-image-arguments '(:read-init-files nil) + :additional-build-lisp-image-arguments (list :read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard
--- /project/cells/cvsroot/cells/utils-kt/core.lisp 2007/11/30 16:51:26 NONE +++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2007/11/30 16:51:26 1.1 #|
Utils-kt core
Copyright (C) 1995, 2006 by Kenneth Tilton
This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL.
This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Lisp Lesser GNU Public License for more details.
|#
(in-package :utils-kt)
(defmacro eval-now! (&body body) `(eval-when (:compile-toplevel :load-toplevel :execute) ,@body))
(defmacro export! (&rest symbols) `(eval-when (:compile-toplevel :load-toplevel :execute) (export ',symbols)))
(defmacro define-constant (name value &optional docstring) "Define a constant properly. If NAME is unbound, DEFCONSTANT it to VALUE. If it is already bound, and it is EQUAL to VALUE, reuse the SYMBOL-VALUE of NAME. Otherwise, DEFCONSTANT it again, resulting in implementation-specific behavior." `(defconstant ,name (if (not (boundp ',name)) ,value (let ((value ,value)) (if (equal value (symbol-value ',name)) (symbol-value ',name) value))) ,@(when docstring (list docstring))))
(export! exe-path exe-dll font-path)
(defun exe-path () #+its-alive! (excl:current-directory) #-its-alive! (excl:path-pathname (ide.base::project-file ide.base:*current-project*)))
(defun font-path () (merge-pathnames (make-pathname :directory #+its-alive! (list :relative "font") #-its-alive! (append (butlast (pathname-directory (exe-path))) (list "TY Extender" "font"))) (exe-path)))
#+test (list (exe-path)(font-path))
(defmacro exe-dll (&optional filename) (assert filename) (concatenate 'string filename ".dll"))
#+chya (defun exe-dll (&optional filename) (merge-pathnames (make-pathname :name filename :type "DLL" :directory (append (butlast (pathname-directory (exe-path))) (list "dll"))) (exe-path)))
#+test (probe-file (exe-dll "openal32"))