/[cells-gtk]/cells/constructors.lisp
ViewVC logotype

Contents of /cells/constructors.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Wed Jun 7 16:23:31 2006 UTC (7 years, 10 months ago) by pdenno
Branch: MAIN
CVS Tags: HEAD
new files
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
2 ;;;
3 ;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
4 ;;;
5 ;;; Permission is hereby granted, free of charge, to any person obtaining a copy
6 ;;; of this software and associated documentation files (the "Software"), to deal
7 ;;; in the Software without restriction, including without limitation the rights
8 ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9 ;;; copies of the Software, and to permit persons to whom the Software is furnished
10 ;;; to do so, subject to the following conditions:
11 ;;;
12 ;;; The above copyright notice and this permission notice shall be included in
13 ;;; all copies or substantial portions of the Software.
14 ;;;
15 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
20 ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
21 ;;; IN THE SOFTWARE.
22
23 (in-package :cells)
24
25 ;___________________ constructors _______________________________
26
27 (defmacro c-lambda (&body body)
28 `(c-lambda-var (slot-c) ,@body))
29
30 (defmacro c-lambda-var ((c) &body body)
31 `(lambda (,c &aux (self (c-model ,c))
32 (.cache (c-value ,c)))
33 (declare (ignorable .cache self))
34 ,@body))
35
36 ;-----------------------------------------
37
38 (defmacro c? (&body body)
39 `(make-c-dependent
40 :code ',body
41 :value-state :unevaluated
42 :rule (c-lambda ,@body)))
43
44 (defmacro c?8 (&body body)
45 `(make-c-dependent
46 :code ',body
47 :cyclicp t
48 :value-state :unevaluated
49 :rule (c-lambda ,@body)))
50
51 (defmacro c?dbg (&body body)
52 `(make-c-dependent
53 :code ',body
54 :value-state :unevaluated
55 :debug t
56 :rule (c-lambda ,@body)))
57
58 (defmacro c?_ (&body body)
59 `(make-c-dependent
60 :code ',body
61 :value-state :unevaluated
62 :lazy t
63 :rule (c-lambda ,@body)))
64
65 (defmacro c?? ((&key (tagp nil) (in nil) (trigger nil) (out t))&body body)
66 (let ((result (copy-symbol 'result))
67 (thetag (gensym)))
68 `(make-c-dependent
69 :code ',body
70 :value-state :unevaluated
71 :rule (c-lambda
72 (let ((,thetag (gensym "tag"))
73 (*trcdepth* (1+ *trcdepth*))
74 )
75 (declare (ignorable self ,thetag))
76 ,(when in
77 `(trc "c??> entry" (c-slot-name c) (c-model c) (when ,tagp ,thetag)))
78 ,(when trigger `(trc "c??> trigger" .cause c))
79 (count-it :c?? (c-slot-name c) (md-name (c-model c)))
80 (let ((,result (progn ,@body)))
81 ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag)))
82 ,result))))))
83
84 (defmacro c-formula ((&rest keys &key lazy) &body forms)
85 (assert (member lazy '(nil t :once-asked :until-asked :always)))
86 `(make-c-dependent
87 :code ',forms
88 :value-state :unevaluated
89 :rule (c-lambda ,@forms)
90 ,@keys))
91
92 (defmacro c-input ((&rest keys) &optional (value nil valued-p))
93 `(make-cell
94 :inputp t
95 :value-state ,(if valued-p :valid :unbound)
96 :value ,value
97 ,@keys))
98
99 (defmacro c-in (value)
100 `(make-cell
101 :inputp t
102 :value-state :valid
103 :value ,value))
104
105 (defmacro c-in8 (value)
106 `(make-cell
107 :inputp t
108 :cyclicp t
109 :value-state :valid
110 :value ,value))
111
112 (defmacro c-input-dbg (&optional (value nil valued-p))
113 `(make-cell
114 :inputp t
115 :debug t
116 :value-state ,(if valued-p :valid :unbound)
117 :value ,value))
118
119 (defmacro c... ((value) &body body)
120 `(make-c-drifter
121 :code ',body
122 :value-state :valid
123 :value ,value
124 :rule (c-lambda ,@body)))
125
126 (defmacro c-abs (value &body body)
127 `(make-c-drifter-absolute
128 :code ',body
129 :value-state :valid
130 :value ,value
131 :rule (c-lambda ,@body)))
132
133
134 (defmacro c-envalue (&body body)
135 `(make-c-envaluer
136 :envalue-rule (c-lambda ,@body)))
137

  ViewVC Help
Powered by ViewVC 1.1.5