Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Path: utzoo!mnetor!seismo!rutgers!sri-unix!hplabs!decwrl!sun!imagen!turner
From: turner@imagen.UUCP (D'arc Angel)
Newsgroups: comp.ai
Subject: AI expert sources (part 8 of 9)
Message-ID: <801@imagen.UUCP>
Date: Sun, 18-Jan-87 22:50:32 EST
Article-I.D.: imagen.801
Posted: Sun Jan 18 22:50:32 1987
Date-Received: Mon, 19-Jan-87 21:39:02 EST
Organization: The Houses of the Holy
Lines: 1506
Keywords: ai,sources


	X        (setq tlist (cdr tlist))
	X        (setq lind (car tlist))
	X        (setq tlist (cdr tlist))
	X        (setq rind (car tlist))
	X        (setq tlist (cdr tlist))
	X        (comment the next line differs in not-left & -right)
	X        (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
	X        (cond (res (go tloop))
	X              (t (setq mem (cddr mem)) (go fail)))
	X   succ (setq newc (+ inc newc))
	X        (rplaca (cdr mem) newc)
	X        (cond ((or (and (== inc -1.) (== newc 0.))
	X                   (and (== inc 1.) (== newc 1.)))
	X               (sendto newfp memdp 'right outs)))
	X        (setq mem (cddr mem))
	X        (go fail))) 
	X
	X
	X
	X;;; Node memories
	X
	X
	X(defun add-token (memlis flag data-part num)
	X  (prog (was-present)
	X        (cond ((eq flag 'new)
	X               (setq was-present nil)
	X               (real-add-token memlis data-part num))
	X              ((not flag) 
	X	       (setq was-present (remove-old memlis data-part num)))
	X              ((eq flag 'old) (setq was-present t)))
	X        (return was-present))) 
	X
	X(defun real-add-token (lis data-part num)
	X  (setq *current-token* (1+ *current-token*))
	X  (cond (num (rplaca lis (cons num (car lis)))))
	X  (rplaca lis (cons data-part (car lis)))) 
	X
	X(defun remove-old (lis data num)
	X  (cond (num (remove-old-num lis data))
	X        (t (remove-old-no-num lis data)))) 
	X
	X(defun remove-old-num (lis data)
	X  (prog (m next last)
	X        (setq m (car lis))
	X        (cond ((atom m) (return nil))
	X              ((top-levels-eq data (car m))
	X               (setq *current-token* (1- *current-token*))
	X               (rplaca lis (cddr m))
	X               (return (car m))))
	X        (setq next m)
	X   loop (setq last next)
	X        (setq next (cddr next))
	X        (cond ((atom next) (return nil))
	X              ((top-levels-eq data (car next))
	X               (rplacd (cdr last) (cddr next))
	X               (setq *current-token* (1- *current-token*))
	X               (return (car next)))
	X              (t (go loop))))) 
	X
	X(defun remove-old-no-num (lis data)
	X  (prog (m next last)
	X        (setq m (car lis))
	X        (cond ((atom m) (return nil))
	X              ((top-levels-eq data (car m))
	X               (setq *current-token* (1- *current-token*))
	X               (rplaca lis (cdr m))
	X               (return (car m))))
	X        (setq next m)
	X   loop (setq last next)
	X        (setq next (cdr next))
	X        (cond ((atom next) (return nil))
	X              ((top-levels-eq data (car next))
	X               (rplacd last (cdr next))
	X               (setq *current-token* (1- *current-token*))
	X               (return (car next)))
	X              (t (go loop))))) 
	X
	X
	X
	X;;; Conflict Resolution
	X;
	X;
	X; each conflict set element is a list of the following form:
	X; ((p-name . data-part) (sorted wm-recency) special-case-number)
	X
	X(defun removecs (name data)
	X  (prog (cr-data inst cs)
	X        (setq cr-data (cons name data))
	X	(setq cs *conflict-set*)
	X loop1	(cond ((null cs) 
	X               (record-refract name data)
	X               (return nil)))
	X	(setq inst (car cs))
	X	(setq cs (cdr cs))
	X	(and (not (top-levels-eq (car inst) cr-data)) (go loop1))
	X        (setq *conflict-set* (delq inst *conflict-set*))))
	X
	X(defun insertcs (name data rating)
	X  (prog (instan)
	X    (and (refracted name data) (return nil))
	X    (setq instan (list (cons name data) (order-tags data) rating))
	X    (and (atom *conflict-set*) (setq *conflict-set* nil))
	X    (return (setq *conflict-set* (cons instan *conflict-set*))))) 
	X
	X(defun order-tags (dat)
	X  (prog (tags)
	X        (setq tags nil)
	X   l1  (and (atom dat) (go l2))
	X        (setq tags (cons (creation-time (car dat)) tags))
	X        (setq dat (cdr dat))
	X        (go l1)
	X   l2  (cond ((eq *strategy* 'mea)
	X               (return (cons (car tags) (dsort (cdr tags)))))
	X              (t (return (dsort tags)))))) 
	X
	X; destructively sort x into descending order
	X
	X(defun dsort (x)
	X  (prog (sorted cur next cval nval)
	X        (and (atom (cdr x)) (return x))
	X   loop (setq sorted t)
	X        (setq cur x)
	X        (setq next (cdr x))
	X   chek (setq cval (car cur))
	X        (setq nval (car next))
	X        (cond ((> nval cval)
	X               (setq sorted nil)
	X               (rplaca cur nval)
	X               (rplaca next cval)))
	X        (setq cur next)
	X        (setq next (cdr cur))
	X        (cond ((not (null next)) (go chek))
	X              (sorted (return x))
	X              (t (go loop))))) 
	X
	X(defun conflict-resolution nil
	X  (prog (best len)
	X        (setq len (length *conflict-set*))
	X        (cond ((> len *max-cs*) (setq *max-cs* len)))
	X        (setq *total-cs* (+ *total-cs* len))
	X        (cond (*conflict-set*
	X               (setq best (best-of *conflict-set*))
	X               (setq *conflict-set* (delq best *conflict-set*))
	X               (return (pname-instantiation best)))
	X              (t (return nil))))) 
	X
	X(defun best-of (set) (best-of* (car set) (cdr set))) 
	X
	X(defun best-of* (best rem)
	X  (cond ((not rem) best)
	X        ((conflict-set-compare best (car rem))
	X         (best-of* best (cdr rem)))
	X        (t (best-of* (car rem) (cdr rem))))) 
	X
	X(defun remove-from-conflict-set (name)
	X  (prog (cs entry)
	X   l1   (setq cs *conflict-set*)
	X   l2   (cond ((atom cs) (return nil)))
	X        (setq entry (car cs))
	X        (setq cs (cdr cs))
	X        (cond ((eq name (caar entry))
	X               (setq *conflict-set* (delq entry *conflict-set*))
	X               (go l1))
	X              (t (go l2))))) 
	X
	X(defun pname-instantiation (conflict-elem) (car conflict-elem)) 
	X
	X(defun order-part (conflict-elem) (cdr conflict-elem)) 
	X
	X(defun instantiation (conflict-elem)
	X  (cdr (pname-instantiation conflict-elem))) 
	X
	X
	X(defun conflict-set-compare (x y)
	X  (prog (x-order y-order xl yl xv yv)
	X        (setq x-order (order-part x))
	X        (setq y-order (order-part y))
	X        (setq xl (car x-order))
	X        (setq yl (car y-order))
	X   data (cond ((and (null xl) (null yl)) (go ps))
	X              ((null yl) (return t))
	X              ((null xl) (return nil)))
	X        (setq xv (car xl))
	X        (setq yv (car yl))
	X        (cond ((> xv yv) (return t))
	X              ((> yv xv) (return nil)))
	X        (setq xl (cdr xl))
	X        (setq yl (cdr yl))
	X        (go data)
	X   ps   (setq xl (cdr x-order))
	X        (setq yl (cdr y-order))
	X   psl  (cond ((null xl) (return t)))
	X        (setq xv (car xl))
	X        (setq yv (car yl))
	X        (cond ((> xv yv) (return t))
	X              ((> yv xv) (return nil)))
	X        (setq xl (cdr xl))
	X        (setq yl (cdr yl))
	X        (go psl))) 
	X
	X
	X(defun conflict-set nil
	X  (prog (cnts cs p z best)
	X        (setq cnts nil)
	X        (setq cs *conflict-set*)
	X   l1  (and (atom cs) (go l2))
	X        (setq p (caaar cs))
	X        (setq cs (cdr cs))
	X        (setq z (assq p cnts))
	X        (cond ((null z) (setq cnts (cons (cons p 1.) cnts)))
	X              (t (rplacd z (1+ (cdr z)))))
	X        (go l1)
	X   l2  (cond ((atom cnts)
	X               (setq best (best-of *conflict-set*))
	X               (terpri)
	X               (return (list (caar best) 'dominates))))
	X        (terpri)
	X        (princ (caar cnts))
	X        (cond ((> (cdar cnts) 1.)
	X               (princ '|	(|)
	X               (princ (cdar cnts))
	X               (princ '| occurrences)|)))
	X        (setq cnts (cdr cnts))
	X        (go l2))) 
	X	
	X
	X
	X;;; WM maintaining functions
	X;
	X; The order of operations in the following two functions is critical.
	X; add-to-wm order: (1) change wm (2) record change (3) match 
	X; remove-from-wm order: (1) record change (2) match (3) change wm
	X; (back will not restore state properly unless wm changes are recorded
	X; before the cs changes that they cause)  (match will give errors if 
	X; the thing matched is not in wm at the time)
	X
	X
	X(defun add-to-wm (wme override)
	X  (prog (fa z part timetag port)
	X    (setq *critical* t)
	X    (setq *current-wm* (1+ *current-wm*))
	X    (and (> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))
	X    (setq *action-count* (1+ *action-count*))
	X    (setq fa (wm-hash wme))
	X    (or (memq fa *wmpart-list*)
	X        (setq *wmpart-list* (cons fa *wmpart-list*)))
	X    (setq part (get fa 'wmpart*))
	X    (cond (override (setq timetag override))
	X          (t (setq timetag *action-count*)))
	X    (setq z (cons wme timetag))
	X    (putprop fa (cons z part) 'wmpart*)
	X    (record-change '=>wm *action-count* wme)
	X    (match 'new wme)
	X    (setq *critical* nil)
	X    (cond ((and *in-rhs* *wtrace*)
	X           (setq port (trace-file))
	X           (terpri port)
	X           (princ '|=>wm: | port)
	X           (ppelm wme port)))
	X    (and *in-rhs* *mtrace* (setq *madeby* 
	X                                 (cons (cons wme *p-name*) *madeby*))))) 
	X
	X; remove-from-wm uses eq, not equal to determine if wme is present
	X
	X(defun remove-from-wm (wme)
	X  (prog (fa z part timetag port)
	X    (setq fa (wm-hash wme))
	X    (setq part (get fa 'wmpart*))
	X    (setq z (assq wme part))
	X    (or z (return nil))
	X    (setq timetag (cdr z))
	X    (cond ((and *wtrace* *in-rhs*)
	X           (setq port (trace-file))
	X           (terpri port)
	X           (princ '|<=wm: | port)
	X           (ppelm wme port)))
	X    (setq *action-count* (1+ *action-count*))
	X    (setq *critical* t)
	X    (setq *current-wm* (1- *current-wm*))
	X    (record-change '<=wm timetag wme)
	X    (match nil wme)
	X    (putprop fa (delq z part) 'wmpart* )
	X    (setq *critical* nil))) 
	X
	X; mapwm maps down the elements of wm, applying fn to each element
	X; each element is of form (datum . creation-time)
	X
	X(defun mapwm (fn)
	X  (prog (wmpl part)
	X        (setq wmpl *wmpart-list*)
	X   lab1 (cond ((atom wmpl) (return nil)))
	X        (setq part (get (car wmpl) 'wmpart*))
	X        (setq wmpl (cdr wmpl))
	X        (mapc fn part)
	X        (go lab1))) 
	X
	X(defun wm (&quote &rest a) 
	X  (mapc (function (lambda (z) (terpri) (ppelm z t))) 
	X	(get-wm a))
	X  nil) 
	X
	X(defun get-wm (z)
	X  (setq *wm-filter* z)
	X  (setq *wm* nil)
	X  (mapwm (function get-wm2))
	X  (prog2 nil *wm* (setq *wm* nil))) 
	X
	X(defun get-wm2 (elem) 
	X (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*))
	X	(setq *wm* (cons (car elem) *wm*)))))
	X
	X(defun wm-hash (x)
	X  (cond ((not x) '<default>)
	X        ((not (car x)) (wm-hash (cdr x)))
	X        ((symbolp (car x)) (car x))
	X        (t (wm-hash (cdr x))))) 
	X
	X(defun creation-time (wme)
	X  (cdr (assq wme (get (wm-hash wme) 'wmpart*)))) 
	X
	X(defun rehearse nil
	X  (prog nil
	X    (setq *old-wm* nil)
	X    (mapwm (function refresh-collect))
	X    (mapc (function refresh-del) *old-wm*)
	X    (mapc (function refresh-add) *old-wm*)
	X    (setq *old-wm* nil))) 
	X
	X(defun refresh-collect (x) (setq *old-wm* (cons x *old-wm*))) 
	X
	X(defun refresh-del (x) (remove-from-wm (car x))) 
	X
	X(defun refresh-add (x) (add-to-wm (car x) (cdr x))) 
	X
	X(defun trace-file ()
	X  (prog (port)
	X        (setq port t)
	X	(cond (*trace-file*
	X	       (setq port ($ofile *trace-file*))
	X	       (cond ((null port)
	X	              (%warn '|trace: file has been closed| *trace-file*)
	X		      (setq port t)))))
	X        (return port)))
	X
	X
	X;;; Basic functions for RHS evaluation
	X
	X(defun eval-rhs (pname data)
	X  (prog (node port)
	X    (cond (*ptrace*
	X           (setq port (trace-file))
	X           (terpri port)
	X           (princ *cycle-count* port)
	X           (princ '|. | port)
	X           (princ pname port)
	X           (time-tag-print data port)))
	X    (setq *data-matched* data)
	X    (setq *p-name* pname)
	X    (setq *last* nil)
	X    (setq node (get pname 'topnode))
	X    (init-var-mem (var-part node))
	X    (init-ce-var-mem (ce-var-part node))
	X    (begin-record pname data)
	X    (setq *in-rhs* t)
	X    (eval (rhs-part node))
	X    (setq *in-rhs* nil)
	X    (end-record))) 
	X
	X(defun time-tag-print (data port)
	X  (cond ((not (null data))
	X         (time-tag-print (cdr data) port)
	X         (princ '| | port)
	X         (princ (creation-time (car data)) port))))
	X
	X(defun init-var-mem (vlist)
	X  (prog (v ind r)
	X        (setq *variable-memory* nil)
	X   top  (and (atom vlist) (return nil))
	X        (setq v (car vlist))
	X        (setq ind (cadr vlist))
	X        (setq vlist (cddr vlist))
	X        (setq r (gelm *data-matched* ind))
	X        (setq *variable-memory* (cons (cons v r) *variable-memory*))
	X        (go top))) 
	X
	X(defun init-ce-var-mem (vlist)
	X  (prog (v ind r)
	X        (setq *ce-variable-memory* nil)
	X   top  (and (atom vlist) (return nil))
	X        (setq v (car vlist))
	X        (setq ind (cadr vlist))
	X        (setq vlist (cddr vlist))
	X        (setq r (ce-gelm *data-matched* ind))
	X        (setq *ce-variable-memory*
	X              (cons (cons v r) *ce-variable-memory*))
	X        (go top))) 
	X
	X(defun make-ce-var-bind (var elem)
	X  (setq *ce-variable-memory*
	X        (cons (cons var elem) *ce-variable-memory*))) 
	X
	X(defun make-var-bind (var elem)
	X  (setq *variable-memory* (cons (cons var elem) *variable-memory*))) 
	X
	X(defun $varbind (x)
	X  (prog (r)
	X	(and (not *in-rhs*) (return x))
	X        (setq r (assq x *variable-memory*))
	X        (cond (r (return (cdr r)))
	X              (t (return x))))) 
	X
	X(defun get-ce-var-bind (x)
	X  (prog (r)
	X        (cond ((numberp x) (return (get-num-ce x))))
	X        (setq r (assq x *ce-variable-memory*))
	X        (cond (r (return (cdr r)))
	X              (t (return nil))))) 
	X
	X(defun get-num-ce (x)
	X  (prog (r l d)
	X        (setq r *data-matched*)
	X        (setq l (length r))
	X        (setq d (- l x))
	X        (and (> 0. d) (return nil))
	X   la   (cond ((null r) (return nil))
	X              ((> 1. d) (return (car r))))
	X        (setq d (1- d))
	X        (setq r (cdr r))
	X        (go la))) 
	X
	X
	X(defun build-collect (z)
	X  (prog (r)
	X   la   (and (atom z) (return nil))
	X        (setq r (car z))
	X        (setq z (cdr z))
	X        (cond ((and r (listp r))
	X               ($value '\()
	X               (build-collect r)
	X               ($value '\)))
	X              ((eq r '\\) ($change (car z)) (setq z (cdr z)))
	X              (t ($value r)))
	X        (go la))) 
	X
	X(defun unflat (x) (setq *rest* x) (unflat*)) 
	X
	X(defun unflat* nil
	X  (prog (c)
	X        (cond ((atom *rest*) (return nil)))
	X        (setq c (car *rest*))
	X        (setq *rest* (cdr *rest*))
	X        (cond ((eq c '\() (return (cons (unflat*) (unflat*))))
	X              ((eq c '\)) (return nil))
	X              (t (return (cons c (unflat*))))))) 
	X
	X
	X(defun $change (x)
	X  (prog nil
	X        (cond ((and x (listp x)) (eval-function x)) ;modified to check for nil
	X              (t ($value ($varbind x)))))) 
	X
	X(defun eval-args (z)
	X  (prog (r)
	X        (rhs-tab 1.)
	X   la   (and (atom z) (return nil))
	X        (setq r (car z))
	X        (setq z (cdr z))
	X        (cond ((eq r #\^)
	X               (rhs-tab (car z))
	X               (setq r (cadr z))
	X               (setq z (cddr z))))
	X        (cond ((eq r '//) ($value (car z)) (setq z (cdr z)))
	X              (t ($change r)))
	X        (go la))) 
	X
	X
	X(defun eval-function (form)
	X  (cond ((not *in-rhs*)
	X	 (%warn '|functions cannot be used at top level| (car form)))
	X	(t (eval form))))
	X
	X
	X;;; Functions to manipulate the result array
	X
	X
	X(defun $reset nil
	X  (setq *max-index* 0)
	X  (setq *next-index* 1)) 
	X
	X; rhs-tab implements the tab ('^') function in the rhs.  it has
	X; four responsibilities:
	X;	- to move the array pointers
	X;	- to watch for tabbing off the left end of the array
	X;	  (ie, to watch for pointers less than 1)
	X;	- to watch for tabbing off the right end of the array
	X;	- to write nil in all the slots that are skipped
	X; the last is necessary if the result array is not to be cleared
	X; after each use; if rhs-tab did not do this, $reset
	X; would be much slower.
	X
	X(defun rhs-tab (z) ($tab ($varbind z)))
	X
	X(defun $tab (z)
	X  (prog (edge next)
	X        (setq next ($litbind z))
	X        (and (floatp next) (setq next (fix next)))
	X        (cond ((or (not (numberp next)) 
	X		   (> next *size-result-array*)
	X		   (> 1. next))
	X               (%warn '|illegal index after ^| next)
	X               (return *next-index*)))
	X        (setq edge (- next 1.))
	X        (cond ((> *max-index* edge) (go ok)))
	X   clear (cond ((== *max-index* edge) (go ok)))
	X        (putvector *result-array* edge nil)
	X        (setq edge (1- edge))
	X        (go clear)
	X   ok   (setq *next-index* next)
	X        (return next))) 
	X
	X(defun $value (v)
	X  (cond ((> *next-index* *size-result-array*)
	X         (%warn '|index too large| *next-index*))
	X        (t
	X         (and (> *next-index* *max-index*)
	X              (setq *max-index* *next-index*))
	X         (putvector *result-array* *next-index* v)
	X         (setq *next-index* (1+ *next-index*))))) 
	X
	X(defun use-result-array nil
	X  (prog (k r)
	X        (setq k *max-index*)
	X        (setq r nil)
	X   top  (and (== k 0.) (return r))
	X        (setq r (cons (getvector *result-array* k) r))
	X        (setq k (1- k))
	X        (go top))) 
	X
	X(defun $assert nil
	X  (setq *last* (use-result-array))
	X  (add-to-wm *last* nil))
	X
	X(defun $parametercount nil *max-index*)
	X
	X(defun $parameter (k)
	X  (cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.))
	X	 (%warn '|illegal parameter number | k)
	X         nil)
	X        ((> k *max-index*) nil)
	X	(t (getvector *result-array* k))))
	X
	X
	X;;; RHS actions
	X
	X(defun make (&quote &rest z)
	X  (prog nil
	X        ($reset)
	X        (eval-args z)
	X        ($assert))) 
	X
	X(defun modify (&quote &rest z)
	X  (prog (old)
	X	(cond ((not *in-rhs*)
	X	       (%warn '|cannot be called at top level| 'modify)
	X	       (return nil)))
	X        (setq old (get-ce-var-bind (car z)))
	X        (cond ((null old)
	X               (%warn '|modify: first argument must be an element variable|
	X                        (car z))
	X               (return nil)))
	X        (remove-from-wm old)
	X        (setq z (cdr z))
	X        ($reset)
	X   copy (and (atom old) (go fin))
	X        ($change (car old))
	X        (setq old (cdr old))
	X        (go copy)
	X   fin  (eval-args z)
	X        ($assert))) 
	X
	X(defun bind (&quote &rest z)
	X  (prog (val)
	X	(cond ((not *in-rhs*)
	X	       (%warn '|cannot be called at top level| 'bind)
	X	       (return nil)))
	X    (cond ((< (length z) 1.)
	X           (%warn '|bind: wrong number of arguments to| z)
	X           (return nil))
	X          ((not (symbolp (car z)))
	X           (%warn '|bind: illegal argument| (car z))
	X           (return nil))
	X          ((= (length z) 1.) (setq val (gensym)))
	X          (t ($reset)
	X             (eval-args (cdr z))
	X             (setq val ($parameter 1.))))
	X    (make-var-bind (car z) val))) 
	X
	X(defun cbind (&quote &rest z)
	X  (cond ((not *in-rhs*)
	X	 (%warn '|cannot be called at top level| 'cbind))
	X	((not (= (length z) 1.))
	X	 (%warn '|cbind: wrong number of arguments| z))
	X	((not (symbolp (car z)))
	X	 (%warn '|cbind: illegal argument| (car z)))
	X	((null *last*)
	X	 (%warn '|cbind: nothing added yet| (car z)))
	X	(t (make-ce-var-bind (car z) *last*)))) 
	X
	X(defun oremove (&quote &rest z)
	X  (prog (old)
	X	(and (not *in-rhs*)(return (top-level-remove z)))
	X   top  (and (atom z) (return nil))
	X        (setq old (get-ce-var-bind (car z)))
	X        (cond ((null old)
	X               (%warn '|remove: argument not an element variable| (car z))
	X               (return nil)))
	X        (remove-from-wm old)
	X        (setq z (cdr z))
	X        (go top))) 
	X
	X(defun ocall (&quote &rest z)
	X  (prog (f)
	X	(setq f (car z))
	X        ($reset)
	X        (eval-args (cdr z))
	X        (funcall f))) 
	X
	X(defun owrite (&quote &rest z)
	X  (prog (port max k x needspace)
	X	(cond ((not *in-rhs*)
	X	       (%warn '|cannot be called at top level| 'write)
	X	       (return nil)))
	X	($reset)
	X	(eval-args z)
	X	(setq k 1.)
	X	(setq max ($parametercount))
	X	(cond ((< max 1.)
	X	       (%warn '|write: nothing to print| z)
	X	       (return nil)))
	X	(setq port (default-write-file))
	X	(setq x ($parameter 1.))
	X	(cond ((and (symbolp x) ($ofile x)) 
	X	       (setq port ($ofile x))
	X	       (setq k 2.)))
	X        (setq needspace t)
	X   la   (and (> k max) (return nil))
	X	(setq x ($parameter k))
	X	(cond ((eq x '|=== C R L F ===|)
	X	       (setq needspace nil)
	X               (terpri port))
	X              ((eq x '|=== R J U S T ===|)
	X	       (setq k (+ 2 k))
	X	       (do-rjust ($parameter (1- k)) ($parameter k) port))
	X	      ((eq x '|=== T A B T O ===|)
	X	       (setq needspace nil)
	X	       (setq k (1+ k))
	X	       (do-tabto ($parameter k) port))
	X	      (t 
	X	       (and needspace (princ '| | port))
	X	       (setq needspace t)
	X	       (princ x port)))
	X	(setq k (1+ k))
	X	(go la))) 
	X	
	X(defun default-write-file ()
	X  (prog (port)
	X	(setq port t)
	X	(cond (*write-file*
	X	       (setq port ($ofile *write-file*))
	X	       (cond ((null port) 
	X		      (%warn '|write: file has been closed| *write-file*)
	X		      (setq port t)))))
	X        (return port)))
	X
	X                                                                                                                                                                                                         
	X(defun do-rjust (width value port)
	X  (prog (size)
	X	(cond ((eq value '|=== T A B T O ===|)
	X	       (%warn '|rjust cannot precede this function| 'tabto)
	X               (return nil))
	X	      ((eq value '|=== C R L F ===|)
	X	       (%warn '|rjust cannot precede this function| 'crlf)
	X               (return nil))
	X	      ((eq value '|=== R J U S T ===|)
	X	       (%warn '|rjust cannot precede this function| 'rjust)
	X               (return nil)))
	X        (setq size (flatc value ))
	X	(cond ((> size width)
	X	       (princ '| | port)
	X	       (princ value port)
	X	       (return nil)))
	X        (do k (- width size) (1- k) (not (> k 0)) (princ '| | port))
	X	(princ value port)))
	X
	X(defun do-tabto (col port)
	X  (eval `(format ,port (concatenate 'string "~" (princ-to-string ,col) "T"))))
	X
	X;  (prog (pos)
	X;	(setq pos (1+ (nwritn port)))
	X;	(cond ((> pos col)
	X;	       (terpri port)
	X;	       (setq pos 1)))
	X;	(do k (- col pos) (1- k) (not (> k 0)) (princ '| | port))
	X;	(return nil)))
	X
	X
	X(defun halt nil 
	X  (cond ((not *in-rhs*)
	X	 (%warn '|cannot be called at top level| 'halt))
	X	(t (setq *halt-flag* t)))) 
	X
	X(defun build (&quote &rest z)
	X  (prog (r)
	X	(cond ((not *in-rhs*)
	X	       (%warn '|cannot be called at top level| 'build)
	X	       (return nil)))
	X        ($reset)
	X        (build-collect z)
	X        (setq r (unflat (use-result-array)))
	X        (and *build-trace* (funcall *build-trace* r))
	X        (compile-production (car r) (cdr r)))) 
	X
	X(defun infile(file)
	X    (open file :direction :input))
	X
	X(defun outfile (file)
	X    (open file :direction :output))
	X
	X(defun openfile (&quote &rest z)
	X  (prog (file mode id)
	X	($reset)
	X	(eval-args z)
	X	(cond ((not (equal ($parametercount) 3.))
	X	       (%warn '|openfile: wrong number of arguments| z)
	X	       (return nil)))
	X	(setq id ($parameter 1))
	X	(setq file ($parameter 2))
	X	(setq mode ($parameter 3))
	X	(cond ((not (symbolp id))
	X	       (%warn '|openfile: file id must be a symbolic atom| id)
	X	       (return nil))
	X              ((null id)
	X               (%warn '|openfile: 'nil' is reserved for the terminal| nil)
	X               (return nil))
	X	      ((or ($ifile id)($ofile id))
	X	       (%warn '|openfile: name already in use| id)
	X	       (return nil)))
	X	(cond ((eq mode 'in) (putprop id  (infile file) 'inputfile))
	X	      ((eq mode 'out) (putprop id  (outfile file) 'outputfile))
	X	      (t (%warn '|openfile: illegal mode| mode)
	X		 (return nil)))
	X	(return nil)))
	X
	X(defun $ifile (x) 
	X  (cond ((and x (symbolp x)) (get x 'inputfile))
	X        (t *standard-input*)))
	X 
	X(defun $ofile (x) 
	X  (cond ((and x (symbolp x)) (get x 'outputfile))
	X        (t *standard-output*)))
	X
	X
	X(defun closefile (&quote &rest z)
	X  ($reset)
	X  (eval-args z)
	X  (mapc (function closefile2) (use-result-array)))
	X
	X(defun closefile2 (file)
	X  (prog (port)
	X	(cond ((not (symbolp file))
	X	       (%warn '|closefile: illegal file identifier| file))
	X	      ((setq port ($ifile file))
	X	       (close port)
	X	       (remprop file 'inputfile))
	X	      ((setq port ($ofile file))
	X	       (close port)
	X	       (remprop file 'outputfile)))
	X	(return nil)))
	X
	X(defun default (&quote &rest z)
	X  (prog (file use)
	X	($reset)
	X	(eval-args z)
	X	(cond ((not (equal ($parametercount) 2.))
	X	       (%warn '|default: wrong number of arguments| z)
	X	       (return nil)))
	X	(setq file ($parameter 1))
	X	(setq use ($parameter 2))
	X	(cond ((not (symbolp file))
	X	       (%warn '|default: illegal file identifier| file)
	X	       (return nil))
	X	      ((not (memq use '(write accept trace)))
	X	       (%warn '|default: illegal use for a file| use)
	X	       (return nil))
	X	      ((and (memq use '(write trace)) 
	X		    (not (null file))
	X		    (not ($ofile file)))
	X	       (%warn '|default: file has not been opened for output| file)
	X	       (return nil))
	X	      ((and (eq use 'accept) 
	X		    (not (null file))
	X		    (not ($ifile file)))
	X	       (%warn '|default: file has not been opened for input| file)
	X	       (return nil))
	X	      ((eq use 'write) (setq *write-file* file))
	X	      ((eq use 'accept) (setq *accept-file* file))
	X	      ((eq use 'trace) (setq *trace-file* file)))
	X	(return nil)))
	X
	X
	X
	X;;; RHS Functions
	X
	X(defun accept (&quote &rest z)
	X  (prog (port arg)
	X	(cond ((> (length z) 1.)
	X	       (%warn '|accept: wrong number of arguments| z)
	X	       (return nil)))
	X	(setq port t)
	X	(cond (*accept-file*
	X	       (setq port ($ifile *accept-file*))
	X	       (cond ((null port) 
	X		      (%warn '|accept: file has been closed| *accept-file*)
	X		      (return nil)))))
	X	(cond ((= (length z) 1)
	X	       (setq arg ($varbind (car z)))
	X	       (cond ((not (symbolp arg))
	X	              (%warn '|accept: illegal file name| arg)
	X		      (return nil)))
	X	       (setq port ($ifile arg))
	X	       (cond ((null port) 
	X		      (%warn '|accept: file not open for input| arg)
	X		      (return nil)))))
	X        (cond ((= (tyipeek port) -1.)
	X	       ($value 'end-of-file)
	X	       (return nil)))
	X	(flat-value (read port)))) 
	X
	X(defun flat-value (x)
	X  (cond ((atom x) ($value x))
	X        (t (mapc (function flat-value) x)))) 
	X
	X(defun span-chars (x prt)
	X  (do ch (tyipeek prt) (tyipeek prt) (not (member ch x #'char-equal)) (read-char prt)))
	X
	X(defun acceptline (&quote &rest z)
	X  (prog ( def arg port)
	X	(setq port t)
	X	(setq def z)
	X	(cond (*accept-file*
	X	       (setq port ($ifile *accept-file*))
	X	       (cond ((null port) 
	X		      (%warn '|acceptline: file has been closed| 
	X		             *accept-file*)
	X		      (return nil)))))
	X	(cond ((> (length def) 0)
	X	       (setq arg ($varbind (car def)))
	X	       (cond ((and (symbolp arg) ($ifile arg))
	X	              (setq port ($ifile arg))
	X		      (setq def (cdr def))))))
	X        (span-chars '(9. 41.) port)
	X	(cond ((memq (tyipeek port) '(-1. 10.))
	X	       (mapc (function $change) def)
	X	       (return nil)))
	X   lp1	(flat-value (read port))
	X        (span-chars '(9. 41.) port)
	X	(cond ((not (memq (tyipeek port) '(-1. 10.))) (go lp1)))))
	X
	X(defun substr (&quote &rest l)
	X  (prog (k elm start end)
	X        (cond ((not (= (length l) 3.))
	X               (%warn '|substr: wrong number of arguments| l)
	X               (return nil)))
	X        (setq elm (get-ce-var-bind (car l)))
	X        (cond ((null elm)
	X               (%warn '|first argument to substr must be a ce var|
	X                        l)
	X               (return nil)))
	X        (setq start ($varbind (cadr l)))
	X	(setq start ($litbind start))
	X        (cond ((not (numberp start))
	X               (%warn '|second argument to substr must be a number|
	X                        l)
	X               (return nil)))
	X	(comment |if a variable is bound to INF, the following|
	X		 |will get the binding and treat it as INF is|
	X		 |always treated.  that may not be good|)
	X        (setq end ($varbind (caddr l)))
	X        (cond ((eq end 'inf) (setq end (length elm))))
	X	(setq end ($litbind end))
	X        (cond ((not (numberp end))
	X               (%warn '|third argument to substr must be a number|
	X                        l)
	X               (return nil)))
	X        (comment |this loop does not check for the end of elm|
	X                 |instead it relies on cdr of nil being nil|
	X                 |this may not work in all versions of lisp|)
	X        (setq k 1.)
	X   la   (cond ((> k end) (return nil))
	X              ((not (< k start)) ($value (car elm))))
	X        (setq elm (cdr elm))
	X        (setq k (1+ k))
	X        (go la))) 
	X
	X
	X(defun compute (&quote &rest z) ($value (ari z))) 
	X
	X; arith is the obsolete form of compute
	X(defun arith (&quote &rest z) ($value (ari z))) 
	X
	X(defun ari (x)
	X  (cond ((atom x)
	X         (%warn '|bad syntax in arithmetic expression | x)
	X	 0.)
	X        ((atom (cdr x)) (ari-unit (car x)))
	X        ((eq (cadr x) '+)
	X         (plus (ari-unit (car x)) (ari (cddr x))))
	X        ((eq (cadr x) '-)
	X         (difference (ari-unit (car x)) (ari (cddr x))))
	X        ((eq (cadr x) '*)
	X         (times (ari-unit (car x)) (ari (cddr x))))
	X        ((eq (cadr x) '//)
	X         (quotient (ari-unit (car x)) (ari (cddr x))))
	X        ((eq (cadr x) '\\)
	X         (mod (fix (ari-unit (car x))) (fix (ari (cddr x)))))
	X        (t (%warn '|bad syntax in arithmetic expression | x) 0.))) 
	X
	X(defun ari-unit (a)
	X  (prog (r)
	X        (cond ((listp a) (setq r (ari a)))
	X              (t (setq r ($varbind a))))
	X        (cond ((not (numberp r))
	X               (%warn '|bad value in arithmetic expression| a)
	X               (return 0.))
	X              (t (return r))))) 
	X
	X(defun genatom nil ($value (gensym))) 
	X
	X(defun litval (&quote &rest z)
	X  (prog (r)
	X	(cond ((not (= (length z) 1.))
	X	       (%warn '|litval: wrong number of arguments| z)
	X	       ($value 0) 
	X	       (return nil))
	X	      ((numberp (car z)) ($value (car z)) (return nil)))
	X	(setq r ($litbind ($varbind (car z))))
	X	(cond ((numberp r) ($value r) (return nil)))
	X	(%warn '|litval: argument has no literal binding| (car z))
	X	($value 0)))
	X
	X
	X(defun rjust (&quote &rest z)
	X  (prog (val)
	X        (cond ((not (= (length z) 1.))
	X	       (%warn '|rjust: wrong number of arguments| z)
	X               (return nil)))
	X        (setq val ($varbind (car z)))
	X	(cond ((or (not (numberp val)) (< val 1.) (> val 127.))
	X	       (%warn '|rjust: illegal value for field width| val)
	X	       (return nil)))
	X        ($value '|=== R J U S T ===|)
	X	($value val)))
	X
	X(defun crlf (&quote &optional z)
	X        (cond  (z (%warn '|crlf: does not take arguments| z))
	X	       (t ($value '|=== C R L F ===|))))
	X
	X(defun tabto (&quote &rest z)
	X  (prog (val)
	X        (cond ((not (= (length z) 1.))
	X	       (%warn '|tabto: wrong number of arguments| z)
	X	       (return nil)))
	X        (setq val ($varbind (car z)))
	X	(cond ((or (not (numberp val)) (< val 1.) (> val 127.))
	X	       (%warn '|tabto: illegal column number| z)
	X	       (return nil)))
	X        ($value '|=== T A B T O ===|)
	X	($value val)))
	X
	X
	X
	X;;; Printing WM
	X
	X(defun ppwm (&quote &rest avlist)
	X  (prog (next a)
	X        (setq *filters* nil)
	X        (setq next 1.)
	X   l   (and (atom avlist) (go print))
	X        (setq a (car avlist))
	X        (setq avlist (cdr avlist))
	X        (cond ((eq a #\^)
	X               (setq next (car avlist))
	X               (setq avlist (cdr avlist))
	X               (setq next ($litbind next))
	X               (and (floatp next) (setq next (fix next)))
	X               (cond ((or (not (numberp next))
	X                          (> next *size-result-array*)
	X                          (> 1. next))
	X                      (%warn '|illegal index after ^| next)
	X                      (return nil))))
	X              ((variablep a)
	X               (%warn '|ppwm does not take variables| a)
	X               (return nil))
	X              (t (setq *filters* (cons next (cons a *filters*)))
	X                 (setq next (1+ next))))
	X        (go l)
	X   print (mapwm (function ppwm2))
	X        (terpri)
	X        (return nil))) 
	X
	X(defun ppwm2 (elm-tag)
	X  (cond ((filter (car elm-tag)) (terpri) (ppelm (car elm-tag) t)))) 
	X
	X(defun filter (elm)
	X  (prog (fl indx val)
	X        (setq fl *filters*)
	X   top  (and (atom fl) (return t))
	X        (setq indx (car fl))
	X        (setq val (cadr fl))
	X        (setq fl (cddr fl))
	X        (and (ident (nth (1- indx) elm) val) (go top))
	X        (return nil))) 
	X
	X(defun ident (x y)
	X  (cond ((eq x y) t)
	X        ((not (numberp x)) nil)
	X        ((not (numberp y)) nil)
	X        ((=alg x y) t)
	X        (t nil))) 
	X
	X; the new ppelm is designed especially to handle literalize format
	X; however, it will do as well as the old ppelm on other formats
	X
	X(defun ppelm (elm port)
	X  (prog (ppdat sep val att mode lastpos)
	X	(princ (creation-time elm) port)
	X	(princ '|:  | port)
	X        (setq mode 'vector)
	X	(setq ppdat (get (car elm) 'ppdat))
	X	(and ppdat (setq mode 'a-v))
	X	(setq sep '|(|)
	X        (setq lastpos 0)
	X	(do
	X	 ((curpos 1 (1+ curpos)) (vlist elm (cdr vlist)))
	X	 ((atom vlist) nil)
	X	 (setq val (car vlist))
	X	 (setq att (assoc curpos ppdat))
	X	 (cond (att (setq att (cdr att)))
	X	       (t (setq att curpos)))
	X         (and (symbolp att) (is-vector-attribute att) (setq mode 'vector))
	X	 (cond ((or (not (null val)) (eq mode 'vector))
	X		(princ sep port)
	X		(ppval val att lastpos port)
	X		(setq sep '|    |)
	X		(setq lastpos curpos))))
	X	(princ '|)| port)))
	X
	X(defun ppval (val att lastpos port)
	X  (cond ((not (equal att (1+ lastpos)))
	X         (princ '^ port)
	X         (princ att port)
	X         (princ '| | port)))
	X  (princ val port))
	X
	X
	X
	X;;; printing production memory
	X
	X(defmacro pm (&rest z)  `(progn (mapc #'pprule ',z) (terpri) nil)) 
	X
	X(defun pprule (name)
	X  (prog (matrix next lab)
	X        (and (not (symbolp name)) (return nil))
	X        (setq matrix (get name 'production))
	X	(and (null matrix) (return nil))
	X	(terpri)
	X	(princ '|(p |)
	X	(princ name)
	X   top	(and (atom matrix) (go fin))
	X        (setq next (car matrix))
	X	(setq matrix (cdr matrix))
	X	(setq lab nil)
	X	(terpri)
	X	(cond ((eq next '-)
	X	       (princ '|  - |)
	X	       (setq next (car matrix))
	X	       (setq matrix (cdr matrix)))
	X	      ((eq next '-->)
	X	       (princ '|  |))
	X	      ((and (eq next '{) (atom (car matrix)))
	X	       (princ '|   {|)
	X	       (setq lab (car matrix))
	X	       (setq next (cadr matrix))
	X	       (setq matrix (cdddr matrix)))
	X	      ((eq next '{)
	X	       (princ '|   {|)
	X	       (setq lab (cadr matrix))
	X	       (setq next (car matrix))
	X	       (setq matrix (cdddr matrix)))
	X	      (t (princ '|    |)))
	X        (ppline next)
	X	(cond (lab (princ '| |) (princ lab) (princ '})))
	X	(go top)
	X    fin	(princ '|)|)))
	X
	X(defun ppline (line)
	X  (prog ()
	X	(cond ((atom line) (princ line))
	X	      (t
	X	       (princ '|(|)
	X	       (setq *ppline* line)
	X	       (ppline2)
	X	       (princ '|)|)))
	X        (return nil)))
	X
	X(defun ppline2 ()
	X  (prog (needspace)
	X        (setq needspace nil)
	X   top  (and (atom *ppline*) (return nil))
	X        (and needspace (princ '| |))
	X        (cond ((eq (car *ppline*) #\^) (ppattval))
	X	      (t (pponlyval)))
	X        (setq needspace t)
	X        (go top)))
	X
	X;NWRITN, sort of.  This is implementation dependant for the TI Explorer.
	X(defun nwritn(&optional port)
	X   (cond ((null port) 
	X          (cdr (cursorpos)))
	X         (t
	X          (cursorpos port))))
	X
	X(defun ppattval ()
	X  (prog (att val)
	X        (setq att (cadr *ppline*))
	X	(setq *ppline* (cddr *ppline*))
	X	(setq val (getval))
	X	(cond ((> (+ (nwritn) (flatc att) (flatc val)) 76.)
	X	       (terpri)
	X	       (princ '|        |)))
	X        (princ '^)
	X	(princ att)
	X	(mapc (function (lambda (z) (princ '| |) (princ z))) val)))
	X
	X(defun pponlyval ()
	X  (prog (val needspace)
	X	(setq val (getval))
	X	(setq needspace nil)
	X	(cond ((> (+ (nwritn) (flatc val)) 76.)
	X	       (setq needspace nil)
	X	       (terpri)
	X	       (princ '|        |)))
	X    top	(and (atom val) (return nil))
	X        (and needspace (princ '| |))
	X	(setq needspace t)
	X	(princ (car val))
	X	(setq val (cdr val))
	X	(go top)))
	X
	X(defun getval ()
	X  (prog (res v1)
	X        (setq v1 (car *ppline*))
	X	(setq *ppline* (cdr *ppline*))
	X	(cond ((memq v1 '(= <> < <= => > <=>))
	X	       (setq res (cons v1 (getval))))
	X	      ((eq v1 '{)
	X	       (setq res (cons v1 (getupto '}))))
	X	      ((eq v1 '<<)
	X	       (setq res (cons v1 (getupto '>>))))
	X	      ((eq v1 '//)
	X	       (setq res (list v1 (car *ppline*)))
	X	       (setq *ppline* (cdr *ppline*)))
	X	      (t (setq res (list v1))))
	X        (return res)))
	X
	X(defun getupto (end)
	X  (prog (v)
	X        (and (atom *ppline*) (return nil))
	X	(setq v (car *ppline*))
	X	(setq *ppline* (cdr *ppline*))
	X	(cond ((eq v end) (return (list v)))
	X	      (t (return (cons v (getupto end))))))) 
	X
	X
	X
	X
	X
	X
	X;;; backing up
	X
	X
	X
	X(defun record-index-plus (k)
	X  (setq *record-index* (+ k *record-index*))
	X  (cond ((< *record-index* 0.)
	X         (setq *record-index* *max-record-index*))
	X        ((> *record-index* *max-record-index*)
	X         (setq *record-index* 0.)))) 
	X
	X; the following routine initializes the record.  putting nil in the
	X; first slot indicates that that the record does not go back further
	X; than that.  (when the system backs up, it writes nil over the used
	X; records so that it will recognize which records it has used.  thus
	X; the system is set up anyway never to back over a nil.)
	X
	X(defun initialize-record nil
	X  (setq *record-index* 0.)
	X  (setq *recording* nil)
	X  (setq *max-record-index* 31.)
	X  (putvector *record-array* 0. nil)) 
	X
	X; *max-record-index* holds the maximum legal index for record-array
	X; so it and the following must be changed at the same time
	X
	X(defun begin-record (p data)
	X  (setq *recording* t)
	X  (setq *record* (list '=>refract p data))) 
	X
	X(defun end-record nil
	X  (cond (*recording*
	X         (setq *record*
	X               (cons *cycle-count* (cons *p-name* *record*)))
	X         (record-index-plus 1.)
	X         (putvector *record-array* *record-index* *record*)
	X         (setq *record* nil)
	X         (setq *recording* nil)))) 
	X
	X(defun record-change (direct time elm)
	X  (cond (*recording*
	X         (setq *record*
	X               (cons direct (cons time (cons elm *record*))))))) 
	X
	X; to maintain refraction information, need keep only one piece of information:
	X; need to record all unsuccessful attempts to delete things from the conflict
	X; set.  unsuccessful deletes are caused by attempting to delete refracted
	X; instantiations.  when backing up, have to avoid putting things back into the
	X; conflict set if they were not deleted when running forward
	X
	X(defun record-refract (rule data)
	X  (and *recording*
	X       (setq *record* (cons '<=refract (cons rule (cons data *record*))))))
	X
	X(defun refracted (rule data)
	X  (prog (z)
	X        (and (null *refracts*) (return nil))
	X	(setq z (cons rule data))
	X	(return (member z *refracts*))))
	X
	X(defun back (k)
	X  (prog (r)
	X   l   (and (< k 1.) (return nil))
	X        (setq r (getvector *record-array* *record-index*))
	X        (and (null r) (return '|nothing more stored|))
	X        (putvector *record-array* *record-index* nil)
	X        (record-index-plus -1.)
	X        (undo-record r)
	X        (setq k (1- k))
	X        (go l))) 
	X
	X(defun undo-record (r)
	X  (prog (save act a b rate)
	X        (comment *recording* must be off during back up)
	X        (setq save *recording*)
	X        (setq *refracts* nil)
	X        (setq *recording* nil)
	X        (and *ptrace* (back-print (list 'undo (car r) (cadr r))))
	X        (setq r (cddr r))
	X   top  (and (atom r) (go fin))
	X        (setq act (car r))
	X        (setq a (cadr r))
	X        (setq b (caddr r))
	X        (setq r (cdddr r))
	X        (and *wtrace* (back-print (list 'undo act a)))
	X        (cond ((eq act '<=wm) (add-to-wm b a))
	X              ((eq act '=>wm) (remove-from-wm b))
	X              ((eq act '<=refract)
	X               (setq *refracts* (cons (cons a b) *refracts*)))
	X              ((and (eq act '=>refract) (still-present b))
	X	       (setq *refracts* (delete (cons a b) *refracts*))
	X               (setq rate (rating-part (get a 'topnode)))
	X               (removecs a b)
	X               (insertcs a b rate))
	X              (t (%warn '|back: cannot undo action| (list act a))))
	X        (go top)
	X   fin  (setq *recording* save)
	X        (setq *refracts* nil)
	X        (return nil))) 
	X
	X; still-present makes sure that the user has not deleted something
	X; from wm which occurs in the instantiation about to be restored; it
	X; makes the check by determining whether each wme still has a time tag.
	X
	X(defun still-present (data)
	X  (prog nil
	X   l   (cond ((atom data) (return t))
	X              ((creation-time (car data))
	X               (setq data (cdr data))
	X               (go l))
	X              (t (return nil))))) 
	X
	X
	X(defun back-print (x) 
	X  (prog (port)
	X        (setq port (trace-file))
	X        (terpri port)
	X	(print x port)))
	X
	X
	X
	X
	X;;; Functions to show how close rules are to firing
	X
	X(defun matches (&quote &rest rule-list)
	X  (progn 
	X    (mapc (function matches2) rule-list)
	X    (terpri)) )
	X
	X(defun matches2 (p)
	X  (cond ((atom p)
	X         (terpri)
	X         (terpri)
	X         (princ p)
	X         (matches3 (get p 'backpointers) 2. (ncons 1.))))) 
	X
	X(defun matches3 (nodes ce part)
	X  (cond ((not (null nodes))
	X         (terpri)
	X         (princ '| ** matches for |)
	X         (princ part)
	X         (princ '| ** |)
	X         (mapc (function write-elms) (find-left-mem (car nodes)))
	X         (terpri)
	X         (princ '| ** matches for |)
	X         (princ (ncons ce))
	X         (princ '| ** |)
	X         (mapc (function write-elms) (find-right-mem (car nodes)))
	X         (matches3 (cdr nodes) (1+ ce) (cons ce part))))) 
	X
	X(defun write-elms (wme-or-count)
	X  (cond ((listp wme-or-count)
	X	 (terpri)
	X	 (mapc (function write-elms2) wme-or-count)))) 
	X
	X(defun write-elms2 (x)
	X  (princ '|  |)
	X  (princ (creation-time x)))
	X
	X(defun find-left-mem (node)
	X  (cond ((eq (car node) '&and) (memory-part (caddr node)))
	X        (t (car (caddr node))))) 
	X
	X(defun find-right-mem (node) (memory-part (cadddr node))) 
	X
	X
	X;;; Check the RHSs of productions 
	X
	X
	X(defun check-rhs (rhs) (mapc (function check-action) rhs))
	X
	X(defun check-action (x)
	X  (prog (a)
	X    (cond ((atom x)
	X           (%warn '|atomic action| x)
	X	   (return nil)))
	X    (setq a  (car x))
	X    (cond ((eq a 'bind) (check-bind x))
	X          ((eq a 'cbind) (check-cbind x))
	X          ((eq a 'make) (check-make x))
	X          ((eq a 'modify) (check-modify x))
	X          ((eq a 'oremove) (check-remove x))
	X          ((eq a 'owrite) (check-write x))
	X          ((eq a 'ocall) (check-call x))
	X          ((eq a 'halt) (check-halt x))
	X          ((eq a 'openfile) (check-openfile x))
	X          ((eq a 'closefile) (check-closefile x))
	X          ((eq a 'default) (check-default x))
	X          ((eq a 'build) (check-build x))
	X          ;;the following section is responsible for replacing standard ops RHS actions
	X          ;;with actions which don't conflict with existing CL functions.  The RPLACA function
	X          ;;is used so that the change will be reflected in the production body.
	X          ((eq a 'remove) (rplaca x 'oremove) 
	X                          (check-remove x))
	X          ((eq a 'write)   (rplaca x 'owrite)
	X                          (check-write x)) 
	X          ((eq a 'call)   (rplaca x 'ocall)
	X                          (check-call x))
	X          (t (%warn '|undefined rhs action| a))))) 
	X
	X(defun check-build (z)
	X  (and (null (cdr z)) (%warn '|needs arguments| z))
	X  (check-build-collect (cdr z)))
	X
	X(defun check-build-collect (args)
	X  (prog (r)
	X    top	(and (null args) (return nil))
	X	(setq r (car args))
	X	(setq args (cdr args))
	X	(cond ((listp r) (check-build-collect r))
	X	      ((eq r '\\)
	X	       (and (null args) (%warn '|nothing to evaluate| r))
	X	       (check-rhs-value (car args))
	X	       (setq args (cdr args))))
	X	(go top)))
	X
	X(defun check-remove (z) 
	X  (and (null (cdr z)) (%warn '|needs arguments| z))
	X  (mapc (function check-rhs-ce-var) (cdr z))) 
	X
	X(defun check-make (z)
	X  (and (null (cdr z)) (%warn '|needs arguments| z))
	X  (check-change& (cdr z))) 
	X
	X(defun check-openfile (z)
	X  (and (null (cdr z)) (%warn '|needs arguments| z))
	X  (check-change& (cdr z))) 
	X
	X(defun check-closefile (z)
	X  (and (null (cdr z)) (%warn '|needs arguments| z))
	X  (check-change& (cdr z))) 
	X
	X(defun check-default (z)
	X  (and (null (cdr z)) (%warn '|needs arguments| z))
	X  (check-change& (cdr z))) 
	X
	X(defun check-modify (z)
	X  (and (null (cdr z)) (%warn '|needs arguments| z))
	X  (check-rhs-ce-var (cadr z))
	X  (and (null (cddr z)) (%warn '|no changes to make| z))
	X  (check-change& (cddr z))) 
	X
	X(defun check-write (z)
	X  (and (null (cdr z)) (%warn '|needs arguments| z))
	X  (check-change& (cdr z))) 
	X
	X(defun check-call (z)
	X  (prog (f)
	X    (and (null (cdr z)) (%warn '|needs arguments| z))
	X    (setq f (cadr z))
	X    (and (variablep f)
	X         (%warn '|function name must be a constant| z))
	X    (or (symbolp f)
	X        (%warn '|function name must be a symbolic atom| f))
	X    (or (externalp f)
	X        (%warn '|function name not declared external| f))
	X    (check-change& (cddr z)))) 
	X
	X(defun check-halt (z)
	X  (or (null (cdr z)) (%warn '|does not take arguments| z))) 
	X
	X(defun check-cbind (z)
	X  (prog (v)
	X    (or (= (length z) 2.) (%warn '|takes only one argument| z))
	X    (setq v (cadr z))
	X    (or (variablep v) (%warn '|takes variable as argument| z))
	X    (note-ce-variable v))) 
	X
	X(defun check-bind (z)
	X  (prog (v)
	X    (or (> (length z) 1.) (%warn '|needs arguments| z))
	X    (setq v (cadr z))
	X    (or (variablep v) (%warn '|takes variable as argument| z))
	X    (note-variable v)
	X    (check-change& (cddr z)))) 
	X
	X
	X(defun check-change& (z)
	X  (prog (r tab-flag)
	X        (setq tab-flag nil)
	X   la   (and (atom z) (return nil))
	X        (setq r (car z))
	X        (setq z (cdr z))
	X        (cond ((eq r #\^)
	X               (and tab-flag
	X                    (%warn '|no value before this tab| (car z)))
	X               (setq tab-flag t)
	X               (check-tab-index (car z))
	X               (setq z (cdr z)))
	X              ((eq r '//) (setq tab-flag nil) (setq z (cdr z)))
	X              (t (setq tab-flag nil) (check-rhs-value r)))
	X        (go la))) 
	X
	X(defun check-rhs-ce-var (v)
	X  (cond ((and (not (numberp v)) (not (ce-bound? v)))
	X         (%warn '|unbound element variable| v))
	X        ((and (numberp v) (or (< v 1.) (> v *ce-count*)))
	X         (%warn '|numeric element designator out of bounds| v)))) 
	X
	X(defun check-rhs-value (x)
	X  (cond ((and x (listp x)) (check-rhs-function x))
	X        (t (check-rhs-atomic x)))) 
	X
	X(defun check-rhs-atomic (x)
	X  (and (variablep x) 
	X       (not (bound? x)) 
	X       (%warn '|unbound variable| x)))
	X
	X(defun check-rhs-function (x)
	X  (prog (a)
	X    (setq a (car x))
	X    (cond ((eq a 'compute) (check-compute x))
-- 
---------------
C'est la vie, C'est la guerre, C'est la pomme de terre
Mail:	Imagen Corp. 2650 San Tomas Expressway Santa Clara, CA 95052-8101 
UUCP:	...{decvax,ucbvax}!decwrl!imagen!turner      AT&T: (408) 986-9400