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

Contents of /cells/link.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
26
27
28 (defun c-link-ex (used &aux (user (car *c-calculators*)))
29 (c-assert user)
30 (assert used)
31 (when (or (c-optimized-away-p used)
32 (not (typep used 'cell)))
33 (return-from c-link-ex nil))
34
35
36 ;
37 ; --------- debug stuff --------------
38 (c-assert user)
39 (c-assert (c-model user))
40 (c-assert (c-model used))
41 (c-assert (not (cmdead user)) () "dead user in link-ex ~a, used being ~a" user used)
42 (c-assert (not (cmdead used)) () "dead used in link-ex ~a, user being ~a" used user)
43
44 #+dfdbg (trc user "c-link > user, used" user used)
45 (c-assert (not (eq :eternal-rest (md-state (c-model user)))))
46 (c-assert (not (eq :eternal-rest (md-state (c-model used)))))
47 (count-it :c-link-entry)
48
49
50 (unless (find used (c-useds user))
51 (trc nil "c-link > new user,used " user used)
52 (c-add-user used user)
53 (c-add-used user used))
54
55 (let ((mapn (- *cd-usagect*
56 (- (length (cd-useds user))
57 (or (position used (cd-useds user)) 0)))))
58 ;; (trc user "c-link> setting usage bit" user mapn used)
59 (if (minusp mapn)
60 (c-break "whoa. more than ~d used by ~a? i see ~d"
61 *cd-usagect* user (length (cd-useds user)))
62 (cd-usage-set user mapn)))
63 used)
64
65 ;--- c-unlink-unused --------------------------------
66
67 (defun c-unlink-unused (c &aux (usage (cd-usage c)))
68 (loop for useds on (cd-useds c)
69 for used = (car useds)
70 for mapn upfrom (- *cd-usagect* (length (cd-useds c)))
71 when (zerop (sbit usage mapn))
72 do
73 (c-assert (not (minusp mapn)))
74 (c-assert (< mapn *cd-usagect*))
75
76 (trc nil "dropping unused" used :mapn-usage mapn usage)
77 (c-unlink-user used c)
78 (rplaca useds nil))
79 (setf (cd-useds c) (delete-if #'null (cd-useds c))))
80
81 (defun c-add-user (used user)
82 (count-it :c-adduser)
83 (pushnew user (c-users used))
84 used)
85
86 (defun c-user-path-exists-p (from-used to-user)
87 (count-it :user-path-exists-p)
88 (or (find to-user (c-users from-used))
89 (find-if (lambda (from-used-user)
90 (c-user-path-exists-p from-used-user to-user))
91 (c-users from-used))))
92
93 ; -----------
94
95 (defun c-add-used (user used)
96 (count-it :c-used)
97 #+ucount (unless (member used (cd-useds user))
98 (incf *cd-useds*)
99 (when (zerop (mod *cd-useds* 100))
100 (trc "useds count = " *cd-useds*)))
101 (pushnew used (cd-useds user))
102 (trc nil "c-add-used> user <= used" user used (length (cd-useds user)))
103 (cd-useds user))
104
105 ; ---------------------------------------------
106
107 (defun cd-usage-set (c mapn)
108 (setf (sbit (cd-usage c) mapn) 1))
109
110 (defun cd-usage-clear-all (c)
111 (bit-and (cd-usage c)
112 #*0000000000000000000000000000000000000000000000000000000000000000
113 t))
114
115 ;--- unlink from used ----------------------
116
117 (defmethod c-unlink-from-used ((user c-dependent))
118 (dolist (used (cd-useds user))
119 #+dfdbg (trc user "unlinking from used" user used)
120 (c-unlink-user used user))
121 ;; shouldn't be necessary (setf (cd-useds user) nil)
122 )
123
124 (defmethod c-unlink-from-used (other)
125 (declare (ignore other)))
126
127 ;----------------------------------------------------------
128
129 (defun c-unlink-user (used user)
130 #+dfdbg (trc user "user unlinking from used" user used)
131 (setf (c-users used) (delete user (c-users used)))
132 (c-unlink-used user used))
133
134 (defun c-unlink-used (user used)
135 (setf (cd-useds user) (delete used (cd-useds user))))
136
137 ;----------------- link debugging ---------------------
138
139 (defun dump-users (c &optional (depth 0))
140 (format t "~&~v,4t~s" depth c)
141 (dolist (user (c-users c))
142 (dump-users user (+ 1 depth))))
143
144 (defun dump-useds (c &optional (depth 0))
145 ;(c.trc "dump-useds> entry " c (+ 1 depth))
146 (when (zerop depth)
147 (format t "x~&"))
148 (format t "~&|usd> ~v,8t~s" depth c)
149 (when (typep c 'c-ruled)
150 ;(c.trc "its ruled" c)
151 (dolist (used (cd-useds c))
152 (dump-useds used (+ 1 depth)))))
153

  ViewVC Help
Powered by ViewVC 1.1.5