/[cells-gtk]/cells/slot-utilities.lisp
ViewVC logotype

Contents of /cells/slot-utilities.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 (defun c-setting-debug (self slot-name c new-value)
26 (declare (ignorable new-value))
27 (if (null c)
28 (progn
29 (format t "c-setting-debug > constant ~a in ~a may not be altered..init to (c-in nil)"
30 slot-name self)
31
32 (c-break "setting-const-cell")
33 (error "setting-const-cell"))
34 (let ((self (c-model c))
35 (slot-name (c-slot-name c)))
36 ;(trc "c-setting-debug sees" c newvalue self slot-name)
37 (when (and c (not (and slot-name self)))
38 ;; cv-test handles errors, so don't set *stop* (c-stop)
39 (c-break "unadopted ~a for self ~a spec ~a" c self slot-name)
40 (error 'c-unadopted :cell c))
41 (typecase c
42 (c-dependent
43 ;(trc "setting c-dependent" c newvalue)
44 (format t "c-setting-debug > ruled ~a in ~a may not be setf'ed"
45 (c-slot-name c) self)
46
47 (c-break "setting-ruled-cell")
48 (error "setting-ruled-cell"))
49 ))))
50
51 (defun c-absorb-value (c value)
52 (typecase c
53 (c-drifter-absolute (c-value-incf c value 0)) ;; strange but true
54 (c-drifter (c-value-incf c (c-value c) value))
55 (t value)))
56
57 (eval-when (:compile-toplevel :load-toplevel :execute)
58 (export '(c-value-incf)))
59
60 (defmethod c-value-incf (c (envaluer c-envaluer) delta)
61 (c-assert (c-model c))
62 (c-value-incf c (funcall (envalue-rule envaluer) c)
63 delta))
64
65 (defmethod c-value-incf (c (base number) delta)
66 (declare (ignore c))
67 (if delta
68 (+ base delta)
69 base))
70
71
72 ;----------------------------------------------------------------------
73
74 (defun bd-slot-value (self slot-name)
75 (slot-value self slot-name))
76
77 (defun (setf bd-slot-value) (new-value self slot-name)
78 (setf (slot-value self slot-name) new-value))
79
80 (defun bd-bound-slot-value (self slot-name caller-id)
81 (declare (ignorable caller-id))
82 (when (bd-slot-boundp self slot-name)
83 (bd-slot-value self slot-name)))
84
85 (defun bd-slot-boundp (self slot-name)
86 (slot-boundp self slot-name))
87
88 (defun bd-slot-makunbound (self slot-name)
89 (slot-makunbound self slot-name))
90
91 #| sample incf
92 (defmethod c-value-incf ((base fpoint) delta)
93 (declare (ignore model))
94 (if delta
95 (fp-add base delta)
96 base))
97 |#

  ViewVC Help
Powered by ViewVC 1.1.5