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


	X; the following two functions encode indices so that gelm can
	X; decode them as fast as possible
	X
	X(defun encode-pair (a b) (+ (* 10000. (1- a)) (1- b))) 
	X
	X(defun encode-singleton (a) (1- a)) 
	X
	X(defun promote-var (dope)
	X  (prog (vname vpred vpos new)
	X        (setq vname (car dope))
	X        (setq vpred (cadr dope))
	X        (setq vpos (caddr dope))
	X        (or (eq 'eq vpred)
	X            (%error '|illegal predicate for first occurrence|
	X                   (list vname vpred)))
	X        (setq new (list vname 0. vpos))
	X        (setq *vars* (cons new *vars*)))) 
	X
	X(defun fudge nil
	X  (mapc (function fudge*) *vars*)
	X  (mapc (function fudge*) *ce-vars*)) 
	X
	X(defun fudge* (z)
	X  (prog (a) (setq a (cdr z)) (rplaca a (1+ (car a))))) 
	X
	X(defun build-beta (type tests)
	X  (prog (rpred lpred lnode lef)
	X        (link-new-node (list '&mem nil nil (protomem)))
	X        (setq rpred *last-node*)
	X        (cond ((eq type '&and)
	X               (setq lnode (list '&mem nil nil (protomem))))
	X              (t (setq lnode (list '&two nil nil))))
	X        (setq lpred (link-to-branch lnode))
	X        (cond ((eq type '&and) (setq lef lpred))
	X              (t (setq lef (protomem))))
	X        (link-new-beta-node (list type nil lef rpred tests)))) 
	X
	X(defun protomem nil (list nil)) 
	X
	X(defun memory-part (mem-node) (car (cadddr mem-node))) 
	X
	X(defun encode-dope nil
	X  (prog (r all z k)
	X        (setq r nil)
	X        (setq all *vars*)
	X   la   (and (atom all) (return r))
	X        (setq z (car all))
	X        (setq all (cdr all))
	X        (setq k (encode-pair (cadr z) (caddr z)))
	X        (setq r (cons (car z) (cons k r)))
	X        (go la))) 
	X
	X(defun encode-ce-dope nil
	X  (prog (r all z k)
	X        (setq r nil)
	X        (setq all *ce-vars*)
	X   la   (and (atom all) (return r))
	X        (setq z (car all))
	X        (setq all (cdr all))
	X        (setq k (cadr z))
	X        (setq r (cons (car z) (cons k r)))
	X        (go la))) 
	X
	X
	X
	X;;; Linking the nodes
	X
	X(defun link-new-node (r)
	X  (cond ((not (member (car r) '(&p &mem &two &and &not)))
	X	 (setq *feature-count* (1+ *feature-count*))))
	X  (setq *virtual-cnt* (1+ *virtual-cnt*))
	X  (setq *last-node* (link-left *last-node* r))) 
	X
	X(defun link-to-branch (r)
	X  (setq *virtual-cnt* (1+ *virtual-cnt*))
	X  (setq *last-branch* (link-left *last-branch* r))) 
	X
	X(defun link-new-beta-node (r)
	X  (setq *virtual-cnt* (1+ *virtual-cnt*))
	X  (setq *last-node* (link-both *last-branch* *last-node* r))
	X  (setq *last-branch* *last-node*)) 
	X
	X(defun link-left (pred succ)
	X  (prog (a r)
	X        (setq a (left-outs pred))
	X        (setq r (find-equiv-node succ a))
	X        (and r (return r))
	X        (setq *real-cnt* (1+ *real-cnt*))
	X        (attach-left pred succ)
	X        (return succ))) 
	X
	X(defun link-both (left right succ)
	X  (prog (a r)
	X        (setq a (interq (left-outs left) (right-outs right)))
	X        (setq r (find-equiv-beta-node succ a))
	X        (and r (return r))
	X        (setq *real-cnt* (1+ *real-cnt*))
	X        (attach-left left succ)
	X        (attach-right right succ)
	X        (return succ))) 
	X
	X(defun attach-right (old new)
	X  (rplaca (cddr old) (cons new (caddr old)))) 
	X
	X(defun attach-left (old new)
	X  (rplaca (cdr old) (cons new (cadr old)))) 
	X
	X(defun right-outs (node) (caddr node)) 
	X
	X(defun left-outs (node) (cadr node)) 
	X
	X(defun find-equiv-node (node list)
	X  (prog (a)
	X        (setq a list)
	X   l1   (cond ((atom a) (return nil))
	X              ((equiv node (car a)) (return (car a))))
	X        (setq a (cdr a))
	X        (go l1))) 
	X
	X(defun find-equiv-beta-node (node list)
	X  (prog (a)
	X        (setq a list)
	X   l1   (cond ((atom a) (return nil))
	X              ((beta-equiv node (car a)) (return (car a))))
	X        (setq a (cdr a))
	X        (go l1))) 
	X
	X; do not look at the predecessor fields of beta nodes; they have to be
	X; identical because of the way the candidate nodes were found
	X
	X(defun equiv (a b)
	X  (and (eq (car a) (car b))
	X       (or (eq (car a) '&mem)
	X           (eq (car a) '&two)
	X           (equal (caddr a) (caddr b)))
	X       (equal (cdddr a) (cdddr b)))) 
	X
	X(defun beta-equiv (a b)
	X  (and (eq (car a) (car b))
	X       (equal (cddddr a) (cddddr b))
	X       (or (eq (car a) '&and) (equal (caddr a) (caddr b))))) 
	X
	X; the equivalence tests are set up to consider the contents of
	X; node memories, so they are ready for the build action
	X
	X;;; Network interpreter
	X
	X(defun match (flag wme)
	X  (sendto flag (list wme) 'left (list *first-node*)))
	X
	X; note that eval-nodelist is not set up to handle building
	X; productions.  would have to add something like ops4's build-flag
	X
	X(defun eval-nodelist (nl)
	X  (prog nil
	X   top  (and (not nl) (return nil))
	X        (setq *sendtocall* nil)
	X	(setq *last-node* (car nl))
	X        (apply (caar nl) (cdar nl))
	X        (setq nl (cdr nl))
	X        (go top))) 
	X
	X(defun sendto (flag data side nl)
	X  (prog nil
	X   top  (and (not nl) (return nil))
	X        (setq *side* side)
	X        (setq *flag-part* flag)
	X        (setq *data-part* data)
	X        (setq *sendtocall* t)
	X	(setq *last-node* (car nl))
	X        (apply (caar nl) (cdar nl))
	X        (setq nl (cdr nl))
	X        (go top))) 
	X
	X; &bus sets up the registers for the one-input nodes.  note that this
	X(defun &bus (outs)
	X  (prog (dp)
	X        (setq *alpha-flag-part* *flag-part*)
	X        (setq *alpha-data-part* *data-part*)
	X        (setq dp (car *data-part*))
	X        (setq *c1* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c2* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c3* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c4* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c5* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c6* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c7* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c8* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c9* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c10* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c11* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c12* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c13* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c14* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c15* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c16* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c17* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c18* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c19* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c20* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c21* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c22* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c23* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c24* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c25* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c26* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c27* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c28* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c29* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c30* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c31* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c32* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c33* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c34* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c35* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c36* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c37* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c38* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c39* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c40* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c41* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c42* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c43* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c44* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c45* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c46* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c47* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c48* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c49* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c50* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c51* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c52* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c53* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c54* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c55* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c56* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c57* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c58* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c59* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c60* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c61* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c62* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c63* (car dp))
	X        (setq dp (cdr dp))
	X        (setq *c64* (car dp))
	X        (eval-nodelist outs))) 
	X
	X(defun &any (outs register const-list)
	X  (prog (z c)
	X        (setq z (fast-symeval register))
	X        (cond ((numberp z) (go number)))
	X   symbol (cond ((null const-list) (return nil))
	X                ((eq (car const-list) z) (go ok))
	X                (t (setq const-list (cdr const-list)) (go symbol)))
	X   number (cond ((null const-list) (return nil))
	X                ((and (numberp (setq c (car const-list)))
	X                      (=alg c z))
	X                 (go ok))
	X                (t (setq const-list (cdr const-list)) (go number)))
	X   ok   (eval-nodelist outs))) 
	X
	X(defun teqa (outs register constant)
	X  (and (eq (fast-symeval register) constant) (eval-nodelist outs))) 
	X
	X(defun tnea (outs register constant)
	X  (and (not (eq (fast-symeval register) constant)) (eval-nodelist outs))) 
	X
	X(defun txxa (outs register constant)
	X  (and (symbolp (fast-symeval register)) (eval-nodelist outs))) 
	X
	X(defun teqn (outs register constant)
	X  (prog (z)
	X        (setq z (fast-symeval register))
	X        (and (numberp z)
	X             (=alg z constant)
	X             (eval-nodelist outs)))) 
	X
	X(defun tnen (outs register constant)
	X  (prog (z)
	X        (setq z (fast-symeval register))
	X        (and (or (not (numberp z))
	X                 (not (=alg z constant)))
	X             (eval-nodelist outs)))) 
	X
	X(defun txxn (outs register constant)
	X  (prog (z)
	X        (setq z (fast-symeval register))
	X        (and (numberp z) (eval-nodelist outs)))) 
	X
	X(defun tltn (outs register constant)
	X  (prog (z)
	X        (setq z (fast-symeval register))
	X        (and (numberp z)
	X             (greaterp constant z)
	X             (eval-nodelist outs)))) 
	X
	X(defun tgtn (outs register constant)
	X  (prog (z)
	X        (setq z (fast-symeval register))
	X        (and (numberp z)
	X             (greaterp z constant)
	X             (eval-nodelist outs)))) 
	X
	X(defun tgen (outs register constant)
	X  (prog (z)
	X        (setq z (fast-symeval register))
	X        (and (numberp z)
	X             (not (greaterp constant z))
	X             (eval-nodelist outs)))) 
	X
	X(defun tlen (outs register constant)
	X  (prog (z)
	X        (setq z (fast-symeval register))
	X        (and (numberp z)
	X             (not (greaterp z constant))
	X             (eval-nodelist outs)))) 
	X
	X(defun teqs (outs vara varb)
	X  (prog (a b)
	X        (setq a (fast-symeval vara))
	X        (setq b (fast-symeval varb))
	X        (cond ((eq a b) (eval-nodelist outs))
	X              ((and (numberp a)
	X                    (numberp b)
	X                    (=alg a b))
	X               (eval-nodelist outs))))) 
	X
	X(defun tnes (outs vara varb)
	X  (prog (a b)
	X        (setq a (fast-symeval vara))
	X        (setq b (fast-symeval varb))
	X        (cond ((eq a b) (return nil))
	X              ((and (numberp a)
	X                    (numberp b)
	X                    (=alg a b))
	X               (return nil))
	X              (t (eval-nodelist outs))))) 
	X
	X(defun txxs (outs vara varb)
	X  (prog (a b)
	X        (setq a (fast-symeval vara))
	X        (setq b (fast-symeval varb))
	X        (cond ((and (numberp a) (numberp b)) (eval-nodelist outs))
	X              ((and (not (numberp a)) (not (numberp b)))
	X               (eval-nodelist outs))))) 
	X
	X(defun tlts (outs vara varb)
	X  (prog (a b)
	X        (setq a (fast-symeval vara))
	X        (setq b (fast-symeval varb))
	X        (and (numberp a)
	X             (numberp b)
	X             (greaterp b a)
	X             (eval-nodelist outs)))) 
	X
	X(defun tgts (outs vara varb)
	X  (prog (a b)
	X        (setq a (fast-symeval vara))
	X        (setq b (fast-symeval varb))
	X        (and (numberp a)
	X             (numberp b)
	X             (greaterp a b)
	X             (eval-nodelist outs)))) 
	X
	X(defun tges (outs vara varb)
	X  (prog (a b)
	X        (setq a (fast-symeval vara))
	X        (setq b (fast-symeval varb))
	X        (and (numberp a)
	X             (numberp b)
	X             (not (greaterp b a))
	X             (eval-nodelist outs)))) 
	X
	X(defun tles (outs vara varb)
	X  (prog (a b)
	X        (setq a (fast-symeval vara))
	X        (setq b (fast-symeval varb))
	X        (and (numberp a)
	X             (numberp b)
	X             (not (greaterp a b))
	X             (eval-nodelist outs)))) 
	X
	X(defun &two (left-outs right-outs)
	X  (prog (fp dp)
	X        (cond (*sendtocall*
	X               (setq fp *flag-part*)
	X               (setq dp *data-part*))
	X              (t
	X               (setq fp *alpha-flag-part*)
	X               (setq dp *alpha-data-part*)))
	X        (sendto fp dp 'left left-outs)
	X        (sendto fp dp 'right right-outs))) 
	X
	X(defun &mem (left-outs right-outs memory-list)
	X  (prog (fp dp)
	X        (cond (*sendtocall*
	X               (setq fp *flag-part*)
	X               (setq dp *data-part*))
	X              (t
	X               (setq fp *alpha-flag-part*)
	X               (setq dp *alpha-data-part*)))
	X        (sendto fp dp 'left left-outs)
	X        (add-token memory-list fp dp nil)
	X        (sendto fp dp 'right right-outs))) 
	X
	X(defun &and (outs lpred rpred tests)
	X  (prog (mem)
	X        (cond ((eq *side* 'right) (setq mem (memory-part lpred)))
	X              (t (setq mem (memory-part rpred))))
	X        (cond ((not mem) (return nil))
	X              ((eq *side* 'right) (and-right outs mem tests))
	X              (t (and-left outs mem tests))))) 
	X
	X(defun and-left (outs mem tests)
	X  (prog (fp dp memdp tlist tst lind rind res)
	X        (setq fp *flag-part*)
	X        (setq dp *data-part*)
	X   fail (and (null mem) (return nil))
	X        (setq memdp (car mem))
	X        (setq mem (cdr mem))
	X        (setq tlist tests)
	X   tloop (and (null tlist) (go succ))
	X        (setq tst (car tlist))
	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        ;the next line differs in and-left & -right
	X        (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
	X        (cond (res (go tloop))
	X              (t (go fail)))
	X   succ ;the next line differs in and-left & -right
	X        (sendto fp (cons (car memdp) dp) 'left outs)
	X        (go fail))) 
	X
	X(defun and-right (outs mem tests)
	X  (prog (fp dp memdp tlist tst lind rind res)
	X        (setq fp *flag-part*)
	X        (setq dp *data-part*)
	X   fail (and (null mem) (return nil))
	X        (setq memdp (car mem))
	X        (setq mem (cdr mem))
	X        (setq tlist tests)
	X   tloop (and (null tlist) (go succ))
	X        (setq tst (car tlist))
	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        ;the next line differs in and-left & -right
	X        (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
	X        (cond (res (go tloop))
	X              (t (go fail)))
	X   succ ;the next line differs in and-left & -right
	X        (sendto fp (cons (car dp) memdp) 'right outs)
	X        (go fail))) 
	X
	X
	X(defun teqb (new eqvar)
	X  (cond ((eq new eqvar) t)
	X        ((not (numberp new)) nil)
	X        ((not (numberp eqvar)) nil)
	X        ((=alg new eqvar) t)
	X        (t nil))) 
	X
	X(defun tneb (new eqvar)
	X  (cond ((eq new eqvar) nil)
	X        ((not (numberp new)) t)
	X        ((not (numberp eqvar)) t)
	X        ((=alg new eqvar) nil)
	X        (t t))) 
	X
	X(defun tltb (new eqvar)
	X  (cond ((not (numberp new)) nil)
	X        ((not (numberp eqvar)) nil)
	X        ((greaterp eqvar new) t)
	X        (t nil))) 
	X
	X(defun tgtb (new eqvar)
	X  (cond ((not (numberp new)) nil)
	X        ((not (numberp eqvar)) nil)
	X        ((greaterp new eqvar) t)
	X        (t nil))) 
	X
	X(defun tgeb (new eqvar)
	X  (cond ((not (numberp new)) nil)
	X        ((not (numberp eqvar)) nil)
	X        ((not (greaterp eqvar new)) t)
	X        (t nil))) 
	X
	X(defun tleb (new eqvar)
	X  (cond ((not (numberp new)) nil)
	X        ((not (numberp eqvar)) nil)
	X        ((not (greaterp new eqvar)) t)
	X        (t nil))) 
	X
	X(defun txxb (new eqvar)
	X  (cond ((numberp new)
	X         (cond ((numberp eqvar) t)
	X               (t nil)))
	X        (t
	X         (cond ((numberp eqvar) nil)
	X               (t t))))) 
	X
	X
	X(defun &p (rating name var-dope ce-var-dope rhs)
	X  (prog (fp dp)
	X        (cond (*sendtocall*
	X               (setq fp *flag-part*)
	X               (setq dp *data-part*))
	X              (t
	X               (setq fp *alpha-flag-part*)
	X               (setq dp *alpha-data-part*)))
	X        (and (member fp '(nil old)) (removecs name dp))
	X        (and fp (insertcs name dp rating)))) 
	X
	X(defun &old (a b c d e) nil) ;a null function used for deleting node
	X
	X(defun &not (outs lmem rpred tests)
	X  (cond ((and (eq *side* 'right) (eq *flag-part* 'old)) nil)
	X        ((eq *side* 'right) (not-right outs (car lmem) tests))
	X        (t (not-left outs (memory-part rpred) tests lmem)))) 
	X
	X(defun not-left (outs mem tests own-mem)
	X  (prog (fp dp memdp tlist tst lind rind res c)
	X        (setq fp *flag-part*)
	X        (setq dp *data-part*)
	X        (setq c 0.)
	X   fail (and (null mem) (go fin))
	X        (setq memdp (car mem))
	X        (setq mem (cdr mem))
	X        (setq tlist tests)
	X   tloop (and (null tlist) (setq c (1+ c)) (go fail))
	X        (setq tst (car tlist))
	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        ;the next line differs in not-left & -right
	X        (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
	X        (cond (res (go tloop))
	X              (t (go fail)))
	X   fin  (add-token own-mem fp dp c)
	X        (and (== c 0.) (sendto fp dp 'left outs)))) 
	X
	X(defun not-right (outs mem tests)
	X  (prog (fp dp memdp tlist tst lind rind res newfp inc newc)
	X        (setq fp *flag-part*)
	X        (setq dp *data-part*)
	X        (cond ((not fp) (setq inc -1.) (setq newfp 'new))
	X              ((eq fp 'new) (setq inc 1.) (setq newfp nil))
	X              (t (return nil)))
	X   fail (and (null mem) (return nil))
	X        (setq memdp (car mem))
	X        (setq newc (cadr mem))
	X        (setq tlist tests)
	X   tloop (and (null tlist) (go succ))
	X        (setq tst (car tlist))
	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        ;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* (delete inst *conflict-set* :test #'eq))))
	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* (delete best *conflict-set* :test #'eq))
	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* (delete entry *conflict-set* :test #'eq))
	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 (assoc p cnts :test #'eq))
	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 (member fa *wmpart-list* :test #'eq)
	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 (assoc wme part :test #'eq))
	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 (delete z part :test #'eq) '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(defmacro wm (&rest a) 
	X  `(progn
	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 (assoc wme (get (wm-hash wme) 'wmpart*) :test #'eq))) 
	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 (assoc x *variable-memory* :test #'eq))
	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 (assoc x *ce-variable-memory* :test #'eq))
	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 (round 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
	X(defmacro make(&rest z)
	X  `(prog nil
	X        ($reset)
	X        (eval-args ',z)
	X        ($assert))) 
	X
	X(defmacro modify (&rest z)
	X  `(prog (old args)
	X        (setq args ',z)
	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 args)))
	X        (cond ((null old)
	X               (%warn '|modify: first argument must be an element variable|
	X                        (car args))
	X               (return nil)))
	X        (remove-from-wm old)
	X        (setq args (cdr args))
	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 args)
	X        ($assert))) 
	X
	X(defmacro bind (&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(defmacro cbind (&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(defmacro oremove (&rest z)
	X  `(prog (old args)
	X        (setq args ',z)
	X	(and (not *in-rhs*)(return (top-level-remove args)))
	X   top  (and (atom args) (return nil))
	X        (setq old (get-ce-var-bind (car args)))
	X        (cond ((null old)
	X               (%warn '|remove: argument not an element variable| (car args))
	X               (return nil)))
	X        (remove-from-wm old)
	X        (setq args (cdr args))
	X        (go top))) 
	X
	X(defmacro ocall (&rest z)
	X  `(prog (f)
	X	(setq f (car ',z))
	X        ($reset)
	X        (eval-args (cdr ',z))
	X        (funcall f))) 
	X
	X(defmacro owrite (&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 (length (princ-to-string 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(defmacro build (&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(defmacro openfile (&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(defmacro closefile (&rest z)
	X  `(progn 
	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(defmacro default (&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 (member use '(write accept trace)))
	X	       (%warn '|default: illegal use for a file| use)
	X	       (return nil))
	X	      ((and (member 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(defmacro accept (&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(defmacro acceptline (&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 ((member (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 (member (tyipeek port) '(-1. 10.))) (go lp1)))))
	X
	X(defmacro substr (&rest l)
	X  `(prog (k elm start end)
	X        (cond ((not (= (length ',l) 3.))
	X               (%warn '|substr: wrong number of arguments| ',l)
-- 
---------------
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