Commit 926734c6 authored by Kenny Tilton's avatar Kenny Tilton
Browse files

*** empty log message ***

parent 79b12f5c
......@@ -16,14 +16,26 @@ See the Lisp Lesser GNU Public License for more details.
|#
(eval-when (compile load)
(proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3))))
#| Notes
I don't like the way with-cc defers twice, first the whole thing and then when the
body finally runs we are still within the original integrity and each setf gets queued
to UFB separately before md-slot-value-assume finally runs. I think all that is going on here
is that we want the programmer to use with-cc to show they know the setf will not be returning
a useful value. But since they have coded the with-cc we should be able to figure out a way to
let those SETFs thru as if they were outside integrity, and then we get a little less UFBing
but even better SETF behaves as it should.
It would be nice to do referential integrity and notice any time a model object gets stored in
a cellular slot (or in a list in such) and then mop those up on not-to-be.
|#
(in-package :cells)
(eval-when (compile load)
(proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3))))
(in-package :cells)
(defparameter *c-prop-depth* 0)
(defparameter *causation* nil)
......@@ -94,11 +106,8 @@ See the Lisp Lesser GNU Public License for more details.
`t))))
(defmacro without-c-dependency (&body body)
`(call-without-c-dependency (lambda () ,@body)))
(defun call-without-c-dependency (fn)
(let (*depender*)
(funcall fn)))
` (let (*depender*)
,@body))
(export! .cause)
......@@ -117,7 +126,8 @@ See the Lisp Lesser GNU Public License for more details.
(slot-name self new old old-boundp cell)
(declare (ignorable slot-name self new old old-boundp cell)))
#+hunh
(fmakunbound 'slot-value-observe)
; -------- cell conditions (not much used) ---------------------------------------------
(define-condition xcell () ;; new 2k0227
......
......@@ -91,9 +91,7 @@ See the Lisp Lesser GNU Public License for more details.
(.kids :initform (c-in nil) ;; most useful
:owning t
:accessor kids
:initarg :kids)
)
(:default-initargs :fm-parent (when (boundp '*parent*) *parent*)))
:initarg :kids)))
(defmacro the-kids (&rest kids)
`(let ((*parent* self))
......
......@@ -115,6 +115,17 @@ See the Lisp Lesser GNU Public License for more details.
:with-dependency dependently)
(nreverse collection)))
(export! fm-collect-some)
(defun fm-collect-some (tree test &optional skip-top dependently)
(let (collection)
(fm-traverse tree (lambda (node)
(unless (and skip-top (eq node tree))
(bwhen (s (funcall test node))
(push s collection))))
:with-dependency dependently)
(nreverse collection)))
(defun fm-value-dictionary (tree value-fn &optional include-top)
(let (collection)
(fm-traverse tree
......
......@@ -120,64 +120,35 @@ See the Lisp Lesser GNU Public License for more details.
;--------------- geo.row.flow ----------------------------
(export! geo-row-flow)
(defmodel geo-row-flow (geo-inline)
((spacing-hz :cell nil :initarg :spacing-hz :initform 0 :reader spacing-hz)
(spacing-vt :cell nil :initarg :spacing-vt :initform 0 :reader spacing-vt)
(aligned :cell nil :initarg :aligned :initform nil :reader aligned))
(:default-initargs
:lb (c? (geo-kid-wrap self 'pb))
:kid-slots (lambda (self)
(declare (ignore self))
(list
(mk-kid-slot (py)
(c? (py-maintain-pt
(let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent))))
(if (> (+ ph (l-width self)(outset .parent)) (l-width .parent))
(^prior-sib-pb self (spacing-vt .parent))
(^prior-sib-pt self))))))
(mk-kid-slot (px)
(c? (px-maintain-pl
(let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent))))
(if (> (+ ph (l-width self)(outset .parent)) (l-width .parent))
0
ph)))))))))
#| archive
(defmodel geo-row-fv (family-values geo-row)())
(defmodel geo-inline-fv (family-values geo-inline)())
;-------------------------- IMMatrix ------------------------------------------
(defmodel im-matrix (geo-zero-tl)
((columns :cell nil :initarg :columns :initform nil :accessor columns)
(indent-hz :cell nil :initarg :indent-hz :initform 0 :accessor indent-hz)
(spacing-hz :cell nil :initarg :spacing-hz :initform 0 :accessor spacing-hz)
(spacing-vt :cell nil :initarg :spacing-vt :initform 0 :accessor spacing-vt))
(:default-initargs
:kid-slots (lambda (self)
(declare (ignore self))
(list
(mk-kid-slot (px)
(c? (let ((parent (fm-parent self)))
(+ (indent-hz parent)
(if (zerop (mod (fm-pos self)
(or (columns parent)
(length (kids parent)))))
0
(+ (spacing-hz parent)
(pr (find-prior self (kids parent)))))))))
(mk-kid-slot (py)
(c? (let* ((parent (fm-parent self))
(psib (find-prior self (kids parent))))
(if (and psib (columns parent))
(if (zerop (mod (fm-pos self) (columns parent)))
(+ (- (abs (spacing-vt parent))) (pb psib))
(pt psib))
0))))))))
(defmd geo-row-flow (geo-inline)
(spacing-hz 0)
(spacing-vt 0)
(aligned :cell nil)
(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))
when (unless (= pl 0)
(> kpr (- (l-width self) (outset self)))) do
(setf pl 0
pt (+ max-pb (downs (^spacing-vt))))
collect (cons pl pt) into pxys
do (incf pl (+ (l-width k)(^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))
(car xys) 0)
(downs (outset self))))
:kid-slots (lambda (self)
(declare (ignore self))
(list
(mk-kid-slot (px)
(c? (px-maintain-pl (car (nth (kid-no self) (cdr (row-flow-layout .parent)))))))
(mk-kid-slot (py)
(c? (py-maintain-pt (cdr (nth (kid-no self) (cdr (row-flow-layout .parent))))))))))
|#
......
......@@ -77,7 +77,7 @@ See the Lisp Lesser GNU Public License for more details.
(defmacro py-maintain-pB (pB)
`(- ,pB (^lB)))
(export! centered-h? centered-v?)
(export! centered-h? centered-v? lb-maintain-pB)
(defmacro ^fill-down (upper-type &optional (padding 0))
(let ((filled (gensym)))
......
......@@ -110,13 +110,26 @@ See the Lisp Lesser GNU Public License for more details.
;sum pXYs up the family tree ;gave an odd result for cursor display....
(defun v2-xlate (outer inner outer-v2)
(if (eql outer inner)
(if (eq outer inner)
outer-v2
(v2-xlate outer (fm-parent inner)
(v2-subtract outer-v2
(mkv2 (px inner) (py inner))))))
(export! h-xlate v-xlate)
(defun v2-xlate-out (inner outer inner-v2)
(if (eq outer inner)
inner-v2
(v2-xlate (fm-parent inner) outer
(v2-add inner-v2
(mkv2 (px inner) (py inner))))))
(defun v2-xlate-between (from-v2 from to)
(cond
((fm-includes from to)(v2-xlate from to from-v2))
((fm-includes to from)(v2-xlate-out from to from-v2))
(t (break "time to extend v2-xlate-between"))))
(export! h-xlate v-xlate v2-xlate-between)
(defun h-xlate (outer inner outer-h)
(if (eql outer inner)
......
......@@ -48,7 +48,15 @@ See the Lisp Lesser GNU Public License for more details.
(return-from call-with-integrity))
(if *within-integrity*
(if opcode
(ufb-add opcode (cons defer-info action))
(progn
(ufb-add opcode (cons defer-info action))
;
; SETF is supposed to return the value being installed
; in the place, but if the SETF is deferred we return
; something that will help someone who tries to use
; the setf'ed value figure out what is going on:
;
:deferred-to-ufb-1)
(funcall action opcode defer-info))
(let ((*within-integrity* t)
*unfinished-business*
......@@ -63,18 +71,15 @@ See the Lisp Lesser GNU Public License for more details.
(finish-business)))))
(defun ufb-queue (opcode)
(assert (find opcode *ufb-opcodes*))
(cdr (assoc opcode *unfinished-business*)))
(defun ufb-queue-ensure (opcode)
(assert (find opcode *ufb-opcodes*))
(or (ufb-queue opcode)
(cdr (car (push (cons opcode (make-fifo-queue)) *unfinished-business*)))))
(defparameter *no-tell* nil)
(defun ufb-add (opcode continuation)
(assert (find opcode *ufb-opcodes*))
#+trythis (when (and *no-tell* (eq opcode :tell-dependents))
(break "truly queueing tell under no-tell"))
(trc nil "ufb-add deferring" opcode (when (eql opcode :client)(car continuation)))
......@@ -137,7 +142,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)))
(trc "retelling dependenst, one new one being" uqp)
#+x42 (trc "retelling dependenst, one new one being" uqp)
(go tell-dependents))
;--- process client queue ------------------------------
......@@ -175,7 +180,7 @@ See the Lisp Lesser GNU Public License for more details.
(bwhen (task-info (fifo-pop (ufb-queue :change)))
(trc nil "!!! finbiz --- CHANGE ---- (first of)" (fifo-length (ufb-queue :change)))
(destructuring-bind (defer-info . task-fn) task-info
(trc nil "finbiz: deferred state change" defer-info)
#+xxx (trc "fbz: dfrd chg" defer-info (fifo-length (ufb-queue :change)))
(data-pulse-next (list :finbiz defer-info))
(funcall task-fn :change defer-info)
;
......
......@@ -131,7 +131,7 @@ See the Lisp Lesser GNU Public License for more details.
(bwhen (v (c-value c))
(if (mdead v)
(progn
(format t "~&on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v)
#+shhh (format t "~&on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v)
nil)
v)))
......@@ -227,7 +227,8 @@ See the Lisp Lesser GNU Public License for more details.
(defun (setf md-slot-value) (new-value self slot-name
&aux (c (md-slot-cell self slot-name)))
#+shhh (when *within-integrity*
(trc "mdsetf>" self (type-of self) slot-name :new new-value))
(when *c-debug*
(c-setting-debug self slot-name c new-value))
......
......@@ -193,12 +193,13 @@ See the Lisp Lesser GNU Public License for more details.
month year day-of-week
daylight-saving-time-p time-zone))
(format nil "~4,,,'0@A:~2,,,'0@A:~2,,,'0@A:~2,,,'0@A:~2,,,'0@A:~2,,,'0@A:~2,,,'0@A"
year month date hours minutes seconds (floor (now) 10))))
year month date hours minutes seconds (floor (* 10 (mod (now) 1.0))))))
(defun hyphenated-time-string ()
(substitute #\- #\: (ymdhmsh)))
#+test
(hyphenated-time-string)
#+test
(ymdhmsh)
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment