;;; ****************************************************************
 ;;; OPS5 Interpreter ***********************************************
 ;;; ****************************************************************
 ;;; This Common Lisp version of OPS5 is in the public domain.  It is based
 ;;; in part on based on a Franz Lisp implementation done by Charles L. Forgy
 ;;; at Carnegie-Mellon University, which was placed in the public domain by
 ;;; the author in accordance with CMU policies.  Ported to Common Lisp by 
 ;;; George Wood and Jim Kowalski. CMU Common Lisp modifications by
 ;;; Dario Guise, Skef Wholey, Michael Parzen, and Dan Kuokka. 
 ;;; Modified to work in CLtL1, CLtL2 and X3J13 compatible lisps by 
 ;;; Mark Kantrowitz on 14-OCT-92.
 ;;; 
 ;;; This code is made available is, and without warranty of any kind by the
 ;;; authors or by Carnegie-Mellon University.
 ;;;
 
 ;;;; This file contains functions compile productions.
 
 (in-package "OPS")

 ;;(shadow '(remove write))    ; Should get this by requiring ops-rhs
 ;;(export '--> )

 
 
 ;;; External global variables
 

 (defvar *real-cnt* nil)
 (defvar *virtual-cnt* nil)
 (defvar *last-node* nil)
 (defvar *first-node* nil)
 (defvar *pcount* nil)

 
 
 ;;; Internal global variables
 

 (defvar *matrix* nil)
 (defvar *curcond* nil)
 (defvar *feature-count* nil)
 (defvar *ce-count* nil)
 (defvar *vars* nil)
 (defvar *ce-vars* nil)
 (defvar *rhs-bound-vars* nil)
 (defvar *rhs-bound-ce-vars* nil)
 (defvar *last-branch* nil)
 (defvar *subnum* nil)
 (defvar *cur-vars* nil)
 (defvar *action-type* nil)

 
 
 
 (defun compile-init ()
   (setq *real-cnt* (setq *virtual-cnt* 0.))
   (setq *pcount* 0.)
   (make-bottom-node))
 
 
 ;;; LHS Compiler
 
 (defun ops-p (z) 
   (finish-literalize)
   (princ '*) 

   ;;(drain) commented out temporarily

   (force-output)			;@@@ clisp drain?
   (compile-production (car z) (cdr z))) 
 
 
 (defun compile-production (name matrix)
   ;; jgk inverted args to catch and quoted tag
   (setq *p-name* name)
   (catch '!error! (cmp-p name matrix))
   (setq *p-name* nil))

 
 #+(or)

 (defun compile-production (name matrix) ;jgk inverted args to catch 
   (prog (erm)				;and quoted tag

      (setq *p-name* name)
      (setq erm (catch '!error! (cmp-p name matrix)))
      (setq *p-name* nil)))
 

 
 (defun peek-lex ()
   (car *matrix*)) 
 
 (defun lex ()
   (pop *matrix*)) 
 
 (defun end-of-p () (atom *matrix*)) 
 
 (defun rest-of-p () *matrix*) 
 
 (defun prepare-lex (prod) (setq *matrix* prod)) 
 
 
 (defun peek-sublex () (car *curcond*)) 
 
 (defun sublex ()
   (pop *curcond*)) 
 
 (defun end-of-ce () (atom *curcond*)) 
 
 (defun rest-of-ce () *curcond*) 
 
 (defun prepare-sublex (ce) (setq *curcond* ce)) 
 
 (defun make-bottom-node ()
   (setq *first-node* (list '&bus nil))) 
 
 (defun cmp-p (name matrix)
   (prog (m bakptrs)

      (cond ((or (null name) (consp  name))	;dtpr\consp gdw
             (%error '|illegal production name| name))
            ((equal (gethash name *production-table*) matrix)
             (return nil)))
      (prepare-lex matrix)
      (excise-p name)
      (setq bakptrs nil)
      (incf *pcount*)		;"plus" changed to "+" by gdw
      (setq *feature-count* 0.)
      (setq *ce-count* 0)
      (setq *vars* nil)
      (setq *ce-vars* nil)
      (setq *rhs-bound-vars* nil)
      (setq *rhs-bound-ce-vars* nil)
      (setq *last-branch* nil)
      (setq m (rest-of-p))
    l1   (and (end-of-p) (%error '|no '-->' in production| m))
      (cmp-prin)
      (setq bakptrs (cons *last-branch* bakptrs))
      (or (eq '--> (peek-lex)) (go l1))
      (lex)
      (check-rhs (rest-of-p))
      (link-new-node (list '&p
                           *feature-count*
                           name
                           (encode-dope)
                           (encode-ce-dope)
                           (cons 'progn (rest-of-p))))
      (setf (gethash name *backpointers-table*) (cdr (nreverse bakptrs)))
      (setf (gethash name *production-table*) matrix)
      (setf (gethash name *topnode-table*) *last-node*))) 

 
 (defun rating-part (pnode) (cadr pnode)) 
 
 (defun var-part (pnode) (car (cdddr pnode))) 
 
 (defun ce-var-part (pnode) (cadr (cdddr pnode))) 
 
 (defun rhs-part (pnode) (caddr (cdddr pnode))) 
 
 (defun cmp-prin nil
   (setq *last-node* *first-node*)
   (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta))

         ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
         (t (cmp-posce) (cmp-and)))) 

 
 (defun cmp-negce nil (lex) (cmp-ce)) 
 
 (defun cmp-posce nil
   (setq *ce-count* (1+ *ce-count*))		;"plus" changed to "+" by gdw
   (cond ((eq (peek-lex) '\{) (cmp-ce+cevar))	;"plus" changed to "+" by gdw

         (t (cmp-ce)))) 

 
 (defun cmp-ce+cevar ()
   (prog (z)

      (lex)
      (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
            (t (cmp-ce) (cmp-cevar)))
      (setq z (lex))
      (or (eq z '\}) (%error '|missing '}'| z)))) 

 
 (defun new-subnum (k)
   (or (numberp k) (%error '|tab must be a number| k))
   (setq *subnum* (floor k))) 
 
 (defun incr-subnum ()
   (incf *subnum*)) 
 
 (defun cmp-ce ()
   (prog (z)

      (new-subnum 0.)
      (setq *cur-vars* nil)
      (setq z (lex))
      (and (atom z)
           (%error '|atomic conditions are not allowed| z))
      (prepare-sublex z)
    la   (and (end-of-ce) (return nil))
      (incr-subnum)
      (cmp-element)
      (go la))) 

 
 (defun cmp-element nil
   (when (eq (peek-sublex) '^)
     (cmp-tab))
   (cond ((eq (peek-sublex) '\{) (cmp-product))

         (t (cmp-atomic-or-any))))

 
 (defun cmp-atomic-or-any ()
   (cond ((eq (peek-sublex) '<<) (cmp-any))

         (t (cmp-atomic))))

 
 (defun cmp-any ()
   (prog (a z)

      (sublex)
      (setq z nil)
    la   (cond ((end-of-ce) (%error '|missing '>>'| a)))
      (setq a (sublex))
      (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
      (link-new-node (list '&any nil (current-field) z)))) 

 
 (defun cmp-tab nil
   (prog (r)

      (sublex)
      (setq r (sublex))
      (setq r ($litbind r))
      (new-subnum r))) 

 
 (defun get-bind (x)
   (when (symbolp x)
     (literal-binding-of x))) 
 
 (defun cmp-atomic nil
   (prog (test x)

      (setq x (peek-sublex))
      (cond ((eq x '= ) (setq test 'eq) (sublex))
            ((eq x '<>) (setq test 'ne) (sublex))
            ((eq x '<) (setq test 'lt) (sublex))
            ((eq x '<=) (setq test 'le) (sublex))
            ((eq x '>) (setq test 'gt) (sublex))
            ((eq x '>=) (setq test 'ge) (sublex))
            ((eq x '<=>) (setq test 'xx) (sublex))
            (t (setq test 'eq)))
      (cmp-symbol test))) 

 
 (defun cmp-product ()
   (prog (save)

      (setq save (rest-of-ce))
      (sublex)
    la   (cond ((end-of-ce)
                (cond ((member '\} save :test #'equal) 
                       (%error '|wrong contex for '}'| save))
                      (t (%error '|missing '}'| save))))
               ((eq (peek-sublex) '\}) (sublex) (return nil)))
      (cmp-atomic-or-any)
      (go la))) 

 
 (defun cmp-symbol (test)
   (let ((flag t))
     (when (eq (peek-sublex) '//)
       (sublex)
       (setq flag nil))
     (cond ((and flag (variablep (peek-sublex)))

            (cmp-var test))
           ((numberp (peek-sublex)) (cmp-number test))
           ((symbolp (peek-sublex)) (cmp-constant test))
           (t (%error '|unrecognized symbol| (sublex)))))) 

 
 (defun cmp-constant (test)   ;jgk inserted concatenate form
   (or (member test '(eq ne xx))
       (%error '|non-numeric constant after numeric predicate| (sublex)))
   (link-new-node (list (intern (concatenate 'string

                                             "T"
                                             (symbol-name  test)
                                             "A"))
                        nil
                        (current-field)
                        (sublex)))) 

 
 (defun cmp-number (test)		;jgk inserted concatenate form
   (link-new-node (list (intern (concatenate 'string

                                             "T"
                                             (symbol-name  test)
                                             ;;@@@ error? reported by laird fix\	    "A"
                                             "N"))
                        nil
                        (current-field)
                        (sublex)))) 

 
 (defun current-field () (field-name *subnum*)) 
 
 (defun field-name (num)
   (if (< 0 num 127)
       (svref '#(nil *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9* *c10* *c11*

                 *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19* *c20* *c21*
                 *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29* *c30* *c31*
                 *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39* *c40* *c41*
                 *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49* *c50* *c51*
                 *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59* *c60* *c61*
                 *c62* *c63* *c64* *c65* *c66* *c67* *c68* *c69* *c70* *c71*
                 *c72* *c73* *c74* *c75* *c76* *c77* *c78* *c79* *c80* *c81*
                 *c82* *c83* *c84* *c85* *c86* *c87* *c88* *c89* *c90* *c91*
                 *c92* *c93* *c94* *c95* *c96* *c97* *c98* *c99* *c100*
                 *c101* *c102* *c103* *c104* *c105* *c106* *c107* *c108*
                 *c109* *c110* *c111* *c112* *c113* *c114* *c115* *c116*
                 *c117* *c118* *c119* *c120* *c121* *c122* *c123* *c124*
                 *c125* *c126* *c127*)
              num)

       (%error '|condition is too long| (rest-of-ce))))
 
 ;;; Compiling variables

 ;;
 ;;
 ;;
 ;; *cur-vars* are the variables in the condition element currently 
 ;; being compiled.  *vars* are the variables in the earlier condition
 ;; elements.  *ce-vars* are the condition element variables.  note
 ;; that the interpreter will not confuse condition element and regular
 ;; variables even if they have the same name.
 ;;
 ;; *cur-vars* is a list of triples: (name predicate subelement-number)
 ;; eg:		( (<x> eq 3)
 ;;		  (<y> ne 1)
 ;;		  . . . )
 ;;
 ;; *vars* is a list of triples: (name ce-number subelement-number)
 ;; eg:		( (<x> 3 3)
 ;;		  (<y> 1 1)
 ;;		  . . . )
 ;;
 ;; *ce-vars* is a list of pairs: (name ce-number)
 ;; eg:		( (ce1 1)
 ;;		  (<c3> 3)
 ;;		  . . . )

 
 ;;; used only in this file.
 (defmacro var-dope (var) `(assoc ,var *vars*))
 
 (defmacro ce-var-dope (var) `(assoc ,var *ce-vars*))
 
 (defun cmp-var (test)
   (let* ((name (sublex))

          (old (assoc name *cur-vars*)))

     (cond ((and old (eq (cadr old) 'eq))

            (cmp-old-eq-var test old))
           ((and old (eq test 'eq)) (cmp-new-eq-var name old))
           (t (cmp-new-var name test))))) 

 
 (defun cmp-new-var (name test)
   (push (list name test *subnum*) 

         *cur-vars*)) 

 
 (defun cmp-old-eq-var (test old)	; jgk inserted concatenate form
   (link-new-node (list (intern (concatenate 'string

                                             "T"
                                             (symbol-name  test)
                                             "S"))
                        nil
                        (current-field)
                        (field-name (caddr old))))) 

 
 (defun cmp-new-eq-var (name old)	;jgk inserted concatenate form
   (prog (pred next)

      (setq *cur-vars* (delete old *cur-vars* :test #'eq))
      (setq next (assoc name *cur-vars*))
      (cond (next (cmp-new-eq-var name next))
            (t (cmp-new-var name 'eq)))
      (setq pred (cadr old))
      (link-new-node (list (intern (concatenate 'string
                                                "T"
                                                (symbol-name  pred)
                                                "S"))
                           nil
                           (field-name (caddr old))
                           (current-field))))) 

 
 (defun cmp-cevar nil
   (let* ((name (lex))

          (old (assoc name *ce-vars*)))

     (when old
       (%error '|condition element variable used twice| name))
     (push (list name 0.) 

           *ce-vars*))) 

 
 (defun cmp-not nil (cmp-beta '&not)) 
 
 (defun cmp-nobeta nil (cmp-beta nil)) 
 
 (defun cmp-and nil (cmp-beta '&and)) 
 
 (defun cmp-beta (kind)
   (prog (tlist vdope vname #|vpred vpos|# old)

      (setq tlist nil)
    la   (and (atom *cur-vars*) (go lb))
      (setq vdope (car *cur-vars*))
      (setq *cur-vars* (cdr *cur-vars*))
      (setq vname (car vdope))
      ;;  (setq vpred (cadr vdope))    Dario - commented out (unused)
      ;;  (setq vpos (caddr vdope))
      (setq old (assoc vname *vars*))
      (cond (old (setq tlist (add-test tlist vdope old)))
            ((not (eq kind '&not)) (promote-var vdope)))
      (go la)
    lb   (and kind (build-beta kind tlist))
      (or (eq kind '&not) (fudge))
      (setq *last-branch* *last-node*))) 

 
 (defun add-test (list new old) ; jgk inserted concatenate form
   (prog (ttype lloc rloc)

      (incf *feature-count*)
      (setq ttype (intern (concatenate 'string "T"
                                       (symbol-name (cadr new))
                                       "B")))
      (setq rloc (encode-singleton (caddr new)))
      (setq lloc (encode-pair (cadr old) (caddr old)))
      (return (cons ttype (cons lloc (cons rloc list)))))) 

 ;; the following two functions encode indices so that gelm can
 ;; decode them as fast as possible

 
 (defun encode-pair (a b) (+ (* 10000. (1- a)) (1- b))) 

 ;;"plus" changed to "+" by gdw

 
 (defun encode-singleton (a) (1- a)) 
 
 (defun promote-var (dope)
   (prog (vname vpred vpos new)

      (setq vname (car dope))
      (setq vpred (cadr dope))
      (setq vpos (caddr dope))
      (or (eq 'eq vpred)
          (%error '|illegal predicate for first occurrence|
                  (list vname vpred)))
      (setq new (list vname 0. vpos))
      (setq *vars* (cons new *vars*)))) 

 
 (defun fudge nil
   (mapc #'fudge* *vars*)
   (mapc #'fudge* *ce-vars*)) 
 
 (defun fudge* (z)
   (let ((a (cdr z)))
     (incf (car a)))) 
 
 (defun build-beta (type tests)
   (prog (rpred lpred lnode lef)

      (link-new-node (list '&mem nil nil (protomem)))
      (setq rpred *last-node*)
      (cond ((eq type '&and)
             (setq lnode (list '&mem nil nil (protomem))))
            (t (setq lnode (list '&two nil nil))))
      (setq lpred (link-to-branch lnode))
      (cond ((eq type '&and) (setq lef lpred))
            (t (setq lef (protomem))))
      (link-new-beta-node (list type nil lef rpred tests)))) 

 
 (defun protomem nil (list nil)) 
 
 (defun memory-part (mem-node) (car (cadddr mem-node))) 
 
 (defun encode-dope nil
   (prog (r all z k)

      (setq r nil)
      (setq all *vars*)
    la   (and (atom all) (return r))
      (setq z (car all))
      (setq all (cdr all))
      (setq k (encode-pair (cadr z) (caddr z)))
      (setq r (cons (car z) (cons k r)))
      (go la))) 

 
 (defun encode-ce-dope nil
   (prog (r all z k)

      (setq r nil)
      (setq all *ce-vars*)
    la   (and (atom all) (return r))
      (setq z (car all))
      (setq all (cdr all))
      (setq k (cadr z))
      (setq r (cons (car z) (cons k r)))
      (go la))) 

 
 
 
 ;;; Linking the nodes
 
 (defun link-new-node (r)
   (cond ((not (member (car r) '(&p &mem &two &and &not) :test #'equal))

          (setq *feature-count* (1+ *feature-count*))))

   (setq *virtual-cnt* (1+ *virtual-cnt*))
   (setq *last-node* (link-left *last-node* r))) 
 
 (defun link-to-branch (r)
   (setq *virtual-cnt* (1+ *virtual-cnt*))
   (setq *last-branch* (link-left *last-branch* r))) 
 
 (defun link-new-beta-node (r)
   (setq *virtual-cnt* (1+ *virtual-cnt*))
   (setq *last-node* (link-both *last-branch* *last-node* r))
   (setq *last-branch* *last-node*)) 
 
 (defun link-left (pred succ)
   (prog (a r)

      (setq a (left-outs pred))
      (setq r (find-equiv-node succ a))
      (and r (return r))
      (setq *real-cnt* (1+ *real-cnt*))
      (attach-left pred succ)
      (return succ))) 

 
 (defun link-both (left right succ)
   (prog (a r)

      (setq a (intersection (left-outs left) (right-outs right)))
      (setq r (find-equiv-beta-node succ a))
      (and r (return r))
      (setq *real-cnt* (1+ *real-cnt*))
      (attach-left left succ)
      (attach-right right succ)
      (return succ))) 

 
 (defun attach-right (old new)
   (rplaca (cddr old) (cons new (caddr old)))) 
 
 (defun attach-left (old new)
   (rplaca (cdr old) (cons new (cadr old)))) 
 
 (defun right-outs (node) (caddr node)) 
 
 (defun left-outs (node) (cadr node)) 
 
 (defun find-equiv-node (node list)
   (prog (a)

      (setq a list)
    l1   (cond ((atom a) (return nil))
               ((equiv node (car a)) (return (car a))))
      (setq a (cdr a))
      (go l1))) 

 
 (defun find-equiv-beta-node (node list)
   (prog (a)

      (setq a list)
    l1   (cond ((atom a) (return nil))
               ((beta-equiv node (car a)) (return (car a))))
      (setq a (cdr a))
      (go l1))) 

 ;; do not look at the predecessor fields of beta nodes; they have to be
 ;; identical because of the way the candidate nodes were found

 
 (defun equiv (a b)
   (and (eq (car a) (car b))
        (or (eq (car a) '&mem)

            (eq (car a) '&two)
            (equal (caddr a) (caddr b)))

        (equal (cdddr a) (cdddr b)))) 
 
 (defun beta-equiv (a b)
   (and (eq (car a) (car b))
        (equal (cddddr a) (cddddr b))
        (or (eq (car a) '&and) (equal (caddr a) (caddr b))))) 
 

 ;; the equivalence tests are set up to consider the contents of
 ;; node memories, so they are ready for the build action

 
 
 
 ;;; Check the RHSs of productions 
 
 
 (defun check-rhs (rhs) (mapc #'check-action rhs))
 
 (defun check-action (x)
   (if (atom x)
       (%warn '|atomic action| x)
       (let ((a (car x)))

         (setq *action-type* a)
         (case a
           (bind (check-bind x))
           (cbind (check-cbind x))
           (make (check-make x))
           (modify (check-modify x))
           (remove (check-remove x))
           (write (check-write x))	
           (call (check-call x))		
           (halt (check-halt x))
           (openfile (check-openfile x))
           (closefile (check-closefile x))
           (default (check-default x))
           (build (check-build x))
           (t (%warn '|undefined rhs action| a))))))
 
 
 ;;(defun chg-to-write (x)
 ;;	(setq x (cons 'write (cdr x))))

 
 (defun check-build (z)
   (when (null (cdr z))
     (%warn '|needs arguments| z))
   (check-build-collect (cdr z)))
 
 (defun check-build-collect (args)
   (prog (r)

    top	(and (null args) (return nil))
      (setq r (car args))
      (setq args (cdr args))
      (cond ((consp  r) (check-build-collect r))	;dtpr\consp gdw
            ((eq r '\\)
             (and (null args) (%warn '|nothing to evaluate| r))
             (check-rhs-value (car args))
             (setq args (cdr args))))
      (go top)))

 
 (defun check-remove (z) 				;@@@ kluge by gdw
   (when (null (cdr z))
     (%warn '|needs arguments| z))
   (mapc (function check-rhs-ce-var) (cdr z))) 
 

 ;;(defun check-remove (z) 					;original
 ;; (and (null (cdr z)) (%warn '|needs arguments| z))
 ;;(mapc (function check-rhs-ce-var) (cdr z))) 

 
 (defun check-make (z)
   (when (null (cdr z))
     (%warn '|needs arguments| z))
   (check-change& (cdr z))) 
 
 (defun check-openfile (z)
   (when (null (cdr z))
     (%warn '|needs arguments| z))
   (check-change& (cdr z))) 
 
 (defun check-closefile (z)
   (when (null (cdr z))
     (%warn '|needs arguments| z))
   (check-change& (cdr z))) 
 
 (defun check-default (z)
   (when (null (cdr z))
     (%warn '|needs arguments| z))
   (check-change& (cdr z))) 
 
 (defun check-modify (z)
   (when (null (cdr z))
     (%warn '|needs arguments| z))
   (check-rhs-ce-var (cadr z))
   (when (null (cddr z))
     (%warn '|no changes to make| z))
   (check-change& (cddr z))) 
 
 (defun check-write (z)				;note this works w/write
   (when (null (cdr z))
     (%warn '|needs arguments| z))
   (check-change& (cdr z))) 
 
 (defun check-call (z)
   (when (null (cdr z))
     (%warn '|needs arguments| z))
   (let ((f (cadr z)))
     (when (variablep f)
       (%warn '|function name must be a constant| z))
     (unless (symbolp f)
       (%warn '|function name must be a symbolic atom| f))
     (unless (externalp f)
       (%warn '|function name not declared external| f))
     (check-change& (cddr z)))) 
 
 (defun check-halt (z)
   (unless (null (cdr z))
     (%warn '|does not take arguments| z))) 
 
 (defun check-cbind (z)
   (unless (= (length z) 2.)
     (%warn '|takes only one argument| z))
   (let ((v (cadr z)))
     (unless (variablep v)
       (%warn '|takes variable as argument| z))
     (note-ce-variable v))) 
 
 (defun check-bind (z)
   (unless (> (length z) 1.)
     (%warn '|needs arguments| z))
   (let ((v (cadr z)))
     (unless (variablep v)
       (%warn '|takes variable as argument| z))
     (note-variable v)
     (check-change& (cddr z)))) 
 
 (defun check-change& (z)
   (prog (r tab-flag)

      (setq tab-flag nil)
    la   (and (atom z) (return nil))
      (setq r (car z))
      (setq z (cdr z))
      (cond ((eq r '^)
             (and tab-flag
                  (%warn '|no value before this tab| (car z)))
             (setq tab-flag t)
             (check-tab-index (car z))
             (setq z (cdr z)))
            ((eq r '//) (setq tab-flag nil) (setq z (cdr z)))
            (t (setq tab-flag nil) (check-rhs-value r)))
      (go la))) 

 
 (defun check-rhs-ce-var (v)
   (cond ((and (not (numberp v)) (not (ce-bound? v)))

          (%warn '|unbound element variable| v))
         ((and (numberp v) (or (< v 1.) (> v *ce-count*)))
          (%warn '|numeric element designator out of bounds| v)))) 

 
 (defun check-rhs-value (x)
   (if (consp x)				;dtpr\consp gdw 
       (check-rhs-function x)
       (check-rhs-atomic x))) 
 
 (defun check-rhs-atomic (x)
   (when (and (variablep x) 

              (not (bound? x)))

     (%warn '|unbound variable| x)))
 
 (defun check-rhs-function (x)
   (let ((a (car x)))
     (case a
       (compute (check-compute x))
       (arith (check-compute x))
       (substr (check-substr x))
       (accept (check-accept x))
       (acceptline (check-acceptline x))
       (crlf (check-crlf x))
       (genatom (check-genatom x))
       (litval (check-litval x))
       (tabto (check-tabto x))
       (rjust (check-rjust x))
       (otherwise 
        (when (not (externalp a))

          (%warn '"rhs function not declared external" a))))))

 
 (defun externalp (x)

   ;;  (cond ((symbolp x) (gethash x *external-routine-table*)) 	;) @@@
   ;;ok, I'm eliminating this temporarily @@@@

   (cond ((symbolp x) t)

         (t (%warn '|not a legal function name| x) nil)))

 
 (defun check-litval (x) 
   (unless (= (length x) 2)
     (%warn '|wrong number of arguments| x))
   (check-rhs-atomic (cadr x)))
 
 (defun check-accept (x)
   (cond ((= (length x) 1) nil)

         ((= (length x) 2) (check-rhs-atomic (cadr x)))
         (t (%warn '|too many arguments| x))))

 
 (defun check-acceptline (x)
   (mapc #'check-rhs-atomic (cdr x)))
 
 (defun check-crlf (x) 
   (check-0-args x)) 
 
 (defun check-genatom (x) (check-0-args x)) 
 
 (defun check-tabto (x)
   (unless (= (length x) 2)
     (%warn '|wrong number of arguments| x))
   (check-print-control (cadr x)))
 
 (defun check-rjust (x)
   (unless (= (length x) 2)
     (%warn '|wrong number of arguments| x))
   (check-print-control (cadr x)))
 
 (defun check-0-args (x)
   (unless (= (length x) 1.)
     (%warn '|should not have arguments| x))) 
 
 (defun check-substr (x)
   (unless (= (length x) 4.)
     (%warn '|wrong number of arguments| x))
   (check-rhs-ce-var (cadr x))
   (check-substr-index (caddr x))
   (check-last-substr-index (cadddr x))) 
 
 (defun check-compute (x) (check-arithmetic (cdr x))) 
 
 (defun check-arithmetic (l)
   (cond ((atom l)

          (%warn '|syntax error in arithmetic expression| l))
         ((atom (cdr l)) (check-term (car l)))
         ;; "plus" changed to "+" by gdw 
         ;; "quotient" added by mk, for backward compatability with the
         ;; old definition of //.
         ((not (member (cadr l) '(+ - * // \\ quotient)))	
          (%warn '|unknown operator| l))
         (t (check-term (car l)) (check-arithmetic (cddr l))))) 

 
 (defun check-term (x)
   (if (consp x)				;dtpr\consp gdw
       (check-arithmetic x)
       (check-rhs-atomic x))) 
 
 (defun check-last-substr-index (x)
   (or (eq x 'inf) (check-substr-index x))) 
 
 (defun check-substr-index (x)
   (if (bound? x) x
       (let ((v ($litbind x)))

         (cond ((not (numberp v))
                (%warn '|unbound symbol used as index in substr| x))
               ((or (< v 1.) (> v 127.))
                (%warn '|index out of bounds in tab| x)))))) 

 
 (defun check-print-control (x)
   (cond ((bound? x) x)

         ((or (not (numberp x)) (< x 1.) (> x 127.))
          (%warn '|illegal value for printer control| x)))) 

 
 (defun check-tab-index (x)
   (if (bound? x) x
       (let ((v ($litbind x)))

         (cond ((not (numberp v))
                (%warn '|unbound symbol occurs after ^| x))
               ((or (< v 1.) (> v 127.))
                (%warn '|index out of bounds after ^| x)))))) 

 
 (defun note-variable (var)
   (push var *rhs-bound-vars*))
 
 (defun bound? (var)
   (or (member var *rhs-bound-vars*)
       (var-dope var)))
 
 (defun note-ce-variable (ce-var)
   (push ce-var *rhs-bound-ce-vars*))
 
 (defun ce-bound? (ce-var)
   (or (member ce-var *rhs-bound-ce-vars*)
       (ce-var-dope ce-var)))
 
 ;;; *EOF*