git.fiddlerwoaroof.com
Browse code

chore: reformat

Ed L authored on 21/11/2019 08:11:33
Showing 8 changed files
... ...
@@ -47,8 +47,8 @@
47 47
       (undo-record r))))
48 48
 
49 49
 
50
-; *max-record-index* holds the maximum legal index for record-array
51
-; so it and the following must be changed at the same time
50
+;; *max-record-index* holds the maximum legal index for record-array
51
+;; so it and the following must be changed at the same time
52 52
 
53 53
 (defun begin-record (p data)
54 54
   (setq *recording* t)
... ...
@@ -57,7 +57,7 @@
57 57
 (defun end-record ()
58 58
   (when *recording*
59 59
     (setq *record*
60
-	  (cons *cycle-count* (cons *p-name* *record*)))
60
+          (cons *cycle-count* (cons *p-name* *record*)))
61 61
     (record-index-plus 1.)
62 62
     (setf (aref *record-array* *record-index*) *record*)
63 63
     (setq *record* nil)
... ...
@@ -66,13 +66,13 @@
66 66
 (defun record-change (direct time elm)
67 67
   (when *recording*
68 68
     (setq *record*
69
-	  (cons direct (cons time (cons elm *record*)))))) 
69
+          (cons direct (cons time (cons elm *record*)))))) 
70 70
 
71
-; to maintain refraction information, need keep only one piece of information:
72
-; need to record all unsuccessful attempts to delete things from the conflict
73
-; set.  unsuccessful deletes are caused by attempting to delete refracted
74
-; instantiations.  when backing up, have to avoid putting things back into the
75
-; conflict set if they were not deleted when running forward
71
+;; to maintain refraction information, need keep only one piece of information:
72
+;; need to record all unsuccessful attempts to delete things from the conflict
73
+;; set.  unsuccessful deletes are caused by attempting to delete refracted
74
+;; instantiations.  when backing up, have to avoid putting things back into the
75
+;; conflict set if they were not deleted when running forward
76 76
 
77 77
 (defun record-refract (rule data)
78 78
   (when *recording*
... ...
@@ -82,25 +82,25 @@
82 82
   (when *refracts*
83 83
     (let ((z (cons rule data)))
84 84
       (member z *refracts* :test #'equal)))
85
-  #|(prog (z)
86
-    (and (null *refracts*) (return nil))
87
-    (setq z (cons rule data))
88
-    (return (member z *refracts* :test #'equal)))|#
89
-  )
85
+  #+(or)
86
+  (prog (z)
87
+     (and (null *refracts*) (return nil))
88
+     (setq z (cons rule data))
89
+     (return (member z *refracts* :test #'equal))))
90 90
 
91 91
 
92 92
 (defun record-index-plus (k)
93 93
   (incf *record-index* k)
94 94
   (cond ((< *record-index* 0.)
95
-	 (setq *record-index* *max-record-index*))
96
-	((> *record-index* *max-record-index*)
97
-	 (setq *record-index* 0.)))) 
95
+         (setq *record-index* *max-record-index*))
96
+        ((> *record-index* *max-record-index*)
97
+         (setq *record-index* 0.))))
98 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.)
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 104
 
105 105
 (defun initialize-record nil
106 106
   (setq *record-index* 0.)
... ...
@@ -111,82 +111,81 @@
111 111
 
112 112
 ;; replaced per jcp
113 113
 ;;; Commented out
114
-#|
114
+#+(or)
115 115
 (defun undo-record (r)
116 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 (gethash a *topnode-table*)))
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)))
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 (gethash a *topnode-table*)))
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 143
 ;;; End commented out
144
-|#
145 144
 
146 145
 
147 146
 (defun undo-record (r)
148 147
   (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* (tree-remove (cons a b) *refracts*))
167
-	   (setq rate (rating-part (gethash a *topnode-table*)))
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.
148
+     ;;###	(comment *recording* must be off during back up)
149
+     (setq save *recording*)
150
+     (setq *refracts* nil)
151
+     (setq *recording* nil)
152
+     (and *ptrace* (back-print (list '|undo:| (car r) (cadr r))))
153
+     (setq r (cddr r))
154
+   top  (and (atom r) (go fin))
155
+     (setq act (car r))
156
+     (setq a (cadr r))
157
+     (setq b (caddr r))
158
+     (setq r (cdddr r))
159
+     (and *wtrace* (back-print (list '|undo:| act a)))
160
+     (cond ((eq act '<=wm) (add-to-wm b a))
161
+           ((eq act '=>wm) (remove-from-wm b))
162
+           ((eq act '<=refract)
163
+            (setq *refracts* (cons (cons a b) *refracts*)))
164
+           ((and (eq act '=>refract) (still-present b))
165
+            (setq *refracts* (tree-remove (cons a b) *refracts*))
166
+            (setq rate (rating-part (gethash a *topnode-table*)))
167
+            (removecs a b)
168
+            (insertcs a b rate))
169
+           (t (%warn '|back: cannot undo action| (list act a))))
170
+     (go top)
171
+   fin  (setq *recording* save)
172
+     (setq *refracts* nil)
173
+     (return nil))) 
174
+
175
+
176
+
177
+;; still-present makes sure that the user has not deleted something
178
+;; from wm which occurs in the instantiation about to be restored; it
179
+;; makes the check by determining whether each wme still has a time tag.
181 180
 
182 181
 (defun still-present (data)
183 182
   (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))))) 
183
+   loop
184
+     (cond ((atom data) (return t))
185
+           ((creation-time (car data))
186
+            (setq data (cdr data))
187
+            (go loop))
188
+           (t (return nil))))) 
190 189
 
191 190
 (defun back-print (x) 
192 191
   (let ((stream (trace-file)))
... ...
@@ -17,8 +17,8 @@
17 17
 ;;;; This file contains functions compile productions.
18 18
 
19 19
 (in-package "OPS")
20
-;(shadow '(remove write))    ; Should get this by requiring ops-rhs
21
-;(export '--> )
20
+;;(shadow '(remove write))    ; Should get this by requiring ops-rhs
21
+;;(export '--> )
22 22
 
23 23
 
24 24
 ;;; External global variables
... ...
@@ -58,7 +58,7 @@
58 58
 (defun ops-p (z) 
59 59
   (finish-literalize)
60 60
   (princ '*) 
61
-  ;(drain) commented out temporarily
61
+  ;;(drain) commented out temporarily
62 62
   (force-output)			;@@@ clisp drain?
63 63
   (compile-production (car z) (cdr z))) 
64 64
 
... ...
@@ -68,13 +68,14 @@
68 68
   (setq *p-name* name)
69 69
   (catch '!error! (cmp-p name matrix))
70 70
   (setq *p-name* nil))
71
-#|
71
+
72
+#+(or)
72 73
 (defun compile-production (name matrix) ;jgk inverted args to catch 
73 74
   (prog (erm)				;and quoted tag
74
-    (setq *p-name* name)
75
-    (setq erm (catch '!error! (cmp-p name matrix)))
76
-    (setq *p-name* nil)))
77
-|#
75
+     (setq *p-name* name)
76
+     (setq erm (catch '!error! (cmp-p name matrix)))
77
+     (setq *p-name* nil)))
78
+
78 79
 
79 80
 (defun peek-lex ()
80 81
   (car *matrix*)) 
... ...
@@ -105,37 +106,37 @@
105 106
 
106 107
 (defun cmp-p (name matrix)
107 108
   (prog (m bakptrs)
108
-    (cond ((or (null name) (consp  name))	;dtpr\consp gdw
109
-	   (%error '|illegal production name| name))
110
-	  ((equal (gethash name *production-table*) matrix)
111
-	   (return nil)))
112
-    (prepare-lex matrix)
113
-    (excise-p name)
114
-    (setq bakptrs nil)
115
-    (incf *pcount*)		;"plus" changed to "+" by gdw
116
-    (setq *feature-count* 0.)
117
-    (setq *ce-count* 0)
118
-    (setq *vars* nil)
119
-    (setq *ce-vars* nil)
120
-    (setq *rhs-bound-vars* nil)
121
-    (setq *rhs-bound-ce-vars* nil)
122
-    (setq *last-branch* nil)
123
-    (setq m (rest-of-p))
124
-    l1   (and (end-of-p) (%error '|no '-->' in production| m))
125
-    (cmp-prin)
126
-    (setq bakptrs (cons *last-branch* bakptrs))
127
-    (or (eq '--> (peek-lex)) (go l1))
128
-    (lex)
129
-    (check-rhs (rest-of-p))
130
-    (link-new-node (list '&p
131
-			 *feature-count*
132
-			 name
133
-			 (encode-dope)
134
-			 (encode-ce-dope)
135
-			 (cons 'progn (rest-of-p))))
136
-    (setf (gethash name *backpointers-table*) (cdr (nreverse bakptrs)))
137
-    (setf (gethash name *production-table*) matrix)
138
-    (setf (gethash name *topnode-table*) *last-node*))) 
109
+     (cond ((or (null name) (consp  name))	;dtpr\consp gdw
110
+            (%error '|illegal production name| name))
111
+           ((equal (gethash name *production-table*) matrix)
112
+            (return nil)))
113
+     (prepare-lex matrix)
114
+     (excise-p name)
115
+     (setq bakptrs nil)
116
+     (incf *pcount*)		;"plus" changed to "+" by gdw
117
+     (setq *feature-count* 0.)
118
+     (setq *ce-count* 0)
119
+     (setq *vars* nil)
120
+     (setq *ce-vars* nil)
121
+     (setq *rhs-bound-vars* nil)
122
+     (setq *rhs-bound-ce-vars* nil)
123
+     (setq *last-branch* nil)
124
+     (setq m (rest-of-p))
125
+   l1   (and (end-of-p) (%error '|no '-->' in production| m))
126
+     (cmp-prin)
127
+     (setq bakptrs (cons *last-branch* bakptrs))
128
+     (or (eq '--> (peek-lex)) (go l1))
129
+     (lex)
130
+     (check-rhs (rest-of-p))
131
+     (link-new-node (list '&p
132
+                          *feature-count*
133
+                          name
134
+                          (encode-dope)
135
+                          (encode-ce-dope)
136
+                          (cons 'progn (rest-of-p))))
137
+     (setf (gethash name *backpointers-table*) (cdr (nreverse bakptrs)))
138
+     (setf (gethash name *production-table*) matrix)
139
+     (setf (gethash name *topnode-table*) *last-node*))) 
139 140
 
140 141
 (defun rating-part (pnode) (cadr pnode)) 
141 142
 
... ...
@@ -148,23 +149,23 @@
148 149
 (defun cmp-prin nil
149 150
   (setq *last-node* *first-node*)
150 151
   (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta))
151
-	((eq (peek-lex) '-) (cmp-negce) (cmp-not))
152
-	(t (cmp-posce) (cmp-and)))) 
152
+        ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
153
+        (t (cmp-posce) (cmp-and)))) 
153 154
 
154 155
 (defun cmp-negce nil (lex) (cmp-ce)) 
155 156
 
156 157
 (defun cmp-posce nil
157 158
   (setq *ce-count* (1+ *ce-count*))		;"plus" changed to "+" by gdw
158 159
   (cond ((eq (peek-lex) '\{) (cmp-ce+cevar))	;"plus" changed to "+" by gdw
159
-	(t (cmp-ce)))) 
160
+        (t (cmp-ce)))) 
160 161
 
161 162
 (defun cmp-ce+cevar ()
162 163
   (prog (z)
163
-    (lex)
164
-    (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
165
-	  (t (cmp-ce) (cmp-cevar)))
166
-    (setq z (lex))
167
-    (or (eq z '\}) (%error '|missing '}'| z)))) 
164
+     (lex)
165
+     (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
166
+           (t (cmp-ce) (cmp-cevar)))
167
+     (setq z (lex))
168
+     (or (eq z '\}) (%error '|missing '}'| z)))) 
168 169
 
169 170
 (defun new-subnum (k)
170 171
   (or (numberp k) (%error '|tab must be a number| k))
... ...
@@ -175,42 +176,42 @@
175 176
 
176 177
 (defun cmp-ce ()
177 178
   (prog (z)
178
-    (new-subnum 0.)
179
-    (setq *cur-vars* nil)
180
-    (setq z (lex))
181
-    (and (atom z)
182
-	 (%error '|atomic conditions are not allowed| z))
183
-    (prepare-sublex z)
184
-    la   (and (end-of-ce) (return nil))
185
-    (incr-subnum)
186
-    (cmp-element)
187
-    (go la))) 
179
+     (new-subnum 0.)
180
+     (setq *cur-vars* nil)
181
+     (setq z (lex))
182
+     (and (atom z)
183
+          (%error '|atomic conditions are not allowed| z))
184
+     (prepare-sublex z)
185
+   la   (and (end-of-ce) (return nil))
186
+     (incr-subnum)
187
+     (cmp-element)
188
+     (go la))) 
188 189
 
189 190
 (defun cmp-element nil
190 191
   (when (eq (peek-sublex) '^)
191 192
     (cmp-tab))
192 193
   (cond ((eq (peek-sublex) '\{) (cmp-product))
193
-	(t (cmp-atomic-or-any))))
194
+        (t (cmp-atomic-or-any))))
194 195
 
195 196
 (defun cmp-atomic-or-any ()
196 197
   (cond ((eq (peek-sublex) '<<) (cmp-any))
197
-	(t (cmp-atomic))))
198
+        (t (cmp-atomic))))
198 199
 
199 200
 (defun cmp-any ()
200 201
   (prog (a z)
201
-    (sublex)
202
-    (setq z nil)
203
-    la   (cond ((end-of-ce) (%error '|missing '>>'| a)))
204
-    (setq a (sublex))
205
-    (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
206
-    (link-new-node (list '&any nil (current-field) z)))) 
202
+     (sublex)
203
+     (setq z nil)
204
+   la   (cond ((end-of-ce) (%error '|missing '>>'| a)))
205
+     (setq a (sublex))
206
+     (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
207
+     (link-new-node (list '&any nil (current-field) z)))) 
207 208
 
208 209
 (defun cmp-tab nil
209 210
   (prog (r)
210
-    (sublex)
211
-    (setq r (sublex))
212
-    (setq r ($litbind r))
213
-    (new-subnum r))) 
211
+     (sublex)
212
+     (setq r (sublex))
213
+     (setq r ($litbind r))
214
+     (new-subnum r))) 
214 215
 
215 216
 (defun get-bind (x)
216 217
   (when (symbolp x)
... ...
@@ -218,28 +219,28 @@
218 219
 
219 220
 (defun cmp-atomic nil
220 221
   (prog (test x)
221
-    (setq x (peek-sublex))
222
-    (cond ((eq x '= ) (setq test 'eq) (sublex))
223
-	  ((eq x '<>) (setq test 'ne) (sublex))
224
-	  ((eq x '<) (setq test 'lt) (sublex))
225
-	  ((eq x '<=) (setq test 'le) (sublex))
226
-	  ((eq x '>) (setq test 'gt) (sublex))
227
-	  ((eq x '>=) (setq test 'ge) (sublex))
228
-	  ((eq x '<=>) (setq test 'xx) (sublex))
229
-	  (t (setq test 'eq)))
230
-    (cmp-symbol test))) 
222
+     (setq x (peek-sublex))
223
+     (cond ((eq x '= ) (setq test 'eq) (sublex))
224
+           ((eq x '<>) (setq test 'ne) (sublex))
225
+           ((eq x '<) (setq test 'lt) (sublex))
226
+           ((eq x '<=) (setq test 'le) (sublex))
227
+           ((eq x '>) (setq test 'gt) (sublex))
228
+           ((eq x '>=) (setq test 'ge) (sublex))
229
+           ((eq x '<=>) (setq test 'xx) (sublex))
230
+           (t (setq test 'eq)))
231
+     (cmp-symbol test))) 
231 232
 
232 233
 (defun cmp-product ()
233 234
   (prog (save)
234
-    (setq save (rest-of-ce))
235
-    (sublex)
236
-    la   (cond ((end-of-ce)
237
-		(cond ((member '\} save :test #'equal) 
238
-		       (%error '|wrong contex for '}'| save))
239
-		      (t (%error '|missing '}'| save))))
240
-	       ((eq (peek-sublex) '\}) (sublex) (return nil)))
241
-    (cmp-atomic-or-any)
242
-    (go la))) 
235
+     (setq save (rest-of-ce))
236
+     (sublex)
237
+   la   (cond ((end-of-ce)
238
+               (cond ((member '\} save :test #'equal) 
239
+                      (%error '|wrong contex for '}'| save))
240
+                     (t (%error '|missing '}'| save))))
241
+              ((eq (peek-sublex) '\}) (sublex) (return nil)))
242
+     (cmp-atomic-or-any)
243
+     (go la))) 
243 244
 
244 245
 (defun cmp-symbol (test)
245 246
   (let ((flag t))
... ...
@@ -247,77 +248,77 @@
247 248
       (sublex)
248 249
       (setq flag nil))
249 250
     (cond ((and flag (variablep (peek-sublex)))
250
-	   (cmp-var test))
251
-	  ((numberp (peek-sublex)) (cmp-number test))
252
-	  ((symbolp (peek-sublex)) (cmp-constant test))
253
-	  (t (%error '|unrecognized symbol| (sublex)))))) 
251
+           (cmp-var test))
252
+          ((numberp (peek-sublex)) (cmp-number test))
253
+          ((symbolp (peek-sublex)) (cmp-constant test))
254
+          (t (%error '|unrecognized symbol| (sublex)))))) 
254 255
 
255 256
 (defun cmp-constant (test)   ;jgk inserted concatenate form
256 257
   (or (member test '(eq ne xx))
257 258
       (%error '|non-numeric constant after numeric predicate| (sublex)))
258 259
   (link-new-node (list (intern (concatenate 'string
259
-					    "T"
260
-					    (symbol-name  test)
261
-					    "A"))
262
-		       nil
263
-		       (current-field)
264
-		       (sublex)))) 
260
+                                            "T"
261
+                                            (symbol-name  test)
262
+                                            "A"))
263
+                       nil
264
+                       (current-field)
265
+                       (sublex)))) 
265 266
 
266 267
 (defun cmp-number (test)		;jgk inserted concatenate form
267 268
   (link-new-node (list (intern (concatenate 'string
268
-					    "T"
269
-					    (symbol-name  test)
270
-;@@@ error? reported by laird fix\	    "A"
271
-					    "N"))
272
-		       nil
273
-		       (current-field)
274
-		       (sublex)))) 
269
+                                            "T"
270
+                                            (symbol-name  test)
271
+                                            ;;@@@ error? reported by laird fix\	    "A"
272
+                                            "N"))
273
+                       nil
274
+                       (current-field)
275
+                       (sublex)))) 
275 276
 
276 277
 (defun current-field () (field-name *subnum*)) 
277 278
 
278 279
 (defun field-name (num)
279 280
   (if (< 0 num 127)
280 281
       (svref '#(nil *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9* *c10* *c11*
281
-		    *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19* *c20* *c21*
282
-		    *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29* *c30* *c31*
283
-		    *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39* *c40* *c41*
284
-		    *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49* *c50* *c51*
285
-		    *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59* *c60* *c61*
286
-		    *c62* *c63* *c64* *c65* *c66* *c67* *c68* *c69* *c70* *c71*
287
-		    *c72* *c73* *c74* *c75* *c76* *c77* *c78* *c79* *c80* *c81*
288
-		    *c82* *c83* *c84* *c85* *c86* *c87* *c88* *c89* *c90* *c91*
289
-		    *c92* *c93* *c94* *c95* *c96* *c97* *c98* *c99* *c100*
290
-		    *c101* *c102* *c103* *c104* *c105* *c106* *c107* *c108*
291
-		    *c109* *c110* *c111* *c112* *c113* *c114* *c115* *c116*
292
-		    *c117* *c118* *c119* *c120* *c121* *c122* *c123* *c124*
293
-		    *c125* *c126* *c127*)
294
-	     num)
282
+                *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19* *c20* *c21*
283
+                *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29* *c30* *c31*
284
+                *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39* *c40* *c41*
285
+                *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49* *c50* *c51*
286
+                *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59* *c60* *c61*
287
+                *c62* *c63* *c64* *c65* *c66* *c67* *c68* *c69* *c70* *c71*
288
+                *c72* *c73* *c74* *c75* *c76* *c77* *c78* *c79* *c80* *c81*
289
+                *c82* *c83* *c84* *c85* *c86* *c87* *c88* *c89* *c90* *c91*
290
+                *c92* *c93* *c94* *c95* *c96* *c97* *c98* *c99* *c100*
291
+                *c101* *c102* *c103* *c104* *c105* *c106* *c107* *c108*
292
+                *c109* *c110* *c111* *c112* *c113* *c114* *c115* *c116*
293
+                *c117* *c118* *c119* *c120* *c121* *c122* *c123* *c124*
294
+                *c125* *c126* *c127*)
295
+             num)
295 296
       (%error '|condition is too long| (rest-of-ce))))
296 297
 
297 298
 ;;; Compiling variables
298
-;
299
-;
300
-;
301
-; *cur-vars* are the variables in the condition element currently 
302
-; being compiled.  *vars* are the variables in the earlier condition
303
-; elements.  *ce-vars* are the condition element variables.  note
304
-; that the interpreter will not confuse condition element and regular
305
-; variables even if they have the same name.
306
-;
307
-; *cur-vars* is a list of triples: (name predicate subelement-number)
308
-; eg:		( (<x> eq 3)
309
-;		  (<y> ne 1)
310
-;		  . . . )
311
-;
312
-; *vars* is a list of triples: (name ce-number subelement-number)
313
-; eg:		( (<x> 3 3)
314
-;		  (<y> 1 1)
315
-;		  . . . )
316
-;
317
-; *ce-vars* is a list of pairs: (name ce-number)
318
-; eg:		( (ce1 1)
319
-;		  (<c3> 3)
320
-;		  . . . )
299
+;;
300
+;;
301
+;;
302
+;; *cur-vars* are the variables in the condition element currently 
303
+;; being compiled.  *vars* are the variables in the earlier condition
304
+;; elements.  *ce-vars* are the condition element variables.  note
305
+;; that the interpreter will not confuse condition element and regular
306
+;; variables even if they have the same name.
307
+;;
308
+;; *cur-vars* is a list of triples: (name predicate subelement-number)
309
+;; eg:		( (<x> eq 3)
310
+;;		  (<y> ne 1)
311
+;;		  . . . )
312
+;;
313
+;; *vars* is a list of triples: (name ce-number subelement-number)
314
+;; eg:		( (<x> 3 3)
315
+;;		  (<y> 1 1)
316
+;;		  . . . )
317
+;;
318
+;; *ce-vars* is a list of pairs: (name ce-number)
319
+;; eg:		( (ce1 1)
320
+;;		  (<c3> 3)
321
+;;		  . . . )
321 322
 
322 323
 ;;; used only in this file.
323 324
 (defmacro var-dope (var) `(assoc ,var *vars*))
... ...
@@ -326,47 +327,47 @@
326 327
 
327 328
 (defun cmp-var (test)
328 329
   (let* ((name (sublex))
329
-	 (old (assoc name *cur-vars*)))
330
+         (old (assoc name *cur-vars*)))
330 331
     (cond ((and old (eq (cadr old) 'eq))
331
-	   (cmp-old-eq-var test old))
332
-	  ((and old (eq test 'eq)) (cmp-new-eq-var name old))
333
-	  (t (cmp-new-var name test))))) 
332
+           (cmp-old-eq-var test old))
333
+          ((and old (eq test 'eq)) (cmp-new-eq-var name old))
334
+          (t (cmp-new-var name test))))) 
334 335
 
335 336
 (defun cmp-new-var (name test)
336 337
   (push (list name test *subnum*) 
337
-	*cur-vars*)) 
338
+        *cur-vars*)) 
338 339
 
339 340
 (defun cmp-old-eq-var (test old)	; jgk inserted concatenate form
340 341
   (link-new-node (list (intern (concatenate 'string
341
-					    "T"
342
-					    (symbol-name  test)
343
-					    "S"))
344
-		       nil
345
-		       (current-field)
346
-		       (field-name (caddr old))))) 
342
+                                            "T"
343
+                                            (symbol-name  test)
344
+                                            "S"))
345
+                       nil
346
+                       (current-field)
347
+                       (field-name (caddr old))))) 
347 348
 
348 349
 (defun cmp-new-eq-var (name old)	;jgk inserted concatenate form
349 350
   (prog (pred next)
350
-    (setq *cur-vars* (delete old *cur-vars* :test #'eq))
351
-    (setq next (assoc name *cur-vars*))
352
-    (cond (next (cmp-new-eq-var name next))
353
-	  (t (cmp-new-var name 'eq)))
354
-    (setq pred (cadr old))
355
-    (link-new-node (list (intern (concatenate 'string
356
-					      "T"
357
-					      (symbol-name  pred)
358
-					      "S"))
359
-			 nil
360
-			 (field-name (caddr old))
361
-			 (current-field))))) 
351
+     (setq *cur-vars* (delete old *cur-vars* :test #'eq))
352
+     (setq next (assoc name *cur-vars*))
353
+     (cond (next (cmp-new-eq-var name next))
354
+           (t (cmp-new-var name 'eq)))
355
+     (setq pred (cadr old))
356
+     (link-new-node (list (intern (concatenate 'string
357
+                                               "T"
358
+                                               (symbol-name  pred)
359
+                                               "S"))
360
+                          nil
361
+                          (field-name (caddr old))
362
+                          (current-field))))) 
362 363
 
363 364
 (defun cmp-cevar nil
364 365
   (let* ((name (lex))
365
-	 (old (assoc name *ce-vars*)))
366
+         (old (assoc name *ce-vars*)))
366 367
     (when old
367 368
       (%error '|condition element variable used twice| name))
368 369
     (push (list name 0.) 
369
-	  *ce-vars*))) 
370
+          *ce-vars*))) 
370 371
 
371 372
 (defun cmp-not nil (cmp-beta '&not)) 
372 373
 
... ...
@@ -376,49 +377,49 @@
376 377
 
377 378
 (defun cmp-beta (kind)
378 379
   (prog (tlist vdope vname #|vpred vpos|# old)
379
-    (setq tlist nil)
380
-    la   (and (atom *cur-vars*) (go lb))
381
-    (setq vdope (car *cur-vars*))
382
-    (setq *cur-vars* (cdr *cur-vars*))
383
-    (setq vname (car vdope))
384
-    ;;  (setq vpred (cadr vdope))    Dario - commented out (unused)
385
-    ;;  (setq vpos (caddr vdope))
386
-    (setq old (assoc vname *vars*))
387
-    (cond (old (setq tlist (add-test tlist vdope old)))
388
-	  ((not (eq kind '&not)) (promote-var vdope)))
389
-    (go la)
390
-    lb   (and kind (build-beta kind tlist))
391
-    (or (eq kind '&not) (fudge))
392
-    (setq *last-branch* *last-node*))) 
380
+     (setq tlist nil)
381
+   la   (and (atom *cur-vars*) (go lb))
382
+     (setq vdope (car *cur-vars*))
383
+     (setq *cur-vars* (cdr *cur-vars*))
384
+     (setq vname (car vdope))
385
+     ;;  (setq vpred (cadr vdope))    Dario - commented out (unused)
386
+     ;;  (setq vpos (caddr vdope))
387
+     (setq old (assoc vname *vars*))
388
+     (cond (old (setq tlist (add-test tlist vdope old)))
389
+           ((not (eq kind '&not)) (promote-var vdope)))
390
+     (go la)
391
+   lb   (and kind (build-beta kind tlist))
392
+     (or (eq kind '&not) (fudge))
393
+     (setq *last-branch* *last-node*))) 
393 394
 
394 395
 (defun add-test (list new old) ; jgk inserted concatenate form
395 396
   (prog (ttype lloc rloc)
396
-    (incf *feature-count*)
397
-    (setq ttype (intern (concatenate 'string "T"
398
-				     (symbol-name (cadr new))
399
-				     "B")))
400
-    (setq rloc (encode-singleton (caddr new)))
401
-    (setq lloc (encode-pair (cadr old) (caddr old)))
402
-    (return (cons ttype (cons lloc (cons rloc list)))))) 
397
+     (incf *feature-count*)
398
+     (setq ttype (intern (concatenate 'string "T"
399
+                                      (symbol-name (cadr new))
400
+                                      "B")))
401
+     (setq rloc (encode-singleton (caddr new)))
402
+     (setq lloc (encode-pair (cadr old) (caddr old)))
403
+     (return (cons ttype (cons lloc (cons rloc list)))))) 
403 404
 
404
-; the following two functions encode indices so that gelm can
405
-; decode them as fast as possible
405
+;; the following two functions encode indices so that gelm can
406
+;; decode them as fast as possible
406 407
 
407 408
 (defun encode-pair (a b) (+ (* 10000. (1- a)) (1- b))) 
408
-;"plus" changed to "+" by gdw
409
+;;"plus" changed to "+" by gdw
409 410
 
410 411
 (defun encode-singleton (a) (1- a)) 
411 412
 
412 413
 (defun promote-var (dope)
413 414
   (prog (vname vpred vpos new)
414
-    (setq vname (car dope))
415
-    (setq vpred (cadr dope))
416
-    (setq vpos (caddr dope))
417
-    (or (eq 'eq vpred)
418
-	(%error '|illegal predicate for first occurrence|
419
-		(list vname vpred)))
420
-    (setq new (list vname 0. vpos))
421
-    (setq *vars* (cons new *vars*)))) 
415
+     (setq vname (car dope))
416
+     (setq vpred (cadr dope))
417
+     (setq vpos (caddr dope))
418
+     (or (eq 'eq vpred)
419
+         (%error '|illegal predicate for first occurrence|
420
+                 (list vname vpred)))
421
+     (setq new (list vname 0. vpos))
422
+     (setq *vars* (cons new *vars*)))) 
422 423
 
423 424
 (defun fudge nil
424 425
   (mapc #'fudge* *vars*)
... ...
@@ -430,15 +431,15 @@
430 431
 
431 432
 (defun build-beta (type tests)
432 433
   (prog (rpred lpred lnode lef)
433
-    (link-new-node (list '&mem nil nil (protomem)))
434
-    (setq rpred *last-node*)
435
-    (cond ((eq type '&and)
436
-	   (setq lnode (list '&mem nil nil (protomem))))
437
-	  (t (setq lnode (list '&two nil nil))))
438
-    (setq lpred (link-to-branch lnode))
439
-    (cond ((eq type '&and) (setq lef lpred))
440
-	  (t (setq lef (protomem))))
441
-    (link-new-beta-node (list type nil lef rpred tests)))) 
434
+     (link-new-node (list '&mem nil nil (protomem)))
435
+     (setq rpred *last-node*)
436
+     (cond ((eq type '&and)
437
+            (setq lnode (list '&mem nil nil (protomem))))
438
+           (t (setq lnode (list '&two nil nil))))
439
+     (setq lpred (link-to-branch lnode))
440
+     (cond ((eq type '&and) (setq lef lpred))
441
+           (t (setq lef (protomem))))
442
+     (link-new-beta-node (list type nil lef rpred tests)))) 
442 443
 
443 444
 (defun protomem nil (list nil)) 
444 445
 
... ...
@@ -446,25 +447,25 @@
446 447
 
447 448
 (defun encode-dope nil
448 449
   (prog (r all z k)
449
-    (setq r nil)
450
-    (setq all *vars*)
451
-    la   (and (atom all) (return r))
452
-    (setq z (car all))
453
-    (setq all (cdr all))
454
-    (setq k (encode-pair (cadr z) (caddr z)))
455
-    (setq r (cons (car z) (cons k r)))
456
-    (go la))) 
450
+     (setq r nil)
451
+     (setq all *vars*)
452
+   la   (and (atom all) (return r))
453
+     (setq z (car all))
454
+     (setq all (cdr all))
455
+     (setq k (encode-pair (cadr z) (caddr z)))
456
+     (setq r (cons (car z) (cons k r)))
457
+     (go la))) 
457 458
 
458 459
 (defun encode-ce-dope nil
459 460
   (prog (r all z k)
460
-    (setq r nil)
461
-    (setq all *ce-vars*)
462
-    la   (and (atom all) (return r))
463
-    (setq z (car all))
464
-    (setq all (cdr all))
465
-    (setq k (cadr z))
466
-    (setq r (cons (car z) (cons k r)))
467
-    (go la))) 
461
+     (setq r nil)
462
+     (setq all *ce-vars*)
463
+   la   (and (atom all) (return r))
464
+     (setq z (car all))
465
+     (setq all (cdr all))
466
+     (setq k (cadr z))
467
+     (setq r (cons (car z) (cons k r)))
468
+     (go la))) 
468 469
 
469 470
 
470 471
 
... ...
@@ -472,7 +473,7 @@
472 473
 
473 474
 (defun link-new-node (r)
474 475
   (cond ((not (member (car r) '(&p &mem &two &and &not) :test #'equal))
475
-	 (setq *feature-count* (1+ *feature-count*))))
476
+         (setq *feature-count* (1+ *feature-count*))))
476 477
   (setq *virtual-cnt* (1+ *virtual-cnt*))
477 478
   (setq *last-node* (link-left *last-node* r))) 
478 479
 
... ...
@@ -487,22 +488,22 @@
487 488
 
488 489
 (defun link-left (pred succ)
489 490
   (prog (a r)
490
-    (setq a (left-outs pred))
491
-    (setq r (find-equiv-node succ a))
492
-    (and r (return r))
493
-    (setq *real-cnt* (1+ *real-cnt*))
494
-    (attach-left pred succ)
495
-    (return succ))) 
491
+     (setq a (left-outs pred))
492
+     (setq r (find-equiv-node succ a))
493
+     (and r (return r))
494
+     (setq *real-cnt* (1+ *real-cnt*))
495
+     (attach-left pred succ)
496
+     (return succ))) 
496 497
 
497 498
 (defun link-both (left right succ)
498 499
   (prog (a r)
499
-    (setq a (intersection (left-outs left) (right-outs right)))
500
-    (setq r (find-equiv-beta-node succ a))
501
-    (and r (return r))
502
-    (setq *real-cnt* (1+ *real-cnt*))
503
-    (attach-left left succ)
504
-    (attach-right right succ)
505
-    (return succ))) 
500
+     (setq a (intersection (left-outs left) (right-outs right)))
501
+     (setq r (find-equiv-beta-node succ a))
502
+     (and r (return r))
503
+     (setq *real-cnt* (1+ *real-cnt*))
504
+     (attach-left left succ)
505
+     (attach-right right succ)
506
+     (return succ))) 
506 507
 
507 508
 (defun attach-right (old new)
508 509
   (rplaca (cddr old) (cons new (caddr old)))) 
... ...
@@ -516,28 +517,28 @@
516 517
 
517 518
 (defun find-equiv-node (node list)
518 519
   (prog (a)
519
-    (setq a list)
520
-    l1   (cond ((atom a) (return nil))
521
-	       ((equiv node (car a)) (return (car a))))
522
-    (setq a (cdr a))
523
-    (go l1))) 
520
+     (setq a list)
521
+   l1   (cond ((atom a) (return nil))
522
+              ((equiv node (car a)) (return (car a))))
523
+     (setq a (cdr a))
524
+     (go l1))) 
524 525
 
525 526
 (defun find-equiv-beta-node (node list)
526 527
   (prog (a)
527
-    (setq a list)
528
-    l1   (cond ((atom a) (return nil))
529
-	       ((beta-equiv node (car a)) (return (car a))))
530
-    (setq a (cdr a))
531
-    (go l1))) 
528
+     (setq a list)
529
+   l1   (cond ((atom a) (return nil))
530
+              ((beta-equiv node (car a)) (return (car a))))
531
+     (setq a (cdr a))
532
+     (go l1))) 
532 533
 
533
-; do not look at the predecessor fields of beta nodes; they have to be
534
-; identical because of the way the candidate nodes were found
534
+;; do not look at the predecessor fields of beta nodes; they have to be
535
+;; identical because of the way the candidate nodes were found
535 536
 
536 537
 (defun equiv (a b)
537 538
   (and (eq (car a) (car b))
538 539
        (or (eq (car a) '&mem)
539
-	   (eq (car a) '&two)
540
-	   (equal (caddr a) (caddr b)))
540
+           (eq (car a) '&two)
541
+           (equal (caddr a) (caddr b)))
541 542
        (equal (cdddr a) (cdddr b)))) 
542 543
 
543 544
 (defun beta-equiv (a b)
... ...
@@ -545,8 +546,8 @@
545 546
        (equal (cddddr a) (cddddr b))
546 547
        (or (eq (car a) '&and) (equal (caddr a) (caddr b))))) 
547 548
 
548
-; the equivalence tests are set up to consider the contents of
549
-; node memories, so they are ready for the build action
549
+;; the equivalence tests are set up to consider the contents of
550
+;; node memories, so they are ready for the build action
550 551
 
551 552
 
552 553
 
... ...
@@ -559,25 +560,25 @@
559 560
   (if (atom x)
560 561
       (%warn '|atomic action| x)
561 562
       (let ((a (car x)))
562
-	(setq *action-type* a)
563
-	(case a
564
-	  (bind (check-bind x))
565
-	  (cbind (check-cbind x))
566
-	  (make (check-make x))
567
-	  (modify (check-modify x))
568
-	  (remove (check-remove x))
569
-	  (write (check-write x))	
570
-	  (call (check-call x))		
571
-	  (halt (check-halt x))
572
-	  (openfile (check-openfile x))
573
-	  (closefile (check-closefile x))
574
-	  (default (check-default x))
575
-	  (build (check-build x))
576
-	  (t (%warn '|undefined rhs action| a))))))
577
-
578
-
579
-;(defun chg-to-write (x)
580
-;	(setq x (cons 'write (cdr x))))
563
+        (setq *action-type* a)
564
+        (case a
565
+          (bind (check-bind x))
566
+          (cbind (check-cbind x))
567
+          (make (check-make x))
568
+          (modify (check-modify x))
569
+          (remove (check-remove x))
570
+          (write (check-write x))	
571
+          (call (check-call x))		
572
+          (halt (check-halt x))
573
+          (openfile (check-openfile x))
574
+          (closefile (check-closefile x))
575
+          (default (check-default x))
576
+          (build (check-build x))
577
+          (t (%warn '|undefined rhs action| a))))))
578
+
579
+
580
+;;(defun chg-to-write (x)
581
+;;	(setq x (cons 'write (cdr x))))
581 582
 
582 583
 (defun check-build (z)
583 584
   (when (null (cdr z))
... ...
@@ -586,24 +587,24 @@
586 587
 
587 588
 (defun check-build-collect (args)
588 589
   (prog (r)
589
-    top	(and (null args) (return nil))
590
-    (setq r (car args))
591
-    (setq args (cdr args))
592
-    (cond ((consp  r) (check-build-collect r))	;dtpr\consp gdw
593
-	  ((eq r '\\)
594
-	   (and (null args) (%warn '|nothing to evaluate| r))
595
-	   (check-rhs-value (car args))
596
-	   (setq args (cdr args))))
597
-    (go top)))
590
+   top	(and (null args) (return nil))
591
+     (setq r (car args))
592
+     (setq args (cdr args))
593
+     (cond ((consp  r) (check-build-collect r))	;dtpr\consp gdw
594
+           ((eq r '\\)
595
+            (and (null args) (%warn '|nothing to evaluate| r))
596
+            (check-rhs-value (car args))
597
+            (setq args (cdr args))))
598
+     (go top)))
598 599
 
599 600
 (defun check-remove (z) 				;@@@ kluge by gdw
600 601
   (when (null (cdr z))
601 602
     (%warn '|needs arguments| z))
602 603
   (mapc (function check-rhs-ce-var) (cdr z))) 
603 604
 
604
-;(defun check-remove (z) 					;original
605
-   ; (and (null (cdr z)) (%warn '|needs arguments| z))
606
-   ;(mapc (function check-rhs-ce-var) (cdr z))) 
605
+;;(defun check-remove (z) 					;original
606
+;; (and (null (cdr z)) (%warn '|needs arguments| z))
607
+;;(mapc (function check-rhs-ce-var) (cdr z))) 
607 608
 
608 609
 (defun check-make (z)
609 610
   (when (null (cdr z))
... ...
@@ -673,25 +674,25 @@
673 674
 
674 675
 (defun check-change& (z)
675 676
   (prog (r tab-flag)
676
-    (setq tab-flag nil)
677
-    la   (and (atom z) (return nil))
678
-    (setq r (car z))
679
-    (setq z (cdr z))
680
-    (cond ((eq r '^)
681
-	   (and tab-flag
682
-		(%warn '|no value before this tab| (car z)))
683
-	   (setq tab-flag t)
684
-	   (check-tab-index (car z))
685
-	   (setq z (cdr z)))
686
-	  ((eq r '//) (setq tab-flag nil) (setq z (cdr z)))
687
-	  (t (setq tab-flag nil) (check-rhs-value r)))
688
-    (go la))) 
677
+     (setq tab-flag nil)
678
+   la   (and (atom z) (return nil))
679
+     (setq r (car z))
680
+     (setq z (cdr z))
681
+     (cond ((eq r '^)
682
+            (and tab-flag
683
+                 (%warn '|no value before this tab| (car z)))
684
+            (setq tab-flag t)
685
+            (check-tab-index (car z))
686
+            (setq z (cdr z)))
687
+           ((eq r '//) (setq tab-flag nil) (setq z (cdr z)))
688
+           (t (setq tab-flag nil) (check-rhs-value r)))
689
+     (go la))) 
689 690
 
690 691
 (defun check-rhs-ce-var (v)
691 692
   (cond ((and (not (numberp v)) (not (ce-bound? v)))
692
-	 (%warn '|unbound element variable| v))
693
-	((and (numberp v) (or (< v 1.) (> v *ce-count*)))
694
-	 (%warn '|numeric element designator out of bounds| v)))) 
693
+         (%warn '|unbound element variable| v))
694
+        ((and (numberp v) (or (< v 1.) (> v *ce-count*)))
695
+         (%warn '|numeric element designator out of bounds| v)))) 
695 696
 
696 697
 (defun check-rhs-value (x)
697 698
   (if (consp x)				;dtpr\consp gdw 
... ...
@@ -700,7 +701,7 @@
700 701
 
701 702
 (defun check-rhs-atomic (x)
702 703
   (when (and (variablep x) 
703
-	     (not (bound? x)))
704
+             (not (bound? x)))
704 705
     (%warn '|unbound variable| x)))
705 706
 
706 707
 (defun check-rhs-function (x)
... ...
@@ -718,13 +719,13 @@
718 719
       (rjust (check-rjust x))
719 720
       (otherwise 
720 721
        (when (not (externalp a))
721
-	 (%warn '"rhs function not declared external" a))))))
722
+         (%warn '"rhs function not declared external" a))))))
722 723
 
723 724
 (defun externalp (x)
724
-  ;  (cond ((symbolp x) (gethash x *external-routine-table*)) 	;) @@@
725
-  ;ok, I'm eliminating this temporarily @@@@
725
+  ;;  (cond ((symbolp x) (gethash x *external-routine-table*)) 	;) @@@
726
+  ;;ok, I'm eliminating this temporarily @@@@
726 727
   (cond ((symbolp x) t)
727
-	(t (%warn '|not a legal function name| x) nil)))
728
+        (t (%warn '|not a legal function name| x) nil)))
728 729
 
729 730
 (defun check-litval (x) 
730 731
   (unless (= (length x) 2)
... ...
@@ -733,8 +734,8 @@
733 734
 
734 735
 (defun check-accept (x)
735 736
   (cond ((= (length x) 1) nil)
736
-	((= (length x) 2) (check-rhs-atomic (cadr x)))
737
-	(t (%warn '|too many arguments| x))))
737
+        ((= (length x) 2) (check-rhs-atomic (cadr x)))
738
+        (t (%warn '|too many arguments| x))))
738 739
 
739 740
 (defun check-acceptline (x)
740 741
   (mapc #'check-rhs-atomic (cdr x)))
... ...
@@ -769,14 +770,14 @@
769 770
 
770 771
 (defun check-arithmetic (l)
771 772
   (cond ((atom l)
772
-	 (%warn '|syntax error in arithmetic expression| l))
773
-	((atom (cdr l)) (check-term (car l)))
774
-	;; "plus" changed to "+" by gdw 
775
-	;; "quotient" added by mk, for backward compatability with the
776
-	;; old definition of //.
777
-	((not (member (cadr l) '(+ - * // \\ quotient)))	
778
-	 (%warn '|unknown operator| l))
779
-	(t (check-term (car l)) (check-arithmetic (cddr l))))) 
773
+         (%warn '|syntax error in arithmetic expression| l))
774
+        ((atom (cdr l)) (check-term (car l)))
775
+        ;; "plus" changed to "+" by gdw 
776
+        ;; "quotient" added by mk, for backward compatability with the
777
+        ;; old definition of //.
778
+        ((not (member (cadr l) '(+ - * // \\ quotient)))	
779
+         (%warn '|unknown operator| l))
780
+        (t (check-term (car l)) (check-arithmetic (cddr l))))) 
780 781
 
781 782
 (defun check-term (x)
782 783
   (if (consp x)				;dtpr\consp gdw
... ...
@@ -789,23 +790,23 @@
789 790
 (defun check-substr-index (x)
790 791
   (if (bound? x) x
791 792
       (let ((v ($litbind x)))
792
-	(cond ((not (numberp v))
793
-	       (%warn '|unbound symbol used as index in substr| x))
794
-	      ((or (< v 1.) (> v 127.))
795
-	       (%warn '|index out of bounds in tab| x)))))) 
793
+        (cond ((not (numberp v))
794
+               (%warn '|unbound symbol used as index in substr| x))
795
+              ((or (< v 1.) (> v 127.))
796
+               (%warn '|index out of bounds in tab| x)))))) 
796 797
 
797 798
 (defun check-print-control (x)
798 799
   (cond ((bound? x) x)
799
-	((or (not (numberp x)) (< x 1.) (> x 127.))
800
-	 (%warn '|illegal value for printer control| x)))) 
800
+        ((or (not (numberp x)) (< x 1.) (> x 127.))
801
+         (%warn '|illegal value for printer control| x)))) 
801 802
 
802 803
 (defun check-tab-index (x)
803 804
   (if (bound? x) x
804 805
       (let ((v ($litbind x)))
805
-	(cond ((not (numberp v))
806
-	       (%warn '|unbound symbol occurs after ^| x))
807
-	      ((or (< v 1.) (> v 127.))
808
-	       (%warn '|index out of bounds after ^| x)))))) 
806
+        (cond ((not (numberp v))
807
+               (%warn '|unbound symbol occurs after ^| x))
808
+              ((or (< v 1.) (> v 127.))
809
+               (%warn '|index out of bounds after ^| x)))))) 
809 810
 
810 811
 (defun note-variable (var)
811 812
   (push var *rhs-bound-vars*))
... ...
@@ -21,16 +21,16 @@
21 21
 (defparameter *ops-version* "19-OCT-92")
22 22
 
23 23
 (defun ops-init ()
24
-  ; Allows ^ , { , and } operators to be right next to another symbol.
24
+  ;; Allows ^ , { , and } operators to be right next to another symbol.
25 25
   (set-macro-character #\{ #'(lambda (s c)
26
-			       (declare (ignore s c))
27
-			       '\{))
26
+                               (declare (ignore s c))
27
+                               '\{))
28 28
   (set-macro-character #\} #'(lambda (s c)
29
-			       (declare (ignore s c))
30
-			       '\}))
29
+                               (declare (ignore s c))
30
+                               '\}))
31 31
   (set-macro-character #\^ #'(lambda (s c)
32
-			       (declare (ignore s c))
33
-			       '\^))
32
+                               (declare (ignore s c))
33
+                               '\^))
34 34
   (backup-init)
35 35
   (compile-init)
36 36
   (main-init)
... ...
@@ -38,7 +38,7 @@
38 38
   (io-init)
39 39
   (rhs-init)
40 40
   (format t "~&Common Lisp OPS5 interpreter, version ~A.~&"
41
-	  *ops-version*))
41
+          *ops-version*))
42 42
 
43 43
 (defun reset-ops ()
44 44
   "Clears the state of OPS to allow a new rule set to be loaded."
... ...
@@ -51,7 +51,7 @@
51 51
   (clear-ops-hash-tables)
52 52
   ;; (i-g-v)
53 53
   (setq *class-list* nil
54
-	*pcount* 0))
54
+        *pcount* 0))
55 55
 
56 56
 ;;; *EOF*
57 57
 
... ...
@@ -53,80 +53,80 @@
53 53
   (if (not *in-rhs*)
54 54
       (%warn '|cannot be called at top level| 'write)
55 55
       (prog (port max k x)
56
-	($reset)
57
-	(eval-args z)
58
-	(setq max ($parametercount))
59
-	(when (< max 1)
60
-	  (%warn '|write: nothing to print| z)
61
-	  (return nil))
62
-	(setq x ($parameter 1))
63
-	(cond ((and (symbolp x) ($ofile x)) 
64
-	       (setq port ($ofile x))
65
-	       (setq k 2))
66
-	      (t
67
-	       (setq port (default-write-file))
68
-	       (setq k 1)))
69
-	;; Analyze and output all the parameters (write) was passed.
70
-	(do* ((wrstring "")
71
-	      (x ($parameter k) ($parameter k))
72
-	      (field-width))
73
-	     ((> k max)
74
-	      (format port wrstring)
75
-	      (force-output))		; Dario Giuse - added to force output
76
-	  (incf k)
77
-	  (case x
78
-	    (|=== C R L F ===|
79
-	     (format port "~A~%" wrstring) ; Flush the previous line
80
-	     (setq wrstring ""))
81
-	    (|=== R J U S T ===|
82
-	     (setq field-width ($parameter k)) ; Number following (tabto)
83
-	     (incf k)
84
-	     (setq x (format nil "~A" ($parameter k))) ; Next field to print
85
-	     (when (<= (length x) field-width)
86
-	       ;; Right-justify field
87
-	       (append-string (format nil "~V@A" field-width x))
88
-	       (incf k)))		; Skip next field, since we printed it already
89
-	    (|=== T A B T O ===|
90
-	     (setq x ($parameter k))	; Position to tab to
91
-	     (incf k)
92
-	     (when (< x (length wrstring))
93
-	       ;; Flush line, start a new one
94
-	       (format port "~A~%" wrstring)
95
-	       (setq wrstring ""))
96
-	     (append-string (format nil "~V,1@T" (- x (length wrstring) 1))))
97
-	    (t
98
-	     (append-string (format nil "~A " x))))))))
56
+         ($reset)
57
+         (eval-args z)
58
+         (setq max ($parametercount))
59
+         (when (< max 1)
60
+           (%warn '|write: nothing to print| z)
61
+           (return nil))
62
+         (setq x ($parameter 1))
63
+         (cond ((and (symbolp x) ($ofile x)) 
64
+                (setq port ($ofile x))
65
+                (setq k 2))
66
+               (t
67
+                (setq port (default-write-file))
68
+                (setq k 1)))
69
+         ;; Analyze and output all the parameters (write) was passed.
70
+         (do* ((wrstring "")
71
+               (x ($parameter k) ($parameter k))
72
+               (field-width))
73
+              ((> k max)
74
+               (format port wrstring)
75
+               (force-output))		; Dario Giuse - added to force output
76
+           (incf k)
77
+           (case x
78
+             (|=== C R L F ===|
79
+              (format port "~A~%" wrstring) ; Flush the previous line
80
+              (setq wrstring ""))
81
+             (|=== R J U S T ===|
82
+              (setq field-width ($parameter k)) ; Number following (tabto)
83
+              (incf k)
84
+              (setq x (format nil "~A" ($parameter k))) ; Next field to print
85
+              (when (<= (length x) field-width)
86
+                ;; Right-justify field
87
+                (append-string (format nil "~V@A" field-width x))
88
+                (incf k)))		; Skip next field, since we printed it already
89
+             (|=== T A B T O ===|
90
+              (setq x ($parameter k))	; Position to tab to
91
+              (incf k)
92
+              (when (< x (length wrstring))
93
+                ;; Flush line, start a new one
94
+                (format port "~A~%" wrstring)
95
+                (setq wrstring ""))
96
+              (append-string (format nil "~V,1@T" (- x (length wrstring) 1))))
97
+             (t
98
+              (append-string (format nil "~A " x))))))))
99 99
 
100 100
 
101 101
 (defun ops-openfile (z)
102 102
   (prog (file mode id)
103
-    ($reset)
104
-    (eval-args z)
105
-    (cond ((not (equal ($parametercount) 3.))
106
-	   (%warn '|openfile: wrong number of arguments| z)
107
-	   (return nil)))
108
-    (setq id ($parameter 1))
109
-    (setq file ($parameter 2))
110
-    (setq mode ($parameter 3))
111
-    (cond ((not (symbolp id))
112
-	   (%warn '|openfile: file id must be a symbolic atom| id)
113
-	   (return nil))
114
-	  ((null id)
115
-	   (%warn '|openfile: 'nil' is reserved for the terminal| nil)
116
-	   (return nil))
117
-	  ((or ($ifile id)($ofile id))
118
-	   (%warn '|openfile: name already in use| id)
119
-	   (return nil)))
120
-;@@@	(cond ((eq mode 'in) (setf (gethash id *inputfile-table*) (infile file)))
121
-;@@@	      ((eq mode 'out) (setf (gethash id *outputfile-table*) (outfile file)))
122
-; dec 7 83 gdw added setq : is putprop needed ? )
123
-    (cond ((eq mode 'in) (setf (gethash id *inputfile-table*)
124
-			       (setq id (infile file))))
125
-	  ((eq mode 'out) (setf (gethash id *outputfile-table*)
126
-				(setq id (outfile file))))
127
-	  (t (%warn '|openfile: illegal mode| mode)
128
-	     (return nil)))
129
-    (return nil)))
103
+     ($reset)
104
+     (eval-args z)
105
+     (cond ((not (equal ($parametercount) 3.))
106
+            (%warn '|openfile: wrong number of arguments| z)
107
+            (return nil)))
108
+     (setq id ($parameter 1))
109
+     (setq file ($parameter 2))
110
+     (setq mode ($parameter 3))
111
+     (cond ((not (symbolp id))
112
+            (%warn '|openfile: file id must be a symbolic atom| id)
113
+            (return nil))
114
+           ((null id)
115
+            (%warn '|openfile: 'nil' is reserved for the terminal| nil)
116
+            (return nil))
117
+           ((or ($ifile id)($ofile id))
118
+            (%warn '|openfile: name already in use| id)
119
+            (return nil)))
120
+     ;;@@@	(cond ((eq mode 'in) (setf (gethash id *inputfile-table*) (infile file)))
121
+     ;;@@@	      ((eq mode 'out) (setf (gethash id *outputfile-table*) (outfile file)))
122
+     ;; dec 7 83 gdw added setq : is putprop needed ? )
123
+     (cond ((eq mode 'in) (setf (gethash id *inputfile-table*)
124
+                                (setq id (infile file))))
125
+           ((eq mode 'out) (setf (gethash id *outputfile-table*)
126
+                                 (setq id (outfile file))))
127
+           (t (%warn '|openfile: illegal mode| mode)
128
+              (return nil)))
129
+     (return nil)))
130 130
 
131 131
 
132 132
 (defun infile (f_name)
... ...
@@ -143,70 +143,70 @@
143 143
 (defun closefile2 (file)
144 144
   (let (port)
145 145
     (cond ((not (symbolp file))
146
-	   (%warn '|closefile: illegal file identifier| file))
147
-	  ((setq port ($ifile file))
148
-	   (close port)
149
-	   (remhash file *inputfile-table*))
150
-	  ((setq port ($ofile file))
151
-	   (close port)
152
-	   (remhash file *outputfile-table*)))
146
+           (%warn '|closefile: illegal file identifier| file))
147
+          ((setq port ($ifile file))
148
+           (close port)
149
+           (remhash file *inputfile-table*))
150
+          ((setq port ($ofile file))
151
+           (close port)
152
+           (remhash file *outputfile-table*)))
153 153
     nil))
154 154
 
155 155
 (defun ops-default (z)
156 156
   (prog (file use)
157
-    ($reset)
158
-    (eval-args z)
159
-    (cond ((not (equal ($parametercount) 2.))
160
-	   (%warn '|default: wrong number of arguments| z)
161
-	   (return nil)))
162
-    (setq file ($parameter 1))
163
-    (setq use ($parameter 2))
164
-    (cond ((not (symbolp file))
165
-	   (%warn '|default: illegal file identifier| file)
166
-	   (return nil))
167
-	  ((not (member use '(write accept trace) :test #'equal))
168
-	   (%warn '|default: illegal use for a file| use)
169
-	   (return nil))
170
-	  ((and (member use '(write trace) :test #'equal)
171
-		(not (null file))
172
-		(not ($ofile file)))
173
-	   (%warn '|default: file has not been opened for output| file)
174
-	   (return nil))
175
-	  ((and (equal use 'accept) 
176
-		(not (null file))
177
-		(not ($ifile file)))
178
-	   (%warn '|default: file has not been opened for input| file)
179
-	   (return nil))
180
-	  ((equal use 'write) (setq *write-file* file))
181
-	  ((equal use 'accept) (setq *accept-file* file))
182
-	  ((equal use 'trace) (setq *trace-file* file)))
183
-    (return nil)))
157
+     ($reset)
158
+     (eval-args z)
159
+     (cond ((not (equal ($parametercount) 2.))
160
+            (%warn '|default: wrong number of arguments| z)
161
+            (return nil)))
162
+     (setq file ($parameter 1))
163
+     (setq use ($parameter 2))
164
+     (cond ((not (symbolp file))
165
+            (%warn '|default: illegal file identifier| file)
166
+            (return nil))
167
+           ((not (member use '(write accept trace) :test #'equal))
168
+            (%warn '|default: illegal use for a file| use)
169
+            (return nil))
170
+           ((and (member use '(write trace) :test #'equal)
171
+                 (not (null file))
172
+                 (not ($ofile file)))
173
+            (%warn '|default: file has not been opened for output| file)
174
+            (return nil))
175
+           ((and (equal use 'accept) 
176
+                 (not (null file))
177
+                 (not ($ifile file)))
178
+            (%warn '|default: file has not been opened for input| file)
179
+            (return nil))
180
+           ((equal use 'write) (setq *write-file* file))
181
+           ((equal use 'accept) (setq *accept-file* file))
182
+           ((equal use 'trace) (setq *trace-file* file)))
183
+     (return nil)))
184 184
 
185 185
 
186 186
 (defun ops-accept (z)
187 187
   (prog (port arg)
188
-    (cond ((> (length z) 1.)
189
-	   (%warn '|accept: wrong number of arguments| z)
190
-	   (return nil)))
191
-    (setq port *standard-input*)
192
-    (cond (*accept-file*
193
-	   (setq port ($ifile *accept-file*))
194
-	   (cond ((null port) 
195
-		  (%warn '|accept: file has been closed| *accept-file*)
196
-		  (return nil)))))
197
-    (cond ((= (length z) 1)
198
-	   (setq arg ($varbind (car z)))
199
-	   (cond ((not (symbolp arg))
200
-		  (%warn '|accept: illegal file name| arg)
201
-		  (return nil)))
202
-	   (setq port ($ifile arg))
203
-	   (cond ((null port) 
204
-		  (%warn '|accept: file not open for input| arg)
205
-		  (return nil)))))
206
-    (cond ((equal (peek-char t port nil "eof" ) "eof" )
207
-	   ($value 'end-of-file)
208
-	   (return nil)))
209
-    (flat-value (read port)))) 
188
+     (cond ((> (length z) 1.)
189
+            (%warn '|accept: wrong number of arguments| z)
190
+            (return nil)))
191
+     (setq port *standard-input*)
192
+     (cond (*accept-file*
193
+            (setq port ($ifile *accept-file*))
194
+            (cond ((null port) 
195
+                   (%warn '|accept: file has been closed| *accept-file*)
196
+                   (return nil)))))
197
+     (cond ((= (length z) 1)
198
+            (setq arg ($varbind (car z)))
199
+            (cond ((not (symbolp arg))
200
+                   (%warn '|accept: illegal file name| arg)
201
+                   (return nil)))
202
+            (setq port ($ifile arg))
203
+            (cond ((null port) 
204
+                   (%warn '|accept: file not open for input| arg)
205
+                   (return nil)))))
206
+     (cond ((equal (peek-char t port nil "eof" ) "eof" )
207
+            ($value 'end-of-file)
208
+            (return nil)))
209
+     (flat-value (read port)))) 
210 210
 
211 211
 
212 212
 
... ...
@@ -215,97 +215,97 @@
215 215
 ;;;
216 216
 (defun ops-acceptline (z)
217 217
   (let ((port *standard-input*)
218
-	(def z))
218
+        (def z))
219 219
     (cond (*accept-file*
220
-	   (setq port ($ifile *accept-file*))
221
-	   (cond ((null port) 
222
-		  (%warn '|acceptline: file has been closed| 
223
-			 *accept-file*)
224
-		  (return-from ops-acceptline nil)))))
220
+           (setq port ($ifile *accept-file*))
221
+           (cond ((null port) 
222
+                  (%warn '|acceptline: file has been closed| 
223
+                         *accept-file*)
224
+                  (return-from ops-acceptline nil)))))
225 225
     (cond ((> (length def) 0)
226
-	   (let ((arg ($varbind (car def))))
227
-	     (cond ((and (symbolp arg) ($ifile arg))
228
-		    (setq port ($ifile arg))
229
-		    (setq def (cdr def)))))))
226
+           (let ((arg ($varbind (car def))))
227
+             (cond ((and (symbolp arg) ($ifile arg))
228
+                    (setq port ($ifile arg))
229
+                    (setq def (cdr def)))))))
230 230
     (let ((line (read-line port nil 'eof)))
231 231
       (declare (simple-string line))
232 232
       ;; Strip meaningless characters from start and end of string.
233 233
       (setq line (string-trim '(#\( #\) #\, #\tab #\space) line))
234 234
       (when (equal line "")
235
-	(mapc (function $change) def)
236
-	(return-from ops-acceptline nil))
235
+        (mapc (function $change) def)
236
+        (return-from ops-acceptline nil))
237 237
       (setq line (concatenate 'simple-string "(" line ")"))
238 238
       ;; Read all items from the line
239 239
       (flat-value (read-from-string line)))))
240 240
 
241 241
 (defun ops-rjust (z)
242 242
   (prog (val)
243
-    (when (not (= (length z) 1.))
244
-      (%warn '|rjust: wrong number of arguments| z)
245
-      (return nil))
246
-    (setq val ($varbind (car z)))
247
-    (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
248
-	   (%warn '|rjust: illegal value for field width| val)
249
-	   (return nil)))
250
-    ($value '|=== R J U S T ===|)
251
-    ($value val)))
243
+     (when (not (= (length z) 1.))
244
+       (%warn '|rjust: wrong number of arguments| z)
245
+       (return nil))
246
+     (setq val ($varbind (car z)))
247
+     (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
248
+            (%warn '|rjust: illegal value for field width| val)
249
+            (return nil)))
250
+     ($value '|=== R J U S T ===|)
251
+     ($value val)))
252 252
 
253 253
 
254 254
 (defun ops-crlf (z)
255 255
   (cond  (z (%warn '|crlf: does not take arguments| z))
256
-	 (t ($value '|=== C R L F ===|))))
256
+         (t ($value '|=== C R L F ===|))))
257 257
 
258 258
 
259 259
 (defun ops-tabto (z)
260 260
   (prog (val)
261
-    (when (not (= (length z) 1.))
262
-      (%warn '|tabto: wrong number of arguments| z)
263
-      (return nil))
264
-    (setq val ($varbind (car z)))
265
-    (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
266
-	   (%warn '|tabto: illegal column number| z)
267
-	   (return nil)))
268
-    ($value '|=== T A B T O ===|)
269
-    ($value val)))
261
+     (when (not (= (length z) 1.))
262
+       (%warn '|tabto: wrong number of arguments| z)
263
+       (return nil))
264
+     (setq val ($varbind (car z)))
265
+     (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
266
+            (%warn '|tabto: illegal column number| z)
267
+            (return nil)))
268
+     ($value '|=== T A B T O ===|)
269
+     ($value val)))
270 270
 
271 271
 (defun do-rjust (width value port)
272 272
   (prog (size)
273
-    (cond ((eq value '|=== T A B T O ===|)
274
-	   (%warn '|rjust cannot precede this function| 'tabto)
275
-	   (return nil))
276
-	  ((eq value '|=== C R L F ===|)
277
-	   (%warn '|rjust cannot precede this function| 'crlf)
278
-	   (return nil))
279
-	  ((eq value '|=== R J U S T ===|)
280
-	   (%warn '|rjust cannot precede this function| 'rjust)
281
-	   (return nil)))
282
-    ;original->        (setq size (flatc value (1+ width)))
283
-    (setq size (min value (1+ width)))  ;### KLUGE
284
-    (cond ((> size width)
285
-	   (princ '| | port)
286
-	   (princ value port)
287
-	   (return nil)))
288
-    ;###        (do k (- width size) (1- k) (not (> k 0)) (princ '| | port))
289
-    ;^^^KLUGE @@@do
290
-    (princ value port)))
273
+     (cond ((eq value '|=== T A B T O ===|)
274
+            (%warn '|rjust cannot precede this function| 'tabto)
275
+            (return nil))
276
+           ((eq value '|=== C R L F ===|)
277
+            (%warn '|rjust cannot precede this function| 'crlf)
278
+            (return nil))
279
+           ((eq value '|=== R J U S T ===|)
280
+            (%warn '|rjust cannot precede this function| 'rjust)
281
+            (return nil)))
282
+     ;;original->        (setq size (flatc value (1+ width)))
283
+     (setq size (min value (1+ width)))  ;### KLUGE
284
+     (cond ((> size width)
285
+            (princ '| | port)
286
+            (princ value port)
287
+            (return nil)))
288
+     ;;###        (do k (- width size) (1- k) (not (> k 0)) (princ '| | port))
289
+     ;;^^^KLUGE @@@do
290
+     (princ value port)))
291 291
 
292 292
 (defun do-tabto (col port)
293 293
   (prog (pos)
294
-    ;### KLUGE: FLUSHES STREAM & SETS POS TO 0
295
-    ;OIRGINAL->	(setq pos (1+ (nwritn port)))	;hmm-takes 1 arg @@@ port
296
-    (finish-output port);kluge
297
-    (setq pos 0);kluge
298
-    (cond ((> pos col)
299
-	   (terpri port)
300