/
md-utilities.lisp
88 lines (63 loc) · 2.54 KB
/
md-utilities.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
#|
Cells -- Automatic Dataflow Managememnt
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 :cells)
(defun md-awake (self) (eql :awake (md-state self)))
(defun fm-grandparent (md)
(fm-parent (fm-parent md)))
(defmethod md-release (other)
(declare (ignorable other)))
(export! mdead)
;___________________ birth / death__________________________________
(defgeneric mdead (self)
(:method ((self model-object))
(eq :eternal-rest (md-state self)))
(:method (self)
(declare (ignore self))
nil))
(defgeneric not-to-be (self)
(:method ((self model-object))
(md-quiesce self))
(:method :around ((self model-object))
(declare (ignorable self))
(trc nil #+not (typep self '(or mathx::problem mathx::prb-solvers mathx::prb-solver))
"not.to-be nailing" self)
;;showpanic (c-assert (not (eq (md-state self) :eternal-rest)))
(unless (eq (md-state self) :eternal-rest)
(call-next-method)
(setf (fm-parent self) nil
(md-state self) :eternal-rest)
(md-map-cells self nil
(lambda (c)
(c-assert (eq :quiesced (c-state c))))) ;; fails if user obstructs not.to-be with primary method (use :before etc)
(trc nil "not.to-be cleared 2 fm-parent, eternal-rest" 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))))
(defun c-quiesce (c)
(typecase c
(cell
(trc nil "c-quiesce unlinking" c)
(c-unlink-from-used c)
(dolist (caller (c-callers c))
(setf (c-value-state caller) :uncurrent)
(trc nil "c-quiesce unlinking caller and making uncurrent" :q c :caller caller)
(c-unlink-caller c caller))
(setf (c-state c) :quiesced) ;; 20061024 for debugging for now, might break some code tho
)))
(defparameter *to-be-dbg* nil)
(defmacro make-kid (class &rest initargs)
`(make-instance ,class
,@initargs
:fm-parent (progn (assert self) self)))