/[cells]/cells/variables.lisp
ViewVC logotype

Contents of /cells/variables.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Mon Jan 29 06:44:01 2007 UTC (7 years, 2 months ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +1 -0 lines
Some interesting changes
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
2 #|
3
4 Cells -- Automatic Dataflow Managememnt
5
6 Copyright (C) 1995, 2006 by Kenneth Tilton
7
8 This library is free software; you can redistribute it and/or
9 modify it under the terms of the Lisp Lesser GNU Public License
10 (http://opensource.franz.com/preamble.html), known as the LLGPL.
11
12 This library is distributed WITHOUT ANY WARRANTY; without even
13 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
14
15 See the Lisp Lesser GNU Public License for more details.
16
17 |#
18
19 (in-package :cells)
20
21 (defun c-variable-accessor (symbol)
22 (assert (symbolp symbol))
23 (c-variable-reader symbol))
24
25 (defun (setf c-variable-accessor) (value symbol)
26 (assert (symbolp symbol))
27 (c-variable-writer value symbol))
28
29 (defun c-variable-reader (symbol)
30 (assert (symbolp symbol))
31 (assert (get symbol 'cell))
32 (cell-read (get symbol 'cell)))
33
34 (defun c-variable-writer (value symbol)
35 (assert (symbolp symbol))
36 (setf (md-slot-value nil symbol) value)
37 (setf (symbol-value symbol) value))
38
39 (export! def-c-variable)
40
41 (defmacro def-c-variable (v-name cell &key ephemeral owning unchanged-if)
42 (declare (ignore unchanged-if))
43 (let ((c 'whathef)) ;;(gensym)))
44 `(progn
45 (eval-when (:compile-toplevel :load-toplevel)
46 (define-symbol-macro ,v-name (c-variable-accessor ',v-name))
47 (setf (md-slot-cell-type 'null ',v-name) (when ,ephemeral :ephemeral))
48 (when ,owning
49 (setf (md-slot-owning 'null ',v-name) t)))
50 (eval-when (:load-toplevel)
51 (let ((,c ,cell))
52 (md-install-cell nil ',v-name ,c)
53 (awaken-cell ,c)))
54 ',v-name)))
55
56
57 (defobserver *kenny* ()
58 (trcx kenny-obs new-value old-value old-value-boundp))
59
60 #+test
61 (def-c-variable *kenny* (c-in nil))
62
63
64 #+test
65 (defmd kenny-watcher ()
66 (twice (c? (bwhen (k *kenny*)
67 (* 2 k)))))
68
69 (defobserver twice ()
70 (trc "twice kenny is:" new-value self old-value old-value-boundp))
71
72 #+test-ephem
73 (progn
74 (cells-reset)
75 (let ((tvw (make-instance 'kenny-watcher)))
76 (trcx twice-read (twice tvw))
77 (setf *c-debug* nil)
78 (setf *kenny* 42)
79 (setf *kenny* 42)
80 (trcx post-setf-kenny *kenny*)
81 (trcx print-twice (twice tvw))
82 ))
83
84 #+test
85 (let ((*kenny* 13)) (print *kenny*))
86
87 #+test
88 (let ((c (c-in 42)))
89 (md-install-cell '*test-c-variable* '*test-c-variable* c)
90 (awaken-cell c)
91 (let ((tvw (make-instance 'test-var-watcher)))
92 (trcx twice-read (twice tvw))
93 (setf *test-c-variable* 69)
94 (trcx print-testvar *test-c-variable*)
95 (trcx print-twice (twice tvw))
96 (unless (eql (twice tvw) 138)
97 (inspect (md-slot-cell tvw 'twice))
98 (inspect c)
99 ))
100 )
101
102 #+test2
103 (let ((tvw (make-instance 'test-var-watcher :twice (c-in 42))))
104 (let ((c (c? (trcx joggggggggging!!!!!!!!!!!!!!!)
105 (floor (twice tvw) 2))))
106 (md-install-cell '*test-c-variable* '*test-c-variable* c)
107 (awaken-cell c)
108 (trcx print-testvar *test-c-variable*)
109 (trcx twice-read (twice tvw))
110 (setf (twice tvw) 138)
111 (trcx print-twice (twice tvw))
112 (trcx print-testvar *test-c-variable*)
113 (unless (eql *test-c-variable* 69)
114 (inspect (md-slot-cell tvw 'twice))
115 (inspect c)
116 ))
117 )
118

  ViewVC Help
Powered by ViewVC 1.1.5