/[cmucl]/src/contrib/ops/ops-backup.lisp
ViewVC logotype

Contents of /src/contrib/ops/ops-backup.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Thu Feb 20 18:26:01 1992 UTC (22 years, 2 months ago) by ram
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, RELENG_18, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Initial revision
1 ;
2 ;************************************************************************
3 ;
4 ; VPS2 -- Interpreter for OPS5
5 ;
6 ;
7 ;
8 ; This Common Lisp version of OPS5 is in the public domain. It is based
9 ; in part on based on a Franz Lisp implementation done by Charles L. Forgy
10 ; at Carnegie-Mellon University, which was placed in the public domain by
11 ; the author in accordance with CMU policies. This version has been
12 ; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
13 ; and Dan Kuokka.
14 ;
15 ; This code is made available is, and without warranty of any kind by the
16 ; authors or by Carnegie-Mellon University.
17 ;
18
19 ;;;; Definitions and functions for backing up.
20
21 (in-package "OPS")
22
23
24 ;;; Internal Global Variables
25
26 (defvar *refracts*)
27 (defvar *record*)
28 (defvar *record-array*)
29 (defvar *recording*)
30 (defvar *max-record-index*)
31 (defvar *record-index*)
32
33
34
35 (defun backup-init ()
36 (setq *recording* nil)
37 (setq *refracts* nil)
38 (setq *record-array* (make-array 256 :initial-element ())) ;jgk
39 (initialize-record))
40
41
42 (defun back (k)
43 (prog (r)
44 loop (and (< k 1.) (return nil))
45 (setq r (getvector *record-array* *record-index*)) ; (('))
46 (and (null r) (return '|nothing more stored|))
47 (putvector *record-array* *record-index* nil)
48 (record-index-plus -1.)
49 (undo-record r)
50 (setq k (1- k))
51 (go loop)))
52
53
54 ; *max-record-index* holds the maximum legal index for record-array
55 ; so it and the following must be changed at the same time
56
57 (defun begin-record (p data)
58 (setq *recording* t)
59 (setq *record* (list '=>refract p data)))
60
61 (defun end-record nil
62 (cond (*recording*
63 (setq *record*
64 (cons *cycle-count* (cons *p-name* *record*)))
65 (record-index-plus 1.)
66 (putvector *record-array* *record-index* *record*)
67 (setq *record* nil)
68 (setq *recording* nil))))
69
70 (defun record-change (direct time elm)
71 (cond (*recording*
72 (setq *record*
73 (cons direct (cons time (cons elm *record*)))))))
74
75 ; to maintain refraction information, need keep only one piece of information:
76 ; need to record all unsuccessful attempts to delete things from the conflict
77 ; set. unsuccessful deletes are caused by attempting to delete refracted
78 ; instantiations. when backing up, have to avoid putting things back into the
79 ; conflict set if they were not deleted when running forward
80
81 (defun record-refract (rule data)
82 (and *recording*
83 (setq *record* (cons '<=refract (cons rule (cons data *record*))))))
84
85 (defun refracted (rule data)
86 (prog (z)
87 (and (null *refracts*) (return nil))
88 (setq z (cons rule data))
89 (return (member z *refracts* :test #'equal))))
90
91
92 (defun record-index-plus (k)
93 (setq *record-index* (+ k *record-index*)) ;"plus" changed to "+" by gdw
94 (cond ((< *record-index* 0.)
95 (setq *record-index* *max-record-index*))
96 ((> *record-index* *max-record-index*)
97 (setq *record-index* 0.))))
98
99 ; the following routine initializes the record. putting nil in the
100 ; first slot indicates that that the record does not go back further
101 ; than that. (when the system backs up, it writes nil over the used
102 ; records so that it will recognize which records it has used. thus
103 ; the system is set up anyway never to back over a nil.)
104
105 (defun initialize-record nil
106 (setq *record-index* 0.)
107 (setq *recording* nil)
108 (setq *max-record-index* 31.)
109 (putvector *record-array* 0. nil))
110
111
112 ;; replaced per jcp
113 ;;; Commented out
114 #|
115 (defun undo-record (r)
116 (prog (save act a b rate)
117 ;### (comment *recording* must be off during back up)
118 (setq save *recording*)
119 (setq *refracts* nil)
120 (setq *recording* nil)
121 (and *ptrace* (back-print (list '|undo:| (car r) (cadr r))))
122 (setq r (cddr r))
123 top (and (atom r) (go fin))
124 (setq act (car r))
125 (setq a (cadr r))
126 (setq b (caddr r))
127 (setq r (cdddr r))
128 (and *wtrace* (back-print (list '|undo:| act a)))
129 (cond ((eq act '<=wm) (add-to-wm b a))
130 ((eq act '=>wm) (remove-from-wm b))
131 ((eq act '<=refract)
132 (setq *refracts* (cons (cons a b) *refracts*)))
133 ((and (eq act '=>refract) (still-present b))
134 (setq *refracts* (delete (cons a b) *refracts*))
135 (setq rate (rating-part (get a 'topnode)))
136 (removecs a b)
137 (insertcs a b rate))
138 (t (%warn '|back: cannot undo action| (list act a))))
139 (go top)
140 fin (setq *recording* save)
141 (setq *refracts* nil)
142 (return nil)))
143 ;;; End commented out
144 |#
145
146
147 (defun undo-record (r)
148 (prog (save act a b rate)
149 ;### (comment *recording* must be off during back up)
150 (setq save *recording*)
151 (setq *refracts* nil)
152 (setq *recording* nil)
153 (and *ptrace* (back-print (list '|undo:| (car r) (cadr r))))
154 (setq r (cddr r))
155 top (and (atom r) (go fin))
156 (setq act (car r))
157 (setq a (cadr r))
158 (setq b (caddr r))
159 (setq r (cdddr r))
160 (and *wtrace* (back-print (list '|undo:| act a)))
161 (cond ((eq act '<=wm) (add-to-wm b a))
162 ((eq act '=>wm) (remove-from-wm b))
163 ((eq act '<=refract)
164 (setq *refracts* (cons (cons a b) *refracts*)))
165 ((and (eq act '=>refract) (still-present b))
166 (setq *refracts* (spdelete (cons a b) *refracts*))
167 (setq rate (rating-part (get a 'topnode)))
168 (removecs a b)
169 (insertcs a b rate))
170 (t (%warn '|back: cannot undo action| (list act a))))
171 (go top)
172 fin (setq *recording* save)
173 (setq *refracts* nil)
174 (return nil)))
175
176
177
178 ; still-present makes sure that the user has not deleted something
179 ; from wm which occurs in the instantiation about to be restored; it
180 ; makes the check by determining whether each wme still has a time tag.
181
182 (defun still-present (data)
183 (prog nil
184 loop
185 (cond ((atom data) (return t))
186 ((creation-time (car data))
187 (setq data (cdr data))
188 (go loop))
189 (t (return nil)))))
190
191
192 (defun back-print (x)
193 (prog (port)
194 (setq port (trace-file))
195 (terpri port)
196 (print x port)))

  ViewVC Help
Powered by ViewVC 1.1.5