Skip to content
Browse files

nothing special

  • Loading branch information...
1 parent 0d3538c commit d565d1228fa96c6392f74d0be0264ab07c71a5fe ktilton committed Jun 16, 2008
View
11 cells-manifesto.txt
@@ -13,8 +13,8 @@ For example, in a text editor application we might have (condensed):
(make-instance 'menu-item
:label "Cut"
:enabled (c? (bwhen (f (focus *window*))
- (and (typep focus 'text-widget)
- (selection-range focus)))))
+ (and (typep f 'text-widget)
+ (selection-range f)))))
Translated, the enabled state of the Cut menu item follows
whether or not the user is focused on a text-edit widget and
@@ -102,7 +102,9 @@ way around it, and thus his prediction that a software silver bullet was
in principle impossible.
Which brings us to Cells. See also [axiom] Phillip Eby's developing axiomatic
-definition he is developing in support of Ryan Forseth's SoC project.
+definition he is developing in support of Ryan Forseth's SoC project. Mr. Eby was
+inspired by his involvement to develop Trellis, his own Cells work-alike library
+for Python.
DEFMODEL and Slot types
-----------------------
@@ -351,6 +353,9 @@ PhD Thesis in which he develops a constraint programming language or two:
http://portal.acm.org/citation.cfm?id=889490&dl=ACM&coll=ACM
http://www.cs.utk.edu/~bvz/quickplan.html
+Flow-based programming, developed by J. Paul Morrison at IBM, 1971.
+ http://en.wikipedia.org/wiki/Flow-based_programming
+
Sutherland, I. Sketchpad: A Man Machine Graphical Communication System. PhD thesis, MIT, 1963.
Steele himself cites Sketchpad as inexplicably unappreciated prior
art to his Constraints system:
View
21 cells.lisp
@@ -150,30 +150,31 @@ a cellular slot (or in a list in such) and then mop those up on not-to-be.
(break "~&i say, unhandled <c-enabling>: ~s" condition))))
(define-condition c-fatal (xcell)
- ((name :initarg :name :reader name)
- (model :initarg :model :reader model)
- (cell :initarg :cell :reader cell))
+ ((name :initform :anon :initarg :name :reader name)
+ (model :initform nil :initarg :model :reader model)
+ (cell :initform nil :initarg :cell :reader cell))
(:report (lambda (condition stream)
(format stream "~&fatal cell programming error: ~s" condition)
(format stream "~& : ~s" (name condition))
(format stream "~& : ~s" (model condition))
(format stream "~& : ~s" (cell condition)))))
-(define-condition c-unadopted (c-fatal)
- ()
+
+(define-condition asker-midst-askers (c-fatal)
+ ())
+;; "see listener for cell rule cycle diagnotics"
+
+(define-condition c-unadopted (c-fatal) ()
(:report
(lambda (condition stream)
(format stream "~&unadopted cell >: ~s" (cell condition))
(format stream "~& >: often you mis-edit (c? (c? ...)) nesting is error"))))
-
(defun c-break (&rest args)
(unless *stop*
(let ((*print-level* 5)
(*print-circle* t)
(args2 (mapcar 'princ-to-string args)))
- (c-stop args)
-
- (format t "~&c-break > stopping > ~{~a ~}" args2)
- (print `(c-break-args ,@args2))
+ (c-stop :c-break)
+ ;(format t "~&c-break > stopping > ~{~a ~}" args2)
(apply 'error args2))))
View
2 defmodel.lisp
@@ -185,6 +185,8 @@ the defmodel form for ~a" ',class ',class))))
(list* `(:default-initargs ,@definitargs)
(nreverse class-options)))))))))
+
+
#+test
(progn
(defclass md-test-super ()())
View
58 family.lisp
@@ -26,9 +26,13 @@ See the Lisp Lesser GNU Public License for more details.
((.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)
+ (register? :cell nil :initform nil :initarg :register? :reader register?)
(zdbg :initform nil :accessor dbg :initarg :dbg))
)
+(defmethod initialize-instance :after ((self model) &key)
+ (when (register? self)
+ (fm-register self)))
(defmethod print-cell-object ((md model))
(or (md-name md) :md?))
@@ -92,7 +96,14 @@ See the Lisp Lesser GNU Public License for more details.
(.kids :initform (c-in nil) ;; most useful
:owning t
:accessor kids
- :initarg :kids)))
+ :initarg :kids)
+ (registry? :cell nil
+ :initform nil
+ :initarg :registry?
+ :accessor registry?)
+ (registry :cell nil
+ :initform nil
+ :accessor registry)))
#+test
(let ((c (find-class 'family)))
@@ -143,14 +154,11 @@ See the Lisp Lesser GNU Public License for more details.
`(let ((,kid ,self))
(find-prior ,kid (kids (fm-parent ,kid))))))
-
-(defun md-be-adopted (self &aux (fm-parent (fm-parent self)) (selftype (type-of self)))
-
+(defun md-be-adopted (self &aux (fm-parent (fm-parent self)) (selftype (type-of self)))
(c-assert self)
(c-assert fm-parent)
(c-assert (typep fm-parent 'family))
-
(trc nil "md be adopted >" :kid self (adopt-ct self) :by fm-parent)
(when (plusp (adopt-ct self))
@@ -209,5 +217,45 @@ See the Lisp Lesser GNU Public License for more details.
(declare (ignorable self))
(list ,@slot-defs)))
+; --- registry "namespacing" ---
+
+(defmethod registry? (other) (declare (ignore other)) nil)
+
+(defmethod initialize-instance :after ((self family) &key)
+ (when (registry? self)
+ (setf (registry self) (make-hash-table :test 'eq))))
+
+(defmethod fm-register (self &optional (guest self))
+ (assert self)
+ (if (registry? self)
+ (progn
+ (trc "fm-registering" (md-name guest) :with self)
+ (setf (gethash (md-name guest) (registry self)) guest))
+ (fm-register (fm-parent self) guest)))
+
+(defmethod fm-check-out (self &optional (guest self))
+ (assert self () "oops ~a ~a ~a" self (fm-parent self) (slot-value self '.fm-parent))
+ (if (registry? self)
+ (remhash (md-name guest) (registry self))
+ (bif (p (fm-parent self))
+ (fm-check-out p guest)
+ (break "oops ~a ~a ~a" self (fm-parent self) (slot-value self '.fm-parent)))))
+
+(defmethod fm-find-registered (id self &optional (must-find? self must-find?-supplied?))
+ (or (if (registry? self)
+ (gethash id (registry self))
+ (bwhen (p (fm-parent self))
+ (fm-find-registered id p must-find?)))
+ (when (and must-find? (not must-find?-supplied?))
+ (break "fm-find-registered failed seeking ~a starting search at node ~a" id self))))
+
+(export! rg? rg!)
+
+(defmacro rg? (id)
+ `(fm-find-registered ,id self nil))
+
+(defmacro rg! (id)
+ `(fm-find-registered ,id self))
+
View
3 fm-utilities.lisp
@@ -14,7 +14,7 @@ the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Lisp Lesser GNU Public License for more details.
-$Header: /home/ramarren/LISP/cells-hack/rsynced-cvs/cells/fm-utilities.lisp,v 1.20 2008/05/24 19:24:05 fgoenninger Exp $
+$Header: /home/ramarren/LISP/cells-hack/rsynced-cvs/cells/fm-utilities.lisp,v 1.21 2008/06/16 12:38:04 ktilton Exp $
|#
(in-package :cells)
@@ -702,7 +702,6 @@ $Header: /home/ramarren/LISP/cells-hack/rsynced-cvs/cells/fm-utilities.lisp,v 1.
:global-search global-search))))
(when (and must-find (null match))
(trc "fm-find-one > erroring fm-not-found, in family: " family :seeking md-name :global? global-search)
- ;;(inspect family)
(setq diag t must-find nil)
(fm-traverse family #'matcher
:skip-tree skip-tree
View
23 gui-geometry/geo-family.lisp
@@ -102,6 +102,7 @@ See the Lisp Lesser GNU Public License for more details.
(^prior-sib-pr self (spacing .parent)))))))))))
+
(defun ^prior-sib-pb (self &optional (spacing 0)) ;; just keeping with -pt variant till both converted to defun
(bif (psib (find-prior self (kids .parent)
:test (lambda (sib)
@@ -118,23 +119,35 @@ See the Lisp Lesser GNU Public License for more details.
(c? (py-maintain-pt (round (- (l-height .parent) (l-height self)) -2))))
;--------------- geo.row.flow ----------------------------
-(export! geo-row-flow)
+(export! geo-row-flow fixed-col-width ^fixed-col-width ^spacing-hz spacing-hz
+ max-per-row ^max-per-row)
(defmd geo-row-flow (geo-inline)
(spacing-hz 0)
(spacing-vt 0)
(aligned :cell nil)
+ fixed-col-width
+ max-per-row
(row-flow-layout
(c? (loop with max-pb = 0 and pl = 0 and pt = 0
for k in (^kids)
- for kpr = (+ pl (l-width k))
+ for kn upfrom 0
+ for kw = (or (^fixed-col-width) (l-width k))
+ for kpr = (+ pl kw)
when (unless (= pl 0)
- (> kpr (- (l-width self) (outset self)))) do
+ (if (^max-per-row)
+ (zerop (mod kn (^max-per-row)))
+ (> kpr (- (l-width self) (outset self)))))
+ do
+ (when (> kpr (- (l-width self) (outset self)))
+ (trc nil "LR overflow break" kpr :gt (- (l-width self) (outset self))))
+ (when (zerop (mod kn (^max-per-row)))
+ (trc nil "max/row break" kn (^max-per-row) (mod kn (^max-per-row))))
(setf pl 0
pt (+ max-pb (downs (^spacing-vt))))
-
+
collect (cons pl pt) into pxys
- do (incf pl (+ (l-width k)(^spacing-hz)))
+ do (incf pl (+ kw (^spacing-hz)))
(setf max-pb (min max-pb (+ pt (downs (l-height k)))))
finally (return (cons max-pb pxys)))))
:lb (c? (+ (bif (xys (^row-flow-layout))
View
9 integrity.lisp
@@ -66,6 +66,7 @@ See the Lisp Lesser GNU Public License for more details.
*unfinished-business*
*defer-changes*)
(trc nil "initiating new UFB!!!!!!!!!!!!" opcode defer-info)
+ (when *c-debug* (assert (boundp '*istack*)))
(when (or (zerop *data-pulse-id*)
(eq opcode :change))
(eko (nil "!!! New pulse, event" *data-pulse-id* defer-info)
@@ -77,15 +78,17 @@ See the Lisp Lesser GNU Public License for more details.
(let ((*istack* (list (list opcode defer-info)
(list :trigger code)
(list :start-dp *data-pulse-id*))))
+ (trc "*istack* bound")
(handler-case
(go-go)
- (t (c)
+ (xcell (c)
(if (functionp *c-debug*)
(funcall *c-debug* c (nreverse *istack*))
(loop for f in (nreverse *istack*)
do (format t "~&istk> ~(~a~) " f)
finally (describe c)
- (break "integ backtrace: see listener for deets"))))))
+ (break "integ backtrace: see listener for deets")))))
+ (trc "*istack* unbinding"))
(go-go)))))
(defun ufb-queue (opcode)
@@ -163,7 +166,7 @@ See the Lisp Lesser GNU Public License for more details.
; dependent reverses the arrow and puts the burden on the prosecution to prove nested tells are a problem.
(bwhen (uqp (fifo-peek (ufb-queue :tell-dependents)))
- #+x42 (trc "retelling dependenst, one new one being" uqp)
+ #+xxx (trc "retelling dependenst, one new one being" uqp)
(go tell-dependents))
;--- process client queue ------------------------------
View
3 link.lisp
@@ -58,8 +58,7 @@ See the Lisp Lesser GNU Public License for more details.
(defun c-unlink-unused (c &aux (usage (cd-usage c))
(usage-size (array-dimension (cd-usage c) 0))
- (dbg nil)) ;; #+not (and (typep (c-model c) 'mathx::mx-solver-stack)
- ;;(eq (c-slot-name c) '.kids))))
+ (dbg nil))
(declare (ignorable dbg usage-size))
(when (cd-useds c)
(let (rev-pos)
View
52 md-slot-value.lisp
@@ -23,9 +23,11 @@ See the Lisp Lesser GNU Public License for more details.
(defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name)))
(when (and (not *not-to-be*)
(mdead self))
- (trc "md-slot-value passed dead self, returning NIL" self slot-name c)
- #-sbcl (inspect self)
- (break "see inspector for dead ~a" self)
+ (unless *stop*
+ (setf *stop* t)
+ (trc "md-slot-value passed dead self, returning NIL" self slot-name c)
+ #-sbcl (inspect self)
+ (break "see inspector for dead ~a" self))
(return-from md-slot-value nil))
(tagbody
retry
@@ -47,7 +49,7 @@ See the Lisp Lesser GNU Public License for more details.
;; (count-it :md-slot-value slot-name)
(if c
(cell-read c)
- (values (bd-slot-value self slot-name) nil)))
+ (values (slot-value self slot-name) nil)))
(defun cell-read (c)
(assert (typep c 'cell))
@@ -61,12 +63,6 @@ See the Lisp Lesser GNU Public License for more details.
(when (mdead s)
(break "model ~a is dead at ~a" s key)))
-;;;(defmethod trcp ((c cell))
-;;; (and *dbg*
-;;; (case (c-slot-name c)
-;;; (mathx::show-time t)
-;;; (ctk::app-time t))))
-
(defvar *trc-ensure* nil)
(defmethod ensure-value-is-current (c debug-id ensurer)
@@ -145,6 +141,7 @@ See the Lisp Lesser GNU Public License for more details.
nil)
v)))
+
(defun calculate-and-set (c)
(flet ((body ()
(when (c-stopped)
@@ -154,19 +151,18 @@ See the Lisp Lesser GNU Public License for more details.
#-its-alive!
(bwhen (x (find c *call-stack*)) ;; circularity
(unless nil ;; *stop*
- (let ((stack (copy-list *call-stack*)))
- (trc "calculating cell ~a appears in call stack: ~a" c x stack )))
- (setf *stop* t)
- (c-break "yep" c)
- (loop with caller-reiterated
- for caller in *call-stack*
- until caller-reiterated
- do (trc "caller:" caller)
- ;; not necessary (pprint (cr-code c))
- (setf caller-reiterated (eq caller c)))
+ (let ()
+ (inspect c)
+ (trc "calculating cell:" c (cr-code c))
+ (trc "appears-in-call-stack (newest first): " (length *call-stack*))
+ (loop for caller in (copy-list *call-stack*)
+ for n below (length *call-stack*)
+ do (trc "caller> " caller #+shhh (cr-code caller))
+ when (eq caller c) do (loop-finish))))
+ (setf *stop* t)
(c-break ;; break is problem when testing cells on some CLs
"cell ~a midst askers (see above)" c)
- (error "see listener for cell rule cycle diagnotics"))
+ (error 'asker-midst-askers :cell c))
(multiple-value-bind (raw-value propagation-code)
(calculate-and-link c)
@@ -197,6 +193,20 @@ See the Lisp Lesser GNU Public License for more details.
(funcall (cr-rule c) c)
(c-unlink-unused c))))
+#+theabove!
+(defun calculate-and-set (c)
+ (multiple-value-bind (raw-value propagation-code)
+ (let ((*call-stack* (cons c *call-stack*))
+ (*depender* c)
+ (*defer-changes* t))
+ (cd-usage-clear-all c)
+ (multiple-value-prog1
+ (funcall (cr-rule c) c)
+ (c-unlink-unused c)))
+ (unless (c-optimized-away-p c)
+ (md-slot-value-assume c raw-value propagation-code))))
+
+
;-------------------------------------------------------------
(defun md-slot-makunbound (self slot-name
View
86 md-utilities.lisp
@@ -54,16 +54,15 @@ See the Lisp Lesser GNU Public License for more details.
(:method ((self model-object))
(md-quiesce self))
-
+
(:method :before ((self model-object))
(loop for slot-name in (md-owning-slots self)
do (not-to-be (slot-value self slot-name))))
(:method :around ((self model-object))
(declare (ignorable self))
(let ((*not-to-be* t)
- (dbg nil #+not (or (eq (md-name self) :eclm-owner)
- (typep self '(or mathx::eclm-2008 clo:ix-form mathx::a1-panel mathx::edit-caret ctk:window)))))
+ (dbg nil))
(flet ((gok ()
(unless (eq (md-state self) :eternal-rest)
@@ -85,13 +84,15 @@ See the Lisp Lesser GNU Public License for more details.
(mapcar 'type-of (slot-value self '.kids))))
(gok)
(when dbg (trc "finished nailing" self))))))))
-
+
(defun md-quiesce (self)
(trc nil "md-quiesce nailing cells" self (type-of self))
(md-map-cells self nil (lambda (c)
(trc nil "quiescing" c)
(c-assert (not (find c *call-stack*)))
- (c-quiesce c))))
+ (c-quiesce c)))
+ (when (register? self)
+ (fm-check-out self)))
(defun c-quiesce (c)
(typecase c
@@ -112,3 +113,78 @@ See the Lisp Lesser GNU Public License for more details.
,@initargs
:fm-parent (progn (assert self) self)))
+(export! self-owned self-owned?)
+
+(defun (setf self-owned) (new-value self thing)
+ (if (consp thing)
+ (loop for e in thing do
+ (setf (self-owned self e) new-value))
+ (if new-value
+ (progn
+ (assert (not (find thing (z-owned self))))
+ (push thing (z-owned self)))
+ (progn
+ (assert (find thing (z-owned self)))
+ (setf (z-owned self)(delete thing (z-owned self)))))))
+
+(defun self-owned? (self thing)
+ (find thing (z-owned self)))
+
+(defvar *c-d-d*)
+(defvar *max-d-d*)
+
+
+(defun count-model (self)
+ (setf *c-d-d* (make-hash-table :test 'eq) *max-d-d* 0)
+ (with-metrics (t nil "cells statistics for" self)
+ (labels ((cc (self)
+ (count-it :thing)
+ (count-it :thing (type-of self))
+ ;(count-it :thing-type (type-of self))
+ (loop for (id . c) in (cells self)
+ do (count-it :live-cell)
+ ;(count-it :live-cell id)
+
+ (typecase c
+ (c-dependent
+ (count-it :dependent-cell)
+ (loop repeat (length (c-useds c))
+ do (count-it :cell-useds)
+ (count-it :dep-depth (c-depend-depth c))))
+ (otherwise (if (c-inputp c)
+ (count-it :c-input id)
+ (count-it :c-unknow))))
+
+ (loop repeat (length (c-callers c))
+ do (count-it :cell-callers)))
+
+ (loop repeat (length (cells-flushed self))
+ do (count-it :flushed-cell #+toomuchinfo id))
+
+ (loop for slot in (md-owning-slots self) do
+ (loop for k in (let ((sv (SLOT-VALUE self slot)))
+ (if (listp sv) sv (list sv)))
+ do (cc k)))))
+ (cc self))))
+
+(defun c-depend-depth (ctop)
+ (if (null (c-useds ctop))
+ 0
+ (or (gethash ctop *c-d-d*)
+ (labels ((cdd (c &optional (depth 1) chain)
+ (when (and (not (c-useds c))
+ (> depth *max-d-d*))
+ (setf *max-d-d* depth)
+ (trc "new dd champ from user" depth :down-to c)
+ (when (= depth 41)
+ (trc "end at" (c-slot-name c) :of (type-of (c-model c)))
+ (loop for c in chain do
+ (trc "called by" (c-slot-name c) :of (type-of (c-model c))))))
+ (setf (gethash c *c-d-d*)
+ ;(break "c-depend-depth ~a" c)
+ (progn
+ ;(trc "dd" c)
+ (1+ (loop for u in (c-useds c)
+ maximizing (cdd u (1+ depth) (cons c chain))))))))
+ (cdd ctop)))))
+
View
21 model-object.lisp
@@ -21,15 +21,17 @@ See the Lisp Lesser GNU Public License for more details.
;;; --- model-object ----------------------
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(md-name fm-parent .parent)))
+ (export '(md-name fm-parent .parent z-owned)))
(defclass model-object ()
((.md-state :initform :nascent :accessor md-state) ; [nil | :nascent | :alive | :doomed]
- (.awaken-on-init-p :initform nil :initarg :awaken-on-init-p :accessor awaken-on-init-p) ; [nil | :nascent | :alive | :doomed]
+ (.awaken-on-init-p :initform nil :initarg :awaken-on-init-p :accessor awaken-on-init-p)
(.cells :initform nil :accessor cells)
(.cells-flushed :initform nil :accessor cells-flushed
:documentation "cells supplied but un-whenned or optimized-away")
- (adopt-ct :initform 0 :accessor adopt-ct)))
+ (adopt-ct :initform 0 :accessor adopt-ct)
+ (z-owned :initform nil :accessor z-owned ;; experimental, not yet operative
+ :documentation "Things such as kids to be taken down when self is taken down")))
(defmethod md-state ((self symbol))
:alive)
@@ -202,7 +204,8 @@ See the Lisp Lesser GNU Public License for more details.
(dolist (super (class-precedence-list (find-class class-name))
(setf (md-slot-cell-type class-name slot-name) nil))
(bwhen (entry (assoc slot-name (get (c-class-name super) :cell-types)))
- (return-from md-slot-cell-type (setf (md-slot-cell-type class-name slot-name) (cdr entry))))))))
+ (return-from md-slot-cell-type
+ (setf (md-slot-cell-type class-name slot-name) (cdr entry))))))))
(defun (setf md-slot-cell-type) (new-type class-name slot-name)
(assert class-name)
@@ -216,12 +219,6 @@ See the Lisp Lesser GNU Public License for more details.
do (setf (md-slot-cell-type (class-name c) slot-name) new-type)))
(cdar (push (cons slot-name new-type) (get class-name :cell-types)))))))
-#+hunh
-(md-slot-owning? 'mathx::prb-solver '.kids)
-
-#+hunh
-(cdr (assoc '.value (get 'm-index :indirect-ownings)))
-
#+test
(md-slot-owning? 'm-index '.value)
@@ -289,6 +286,10 @@ See the Lisp Lesser GNU Public License for more details.
(defun (setf md-slot-cell) (new-cell self slot-name)
(if self ;; not on def-c-variables
(bif (entry (assoc slot-name (cells self)))
+ ; this next branch guessed it would only occur during kid-slotting,
+ ; before any dependency-ing could have happened, but a math-editor
+ ; is silently switching between implied-multiplication and mixed numbers
+ ; while they type and it
(let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter
(declare (ignorable old))
(c-assert (null (c-callers old)))
View
4 propagate.lisp
@@ -58,12 +58,8 @@ See the Lisp Lesser GNU Public License for more details.
(setf (c-pulse c) *data-pulse-id*))
;--------------- propagate ----------------------------
-
-
; n.b. the cell argument may have been optimized away,
; though it is still receiving final processing here.
-;
-
(defparameter *per-cell-handler* nil)
View
2 test-propagation.lisp
@@ -22,7 +22,7 @@
(defun tcprop ()
(untrace)
- (test-prep)
+ (ukt:test-prep)
(LET ((box (make-instance 'tcp)))
(trc "changing top to 10" *data-pulse-id*)
(setf (top box) 10)
View
37 trc-eko.lisp
@@ -19,13 +19,12 @@ See the Lisp Lesser GNU Public License for more details.
(in-package :cells)
;----------- trc -------------------------------------------
-
+(defparameter *last-trc* (get-internal-real-time))
(defparameter *trcdepth* 0)
(defun trcdepth-reset ()
(setf *trcdepth* 0))
-
(defmacro trc (tgt-form &rest os)
(if (eql tgt-form 'nil)
'(progn)
@@ -45,8 +44,23 @@ See the Lisp Lesser GNU Public License for more details.
(count-it :trcfailed)))
(count-it :tgtnileval)))))))
-(export! brk brkx .bgo)
+(defun call-trc (stream s &rest os)
+ ;(break)
+ (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*)
+ *trcdepth*)
+ (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*)
+ (format stream "~&"))
+ ;;(format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10))
+ (setf *last-trc* (get-internal-real-time))
+ (format stream "~a" s)
+ (let (pkwp)
+ (dolist (o os)
+ (format stream (if pkwp " ~(~s~)" " ~(~s~)") o) ;; save, used to insert divider, trcx dont like
+ (setf pkwp (keywordp o))))
+ (force-output stream)
+ (values))
+(export! brk brkx .bgo)
(define-symbol-macro .bgo (break "go"))
@@ -68,23 +82,8 @@ See the Lisp Lesser GNU Public License for more details.
nconcing (list (intern (format nil "~a" obj) :keyword) obj))))))
-(defparameter *last-trc* (get-internal-real-time))
-(defun call-trc (stream s &rest os)
- ;(break)
- (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*)
- *trcdepth*)
- (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*)
- (format stream "~&"))
- ;;(format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10))
- (setf *last-trc* (get-internal-real-time))
- (format stream "~a" s)
- (let (pkwp)
- (dolist (o os)
- (format stream (if pkwp " ~(~s~)" " ~(~s~)") o) ;; save, used to insert divider, trcx dont like
- (setf pkwp (keywordp o))))
- (force-output stream)
- (values))
+
(defun call-trc-to-string (fmt$ &rest fmt-args)
(let ((o$ (make-array '(0) :element-type 'base-char
View
51 utils-kt/core.lisp
@@ -46,41 +46,26 @@ resulting in implementation-specific behavior."
value)))
,@(when docstring (list docstring)))))
-
-(export! exe-path exe-dll font-path)
-
-#-iamnotkenny
-(defun exe-path ()
- #+its-alive!
- (excl:current-directory)
- #-its-alive!
+(defun test-setup (&optional drib)
+ #+(and allegro ide)
+ (ide.base::find-new-prompt-command
+ (cg.base::find-window :listener-frame))
+ (when drib
+ (dribble (merge-pathnames
+ (make-pathname :name drib :type "TXT")
+ (project-path)))))
+
+(export! test-setup test-prep test-init)
+(export! project-path)
+(defun project-path ()
+ #+(and allegro ide)
(excl:path-pathname (ide.base::project-file ide.base:*current-project*)))
-#-iamnotkenny
-(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))
+(test-setup)
-(defmacro exe-dll (&optional filename)
- (assert filename)
- (concatenate 'string filename ".dll"))
+(defun test-prep (&optional drib)
+ (test-setup drib))
-#+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"))
+(defun test-init (&optional drib)
+ (test-setup drib))
View
7 utils-kt/debug.lisp
@@ -55,13 +55,13 @@ See the Lisp Lesser GNU Public License for more details.
(defmacro count-it (&rest keys)
(declare (ignorable keys))
- #+(or) `(progn)
- `(when (car *counting*)
+ `(progn)
+ #+(or) `(when (car *counting*)
(call-count-it ,@keys)))
(defun call-count-it (&rest keys)
(declare (ignorable keys))
- (when (find (car keys) '(:trcfailed :TGTNILEVAL))
+ #+nahh (when (find (car keys) '(:trcfailed :TGTNILEVAL))
(break "clean up time ~a" keys))
(let ((entry (assoc keys *count* :test #'equal)))
(if entry
@@ -85,6 +85,7 @@ See the Lisp Lesser GNU Public License for more details.
(when clearp (count-clear "show-count")))
+
;-------------------- timex ---------------------------------
(export! timex)
View
24 utils-kt/detritus.lisp
@@ -59,30 +59,6 @@ See the Lisp Lesser GNU Public License for more details.
(defun collect-if (test list)
(remove-if-not test list))
-(defun test-setup (&optional drib)
- #-(or iamnotkenny its-alive!)
- (ide.base::find-new-prompt-command
- (cg.base::find-window :listener-frame))
- (when drib
- (dribble (merge-pathnames
- (make-pathname :name drib :type "TXT")
- (project-path)))))
-
-(export! project-path)
-(defun project-path ()
- #+allegro (excl:path-pathname (ide.base::project-file ide.base:*current-project*)))
-
-#+test
-(test-setup)
-
-(defun test-prep (&optional drib)
- (test-setup drib))
-
-(defun test-init (&optional drib)
- (test-setup drib))
-
-(export! test-setup test-prep test-init)
-
;;; --- FIFO Queue -----------------------------
(defun make-fifo-queue (&rest init-data)
View
14 utils-kt/flow-control.lisp
@@ -150,11 +150,15 @@ See the Lisp Lesser GNU Public License for more details.
(defun -1?1 (x) (* -1?1 x))
(defun prime? (n)
- (and (> n 1)
- (or (= 2 n)(oddp n))
- (loop for d upfrom 3 by 2 to (sqrt n)
- when (zerop (mod n d)) return nil
- finally (return t))))
+ (when (> n 1)
+ (cond
+ ((= 2 n) t)
+ ((evenp n) (values nil 2))
+ (t (loop for d upfrom 3 by 2 to (sqrt n)
+ when (zerop (mod n d)) do (return-from prime? (values nil d))
+ finally (return t))))))
+
+
; --- cloucell support for struct access of slots ------------------------

0 comments on commit d565d12

Please sign in to comment.
Something went wrong with that request. Please try again.