cells-cvs

cells-cvs@common-lisp.net

721 discussions

[cells-cvs] CVS cells/utils-kt
by fgoenninger 02 Dec '07

02 Dec '07

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv18803 Modified Files: utils-kt.asd Log Message: Changed: Now reflects latest changes from Kenny (as found in .lpr file) --- /project/cells/cvsroot/cells/utils-kt/utils-kt.asd 2006/10/17 21:28:40 1.2 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.asd 2007/12/02 18:31:59 1.3 @@ -18,11 +18,14 @@ :long-description "Low-level utilities used by all of Kenny's projects" :serial t :components ((:file "defpackage") + (:file "core") (:file "debug") (:file "flow-control") (:file "detritus") + (:file "quad") (:file "strings") - (:file "datetime"))) + (:file "datetime") + (:file "split-sequence"))) (defmethod perform ((o load-op) (c (eql (find-system :utils-kt)))) ; (pushnew "CELLS" *modules* :test #'string=)

1 0

[cells-cvs] CVS cells
by fgoenninger 02 Dec '07

02 Dec '07

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv18364 Modified Files: constructors.lisp Log Message: Changed: Moved all symbol exports to beginning of file. Removed: c?+n constructor was defined twice in file. --- /project/cells/cvsroot/cells/constructors.lisp 2007/11/30 16:51:18 1.17 +++ /project/cells/cvsroot/cells/constructors.lisp 2007/12/02 18:28:04 1.18 @@ -19,15 +19,28 @@ (in-package :cells) (eval-now! - (export '(c?n))) + (export '(.cache-bound-p + + ;; Cells Constructors + c?n + c?once + c?n-until + c?1 + c_1 + c?+n + + ;; Debug Macros and Functions + c?dbg + c_?dbg + c-input-dbg + + ))) ;___________________ constructors _______________________________ (defmacro c-lambda (&body body) `(c-lambda-var (slot-c) ,@body)) -(export! .cache-bound-p c?+n) - (defmacro c-lambda-var ((c) &body body) `(lambda (,c &aux (self (c-model ,c)) (.cache (c-value ,c)) @@ -72,8 +85,6 @@ :rule (c-lambda ,@body) ,@args)) -(export! c?once c?n-until c?1 c_1) - (defmacro c?once (&body body) `(make-c-dependent :code '(without-c-dependency ,@body) @@ -114,8 +125,6 @@ :lazy :until-asked :rule (c-lambda ,@body))) -(export! c?dbg c_?dbg c-input-dbg) - (defmacro c_?dbg (&body body) "Lazy until asked, then eagerly propagating" `(make-c-dependent

1 0

[cells-cvs] CVS cells
by fgoenninger 02 Dec '07

02 Dec '07

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv14095 Modified Files: cells.asd Log Message: Added: File variables.lisp --- /project/cells/cvsroot/cells/cells.asd 2006/08/22 15:02:04 1.6 +++ /project/cells/cvsroot/cells/cells.asd 2007/12/02 18:15:30 1.7 @@ -38,7 +38,8 @@ (:file "md-utilities") (:file "family") (:file "fm-utilities") - (:file "family-values"))) + (:file "family-values") + (:file "variables"))) (defmethod perform ((o load-op) (c (eql (find-system :cells)))) (pushnew :cells *features*))

1 0

[cells-cvs] CVS cells/gui-geometry
by fgoenninger 02 Dec '07

02 Dec '07

Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv13766 Modified Files: geo-data-structures.lisp Log Message: Added: Comments in code. No other change. --- /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2007/11/30 16:51:19 1.10 +++ /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2007/12/02 18:14:18 1.11 @@ -21,13 +21,10 @@ ;----------------------------- (defstruct v2 - (h 0 ) - (v 0 ) + (h 0 ) ;; horizontal coordinate + (v 0 ) ;; vertical coordinate ) -#+(or) -(instance-slots (mkv2 1 2)) - (defmethod print-object ((self v2) s) (format s "~a|~a" (v2-h self)(v2-v self)))

1 0

[cells-cvs] CVS cells
by ktilton 30 Nov '07

30 Nov '07

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv30806 Modified Files: family.lisp Log Message: --- /project/cells/cvsroot/cells/family.lisp 2007/11/30 16:51:18 1.20 +++ /project/cells/cvsroot/cells/family.lisp 2007/11/30 22:52:36 1.21 @@ -25,8 +25,7 @@ (defmodel model () ((.md-name :cell nil :initform nil :initarg :md-name :accessor md-name) (.fm-parent :cell nil :initform nil :initarg :fm-parent :accessor fm-parent) - (.value :initform nil :accessor value :initarg :value) - (zdbg :initform nil :accessor dbg :initarg :dbg))) + (.value :initform nil :accessor value :initarg :value))) (defmethod fm-parent (other) (declare (ignore other))

1 0

[cells-cvs] CVS cells/doc
by ktilton 30 Nov '07

30 Nov '07

Update of /project/cells/cvsroot/cells/doc In directory clnet:/tmp/cvs-serv30806/doc Modified Files: 01-Cell-basics.lisp Log Message: --- /project/cells/cvsroot/cells/doc/01-Cell-basics.lisp 2006/11/04 20:52:01 1.5 +++ /project/cells/cvsroot/cells/doc/01-Cell-basics.lisp 2007/11/30 22:52:36 1.6 @@ -335,11 +335,12 @@ () (:default-initargs :kids (c-in nil) ;; or we cannot add any addend kids later - :value (c? (reduce #'+ (kids self) + :value (c? (trc "val rule runs") + (reduce #'+ (kids self) :initial-value 0 :key #'value)))) -(defobserver value ((self summer)) +(defobserver .value ((self summer)) (trc "the sum of the values of the kids is" new-value)) (defobserver .kids ((self summer))

1 0

[cells-cvs] CVS cells
by ktilton 30 Nov '07

30 Nov '07

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv27387 Modified Files: cells.lisp integrity.lisp md-slot-value.lisp Log Message: --- /project/cells/cvsroot/cells/cells.lisp 2007/11/30 16:51:18 1.21 +++ /project/cells/cvsroot/cells/cells.lisp 2007/11/30 22:29:06 1.22 @@ -156,7 +156,7 @@ ) (c-stop args) (format t "c-break > stopping > ~a" args) - (apply 'break args)))) + (apply 'error args)))) --- /project/cells/cvsroot/cells/integrity.lisp 2007/11/30 16:51:18 1.18 +++ /project/cells/cvsroot/cells/integrity.lisp 2007/11/30 22:29:06 1.19 @@ -44,9 +44,6 @@ *within-integrity*) (defun call-with-integrity (opcode defer-info action) - (when (eq opcode :change) - (when (eq defer-info :focus) - (break "cwi focus change"))) (when *stop* (return-from call-with-integrity)) (if *within-integrity* --- /project/cells/cvsroot/cells/md-slot-value.lisp 2007/11/30 16:51:18 1.35 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2007/11/30 22:29:06 1.36 @@ -153,7 +153,7 @@ (setf caller-reiterated (eq caller c))) (c-break ;; break is problem when testing cells on some CLs "cell ~a midst askers (see above)" c) - (break "see listener for cell rule cycle diagnotics")) + (error "see listener for cell rule cycle diagnotics")) (multiple-value-bind (raw-value propagation-code) (calculate-and-link c)

1 0

[cells-cvs] CVS cells/cells-test
by ktilton 30 Nov '07

30 Nov '07

Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv27387/cells-test Modified Files: cells-test.lpr person.lisp test.lisp Log Message: --- /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2007/11/30 16:51:19 1.7 +++ /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2007/11/30 22:29:06 1.8 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Sep 29, 2007 20:23)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Oct 30, 2007 12:37)"; cg: "1.103.2.10"; -*- (in-package :cg-user) --- /project/cells/cvsroot/cells/cells-test/person.lisp 2006/03/16 05:22:08 1.3 +++ /project/cells/cvsroot/cells/cells-test/person.lisp 2007/11/30 22:29:06 1.4 @@ -167,8 +167,8 @@ ;; - all cells accessed are constant. ;; (ct-assert (null (md-slot-cell p 'speech))) - (ct-assert (md-slot-cell-flushed p 'speech)) - (ct-assert (c-optimized-away-p (md-slot-cell-flushed p 'speech))) + (ct-assert (assoc 'speech (cells-flushed p))) + (ct-assert (c-optimized-away-p (cdr (assoc 'speech (cells-flushed p))))) (ct-assert (not (c-optimized-away-p (md-slot-cell p 'thought)))) ;; pulse is variable, so cannot opti (ct-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought))))) ;; but speech is opti, so only 1 used @@ -205,7 +205,7 @@ (length (names self))))) nil) (t (error) - (trc "error" error) + (describe error) (setf *stop* nil) t))) ) --- /project/cells/cvsroot/cells/cells-test/test.lisp 2007/11/30 16:51:19 1.10 +++ /project/cells/cvsroot/cells/cells-test/test.lisp 2007/11/30 22:29:06 1.11 @@ -71,7 +71,7 @@ (defun test-cells () (loop for test in (reverse *cell-tests*) - when (eq 'm-syn-bool test) + when t ; (eq 'cv-test-person-5 test) do (cell-test-init test) (funcall test)) (print (make-string 40 :initial-element #\*))

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 30 Nov '07

30 Nov '07

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv21379/utils-kt Added Files: split-sequence.lisp Log Message: --- /project/cells/cvsroot/cells/utils-kt/split-sequence.lisp 2007/11/30 21:58:40 NONE +++ /project/cells/cvsroot/cells/utils-kt/split-sequence.lisp 2007/11/30 21:58:40 1.1 ;;;; SPLIT-SEQUENCE ;;; ;;; This code was based on Arthur Lemmens' in ;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>; ;;; ;;; changes include: ;;; ;;; * altering the behaviour of the :from-end keyword argument to ;;; return the subsequences in original order, for consistency with ;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only ;;; affects the answer if :count is less than the number of ;;; subsequences, by analogy with the above-referenced functions). ;;; ;;; * changing the :maximum keyword argument to :count, by analogy ;;; with CL:REMOVE, CL:SUBSTITUTE, and so on. ;;; ;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather ;;; than SPLIT. ;;; ;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT. ;;; ;;; * The second return value is now an index rather than a copy of a ;;; portion of the sequence; this index is the `right' one to feed to ;;; CL:SUBSEQ for continued processing. ;;; There's a certain amount of code duplication here, which is kept ;;; to illustrate the relationship between the SPLIT-SEQUENCE ;;; functions and the CL:POSITION functions. ;;; Examples: ;;; ;;; * (split-sequence #\; "a;;b;c") ;;; -> ("a" "" "b" "c"), 6 ;;; ;;; * (split-sequence #\; "a;;b;c" :from-end t) ;;; -> ("a" "" "b" "c"), 0 ;;; ;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1) ;;; -> ("c"), 4 ;;; ;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t) ;;; -> ("a" "b" "c"), 6 ;;; ;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra") ;;; -> ("" "" "r" "c" "d" "" "r" ""), 11 ;;; ;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra") ;;; -> ("ab" "a" "a" "ab" "a"), 11 ;;; ;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9) ;;; -> ("oo" "bar" "b"), 9 ;; cl-utilities note: the license of this file is unclear, and I don't ;; even know whom to contact to clarify it. If anybody objects to my ;; assumption that it is public domain, please contact me so I can do ;; something about it. Previously I required the split-sequence ; package as a dependency, but that was so unwieldy that it was *the* ;; sore spot sticking out in the design of cl-utilities. -Peter Scott (in-package :utils-kt) (export! split-sequence) (defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied)) "Return a list of subsequences in seq delimited by delimiter. If :remove-empty-subseqs is NIL, empty subsequences will be included in the result; otherwise they will be discarded. All other keywords work analogously to those for CL:SUBSTITUTE. In particular, the behaviour of :from-end is possibly different from other versions of this function; :from-end values of NIL and T are equivalent unless :count is supplied. The second return value is an index suitable as an argument to CL:SUBSEQ into the sequence indicating where processing stopped." (let ((len (length seq)) (other-keys (nconc (when test-supplied (list :test test)) (when test-not-supplied (list :test-not test-not)) (when key-supplied (list :key key))))) (unless end (setq end len)) (if from-end (loop for right = end then left for left = (max (or (apply #'position delimiter seq :end right :from-end t other-keys) -1) (1- start)) unless (and (= right (1+ left)) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values (nreverse subseqs) right) else collect (subseq seq (1+ left) right) into subseqs and sum 1 into nr-elts until (< left start) finally (return (values (nreverse subseqs) (1+ left)))) (loop for left = start then (+ right 1) for right = (min (or (apply #'position delimiter seq :start left other-keys) len) end) unless (and (= right left) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values subseqs left) else collect (subseq seq left right) into subseqs and sum 1 into nr-elts until (>= right end) finally (return (values subseqs right)))))) (defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) "Return a list of subsequences in seq delimited by items satisfying predicate. If :remove-empty-subseqs is NIL, empty subsequences will be included in the result; otherwise they will be discarded. All other keywords work analogously to those for CL:SUBSTITUTE-IF. In particular, the behaviour of :from-end is possibly different from other versions of this function; :from-end values of NIL and T are equivalent unless :count is supplied. The second return value is an index suitable as an argument to CL:SUBSEQ into the sequence indicating where processing stopped." (let ((len (length seq)) (other-keys (when key-supplied (list :key key)))) (unless end (setq end len)) (if from-end (loop for right = end then left for left = (max (or (apply #'position-if predicate seq :end right :from-end t other-keys) -1) (1- start)) unless (and (= right (1+ left)) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values (nreverse subseqs) right) else collect (subseq seq (1+ left) right) into subseqs and sum 1 into nr-elts until (< left start) finally (return (values (nreverse subseqs) (1+ left)))) (loop for left = start then (+ right 1) for right = (min (or (apply #'position-if predicate seq :start left other-keys) len) end) unless (and (= right left) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values subseqs left) else collect (subseq seq left right) into subseqs and sum 1 into nr-elts until (>= right end) finally (return (values subseqs right)))))) (defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) "Return a list of subsequences in seq delimited by items satisfying (CL:COMPLEMENT predicate). If :remove-empty-subseqs is NIL, empty subsequences will be included in the result; otherwise they will be discarded. All other keywords work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular, the behaviour of :from-end is possibly different from other versions of this function; :from-end values of NIL and T are equivalent unless :count is supplied. The second return value is an index suitable as an argument to CL:SUBSEQ into the sequence indicating where processing stopped." ; Emacs syntax highlighting is broken, and this helps: " (let ((len (length seq)) (other-keys (when key-supplied (list :key key)))) (unless end (setq end len)) (if from-end (loop for right = end then left for left = (max (or (apply #'position-if-not predicate seq :end right :from-end t other-keys) -1) (1- start)) unless (and (= right (1+ left)) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values (nreverse subseqs) right) else collect (subseq seq (1+ left) right) into subseqs and sum 1 into nr-elts until (< left start) finally (return (values (nreverse subseqs) (1+ left)))) (loop for left = start then (+ right 1) for right = (min (or (apply #'position-if-not predicate seq :start left other-keys) len) end) unless (and (= right left) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values subseqs left) else collect (subseq seq left right) into subseqs and sum 1 into nr-elts until (>= right end) finally (return (values subseqs right)))))) (pushnew :split-sequence *features*)

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 30 Nov '07

30 Nov '07

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"))

1 0

← Newer
1
...
19
20
21
22
23
24
25
...
73
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

cells-cvs