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 2 of 9)
Message-ID: <795@imagen.UUCP>
Date: Sun, 18-Jan-87 22:42:10 EST
Article-I.D.: imagen.795
Posted: Sun Jan 18 22:42:10 1987
Date-Received: Mon, 19-Jan-87 20:35:36 EST
Organization: The Houses of the Holy
Lines: 1516
Keywords: ai,source


	X; ((p-name . data-part) (sorted wm-recency) special-case-number)
	X
	X;I'm storing the results of the pattern matches on a property list, pmatches. 
	X
	X;modified OPS5 removecs
	X;remove results of the pattern match
	X
	X(defun ipm-removepm (name cr-data)
	X  (prog (inst cs pmtchs)
	X(setq pmtchs (setq cs (get name 'pmatches)))
	X  l(cond ((null cs) 
	X               (return nil)))
	X(setq inst (car cs))
	X(setq cs (cdr cs))
	X(and (not (top-levels-eq inst cr-data)) (go l))
	X(putprop name (remove inst pmtchs)
	X      'pmatches)
	X))
	X
	X;modified OPS5 insertcs
	X;store the results of the pattern match
	X;Stored as (data ) rather than original conflict set format 
	X;of ((name . data) (order tags) rating)

	X(defun ipm-insertpm (name data)
	X  (let ((pmtch (get name 'pmatches)))
	X    (setq pmtch (get name 'pmatches))
	X    (and (atom pmtch) (setq pmtch nil))
	X    (setq pmtch (cons data pmtch))
	X    (putprop name pmtch 'pmatches)
	X     pmtch
	X    )) 
	X
	X;PMATCH is the RHS/LISP equivalent of the (p rule) macro. When used from Lisp,
	X;it should always be preceded by the ? read macro, so as to force evaluation
	X;at read time.  Otherwise, the Rete net won't be set up correctly.
	X
	X(defmacro pmatch(&rest z) 
	X  `(let ((pname (newsym query))
	X         (level (newsym level)))
	X    (finish-literalize)
	X    (princ '*) 
	X    (cond ((and (listp (car ',z)) (eq (caar ',z) 'args))
	X           (ipm-compile-production pname (add-data-to-prod pname ',z ))
	X  `(let ((tt  (make-ipm-data ',pname ,@(cdar ',z) )) 
	X         (ans (query ',pname)))
	X(restore-ipm-data tt)
	X                ans))
	X  (t 
	X   (ipm-compile-production pname ',z)
	X   `(query ',pname)))))
	X
	X(defun restore-ipm-data(current)
	X   (let ((inrhsflg *in-rhs*)
	X (old (pop *ipm-data-stack*)))
	X       (setq *in-rhs* nil)
	X       (eval (list 'oremove current))
	X       (setq *in-rhs* inrhsflg)
	X       (if old
	X   (add-to-wm (car old) (cdr old)))))
	X   
	X;Note, the only way to pass input to the pattern matcher is to create a 
	X;working memory element containing that input.  The following utility functions
	X;automagically create the ipm$data working memory element and modify the 
	X;production to use it.
	X
	X;MAKE-DATA:  Make data takes a list of values and a unique level specifier
	X;and creates a working memory element of the form (ipm$data val1 val2 val3 .. )
	X;Saves old ipm$data elements on stack so that no interference results.
	X(defun make-ipm-data(&rest arglst)
	X (let ((inrhsflg *in-rhs*)
	X       (old (car (get 'ipm$data 'wmpart*))))
	X   (if old (push old *ipm-data-stack*))
	X   (setq *in-rhs* nil)
	X   (eval (list 'oremove (cdr old))) ;needs in-rhs to be nil
	X   (setq *in-rhs* inrhsflg)
	X   ($reset)
	X   ($change 'ipm$data)
   (mapc #'(lambda(tab val)
	X         ($tab tab)
	X         ($change val)) 
	X       '(a b c d e f g h i j k l) (cdr arglst))
	X   ($tab 'for) ;target data for particular query
	X   ($change (car arglst)) 
	X   ($assert)))
	X
	X;Modify the production so that it accesses the data passed by the ipm$data wme
	X(defun add-data-to-prod(pname prod)
	X    (let ((args (cdar prod))
	X  (body (cdr prod)))
	X     (cons 
	X       `(ipm$data ,@(mapcan #'(lambda(slot arg) (list  '^ slot (concat '\< arg '\> ))) 
	X        '(a b c d e f g h i j k l) args) 
	X       ^for ,pname)
	X       body)))
	X 
	X
	X;Finish-literalize: modified to define special wme type ipm$data which is used to 
	X;transfer lisp arguments to working memory.
	X(defun finish-literalize nil
	X  (cond ((not (null *class-list*))
	X         (cond ((not (member 'ipm$data *class-list*))
	X             (literalize ipm$data a b c d e f g h i j k l for)))
	X         (mapc (function note-user-assigns) *class-list*)
	X         (mapc (function assign-scalars) *class-list*)
	X         (mapc (function assign-vectors) *class-list*)
	X         (mapc (function put-ppdat) *class-list*)
	X         (mapc (function erase-literal-info) *class-list*)
	X         (setq *class-list* nil)
	X         (setq *buckets* nil)))) 
	X
	X
	X
	X;Map the RHS across all matching data.
	X(defmacro map-pmatch(&rest z) 
	X  `(let ((pname (newsym query))
	X         (level (newsym level)))
	X    (finish-literalize)
	X    (princ '*) 
	X    (cond ((and (listp (car ',z)) (eq (caar ',z) 'args))
	X           (ipm-compile-production pname (add-data-to-prod pname ',z ))
	X  `(let ((tt  (make-ipm-data ',pname ,@(cdar ',z) )) 
	X         (ans (map-query ',pname)))
	X(restore-ipm-data tt)
	Xans))
	X  (t 
	X   (ipm-compile-production pname ',z)
	X   `(map-query ',pname)))))
	X
	X
	X(defun ipm-compile-production (name matrix)
	X  (prog (erm)
	X        (setq *p-name* name)
(cond (*compiling-rhs*
	X               (setq erm (catch (ipm-cmp-p-recursive name matrix) '!error!)))
	X      (t
	X               (setq erm (catch (ipm-cmp-p name matrix) '!error!))))
	X; following line is modified to save production name on *qnames*
	X        (pushnew name *qnames*)
	X(return erm)))
	X
	X
	X;save globals *feature-count *ce-count* *vars* *ce-vars* *rhs-bound-vars*
	X;*rhs-bound-ce-vars* *last-branch* on a push-down stack.
	X
	X;Push global variables takes a stack name, and a list of global variables, creates a 
	X;list of lists of the form ((varname value) (varname value) ... ) and pushes it onto
	X;the indicated stack.
	X
	X(defun push-global-variables(stack &rest vars)
	X    (push
	X      (mapcar #'(lambda(var)
	X                  (cons var (eval var)))  ;copy may not be needed, but better safe....
	X               vars)
	X      (symbol-value stack)))
	X
	X;Pop global variables takes a stack name, pops most recent entry off the stack,
	X;and resets the values of the variables.
	X(defun pop-global-variables(stack)
	X   (mapcar #'(lambda(varbinding)
	X                (set (car varbinding) (cdr varbinding)))
	X           (pop stack))  )
	X
	X
	X;This version of cmp-p is used when compiling patterns on the 
	X;righthand side in which we want variable bindings consistent
	X;with variable bindings on the LHS.  Effectively, the RHS 
	X;pattern is just treated as a continuation of the LHS 
	X;pattern, except, of course, that the results of the RHS 
	X;pattern match will not affect the firing of the production.
	X(defun ipm-cmp-p-recursive (name matrix)
	X  (prog (m bakptrs srhs frhs)
	X  (push-global-variables '*cmp-p-context-stack* '*matrix*
	X      '*feature-count* '*ce-count* 
	X      '*vars* '*ce-vars*
	X      '*rhs-bound-vars* '*rhs-bound-ce-vars*
	X      '*last-branch* '*last-node*)
	X        (prepare-lex matrix)
	X(setq *rhs-bound-vars* nil)
	X(setq *rhs-bound-ce-vars* nil)
	X        (setq m (rest-of-p))
	X   l1   (and (end-of-p) (\%error '|no '-->' in production| m))
	X        (cmp-prin)
	X        (setq bakptrs (cons *last-branch* bakptrs))
	X        (or (eq '--> (peek-lex)) (go l1))
	X        (lex)
	X(setq srhs (rest-of-p)) ; get righthand side
	X(if (setq frhs (cdr (memq '<-- srhs))) 
    (setq srhs (remove-frhs srhs)))
	X(ipm-check-rhs srhs)
	X;note, we change the structure of the &query node to have a tail
	X;component.  This is the action to take on a failed pattern match
	X        (link-new-node (list '&query
	X                             *feature-count*
	X     name
	X                             (encode-dope)
	X                             (encode-ce-dope)
	X                             (cons 'progn srhs)
	X     (cons 'progn frhs)))
	X        (putprop name (cdr (nreverse bakptrs)) 'backpointers)
	X(putprop name matrix 'production)
	X        (putprop name *last-node* 'topnode)
	X(pop-global-variables *cmp-p-context-stack*)
	X))
	X
	X;Extract failed pattern match rhs actions from production.
	X(defun remove-frhs(rhs)
	X   (do ((lis nil (append lis (list inp))) 
	X(inp (car rhs) (car rhs)))
	X       ((eq inp '<--)
	X(return lis))
	X      (setq rhs (cdr rhs))
	X       ))
	X
	X;;Modified version of OPS5 cmp-p, compiles pattern match and links
	X;&query node into Rete net. If pmatch occurs in the righthand side of the rule, then
	X;nodes are linked to tree generated by rule's LHS.
	X(defun ipm-cmp-p (name matrix)
	X  (prog (m bakptrs srhs frhs)
	X        (prepare-lex matrix)
	X        (excise-p name)
	X        (setq bakptrs nil)
	X        (setq *pcount* (1+ *pcount*))
	X        (setq *feature-count* 0.)
	X(setq *ce-count* 0)
	X        (setq *vars* nil)
	X        (setq *ce-vars* nil)
	X(setq *rhs-bound-vars* nil)
	X(setq *rhs-bound-ce-vars* nil)
	X        (setq *last-branch* nil)
	X        (setq m (rest-of-p))
	X   l1   (and (end-of-p) (\%error '|no '-->' in production| m))
	X        (cmp-prin)
	X        (setq bakptrs (cons *last-branch* bakptrs))
	X        (or (eq '--> (peek-lex)) (go l1))
	X        (lex)
	X(setq srhs (rest-of-p)) ; get righthand side
	X(if (setq frhs (cdr (memq '<-- srhs))) 
	X    (setq srhs (remove-frhs srhs)))
	X(ipm-check-rhs srhs)
	X;note, we change the structure of the &query node to have a tail
	X;component.  This is the action to take on a failed pattern match
	X        (link-new-node (list '&query
                             *feature-count*
	X                             name
	X                             (encode-dope)
	X                             (encode-ce-dope)
	X                             (cons 'progn srhs)
	X     (cons 'progn frhs)))
	X(terpri)
	X        (putprop name (cdr (nreverse bakptrs)) 'backpointers)
	X(putprop name matrix 'production)
	X        (putprop name *last-node* 'topnode))) 
	X
	X;Modified OPS5 code, sets *compiling-rhs* variable.
	X(defun check-rhs (rhs) 
	X    (setq *compiling-rhs* t)
	X    (mapc (function check-action) rhs)
	X    (setq *compiling-rhs* nil))
	X
	X
	X;rhs part to be evaluated upon pattern match failure
	X
	X(defun frhs-part (pnode) (car (last pnode)))
	X
	X;;returns value of last expression in RHS
	X(defun query (qname)
	X  (ipm-eval-query qname (car (get qname 'pmatches))))
	X   
	X;IPM-EVAL-QUERY: Given a pointer to a query and the associated data, this function
	X;sets up the appropriate environment to evaluate the RHS of the pattern match.
	X;This is a modified eval-rhs from OPS5.
	X
	X(defun ipm-eval-query (pname data)
	X  (let ((node (get pname 'topnode))
	X        (ans nil)
	X        (saved nil))
	X   (if (setq saved *in-rhs*) ;in case of recursive call,save system state and
	X       (save-system-state))  ;set saved flag
	X    (setq *data-matched* data)
	X    (setq *p-name* pname)
	X    (setq *last* nil)
	X    (setq node (get pname 'topnode))
	X    (ipm-init-var-mem (var-part node))
	X    (ipm-init-var-nmatches pname)
	X    (ipm-init-ce-var-mem (ce-var-part node))
	X    (setq *in-rhs* t)
	X    (setq ans
	X      (if (neq *NMATCHES* 0) ;if match failed, execute failpart, if any
	X(eval (rhs-part node))
	X(eval (frhs-part node)) ))
	X    (setq *in-rhs* nil)
	X   (if saved
	X      (restore-system-state))
	X    ans
	X))
	X
	X;map-query is just like query, except that we are performing the 
;eval operation for each match.  Therefore, some of the initialization
	X;must be factored out of ipm-eval-map-query.
	X(defun map-query(qname)
	X   (let* ((node (get qname 'topnode))
	X          (ans nil) 
	X          (saved nil))
	X   (if (setq saved *in-rhs*) ;in case of recursive call,save system state and
	X       (save-system-state))  ;set saved flag
	X      (setq *p-name* qname)
	X      (setq *last* nil)
	X  (setq ans
	X   (if (> (length (get qname 'pmatches)) 0)
	X      (mapcar '(lambda(qinstance) 
	X            (ipm-eval-map-query qname qinstance node))
	X          (get qname 'pmatches))
	X      (eval (frhs-part node)) ))
	X   (if saved
	X      (restore-system-state))
	X   ans)) 
	X
	X(defun ipm-eval-map-query (qname data node)
	X  (let ((ans))
	X    (setq *data-matched* data)
	X    (setq node (get qname 'topnode))
	X    (ipm-init-var-mem (var-part node))
	X    (ipm-init-var-nmatches qname)
	X    (ipm-init-ce-var-mem (ce-var-part node))
	X    (setq *in-rhs* t)
	X    (setq ans (eval (rhs-part node)))
	X    (setq *in-rhs* nil)
	X    ans
	X )) 
	X
	X
	X;the variable &nmatches is bound to the number of production
	X;matches in each query.  Useful for counting applications and
	X;deciding if any matches succeeded.
	X
	X(defun ipm-init-var-nmatches(pname)
	X    (setq *NMATCHES* (length (get pname 'pmatches)))
	X    (setq *variable-memory* ;remove previous number of matches
	X  (remove (assoc '\<NMATCHES\> *variable-memory*) *variable-memory*))
	X    (setq *variable-memory*  ;set up &NMATCHES environ. variable
	X          (cons (cons '\<NMATCHES\> *NMATCHES*)
	X*variable-memory*)))
	X
	X;More modified OPS5 code.  Initializes the variable and ce-variable bindings
	X;to be consistent with the results of the pattern match.
	X(defun ipm-init-var-mem (vlist)
	X  (prog (v ind r)
	X(or *in-rhs* ;if we're in rhs, then global is already set
	X          (setq *variable-memory* nil))
	X   top  (and (atom vlist) (return nil))
	X        (setq v (car vlist))
	X        (setq ind (cadr vlist))
        (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 ipm-init-ce-var-mem (vlist)
	X  (prog (v ind r)
	X(or *in-rhs* ;if we're in rhs, then global is already set
	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 save-system-state()
	X   (push-global-variables '*system-state-stack* '*ce-variable-memory* '*data-matched*
	X                          '*variable-memory* '*NMATCHES* '*p-name* '*in-rhs*))
	X
	X(defun restore-system-state()
	X   (pop-global-variables *system-state-stack*))
	X
	X;changed OPS5 code to accept &query
	X(defun link-new-node (r)
	X  (cond ((not (member (car r) '(&query &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 ipm-check-rhs (rhs) 
	X    (setq *compiling-rhs* t)
	X    (mapc (function ipm-check-action) rhs)
	X    (setq *compiling-rhs* nil))
	X
	X(defun myreplace(x y)
	X   (rplaca x (car y))
	X   (rplacd x (cdr y)))
	X
	X;This check-action is called by pmatch or map-pmatch macros
	X(defun ipm-check-action (x)
	X  (prog (a)
	X    (cond ((atom x)
	X           (%warn '|atomic action| x)
	X   (return nil)))
	X    (setq a (setq *action-type* (car x)))
	X   (cond ((eq a 'bind) (check-bind x))
	X          ((eq a 'query) nil) ;never happens?
	X          ((eq a 'map-query) nil) ;never happens?
	X  ;if we come across an unexpanded pmatch, expand and compile it.
	X  ;replace with result
	X          ((eq a 'pmatch) (myreplace x (eval x)))
	X          ((eq a 'map-pmatch) (myreplace x (eval x)))
          ((eq a 'cbind) (check-cbind x))
	X          ((eq a 'make) (check-make x))
	X          ((eq a 'modify) (check-modify x))
	X          ((eq a 'remove) (check-remove x))
	X          ((eq a 'write) (check-write x))
	X          ((eq a 'call) (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          (t nil) ;in a pmatch rhs, code is not restricted to OPS rhs actions.
	X  )))
	X
	X;This check action is just modified so that pmatch or map-pmatch
	X;are acceptable right-hand sides.
	X(defun check-action (x)
	X  (prog (a)
	X    (cond ((atom x)
	X           (%warn '|atomic action| x)
	X   (return nil)))
	X    (setq a (setq *action-type* (car x)))
	X    (cond ((eq a 'bind) (check-bind x))
	X          ((eq a 'query) nil) ;never happens
	X          ((eq a 'map-query) nil) ;never happens
	X  ;if we come across an unexpanded pmatch, expand and compile it.
	X  ;replace with result
	X          ((eq a 'pmatch) (myreplace x (eval x)))
	X          ((eq a 'map-pmatch) (myreplace x (eval 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 'remove) (check-remove x))
	X          ((eq a 'write) (check-write x))
	X          ((eq a 'call) (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          (t (%warn '|undefined rhs action| a))))) 
	X
	X
	X;add-to-wm: modified to return timetag number of item added
	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))
          (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    (return timetag))) 
	X
	X(defun &old (&rest a) nil) ;a null function used for deleting node
	X
	X
	X;MAKESYM: Does the same thing as gensym, but allows a symbol to be passed, so
	X;         the resulting symbol is meaningful.
	X(defun makesym(x)
	X  (prog(numb)
	X       (and (not (setq numb (get x '$cntr)))
	X    (setq numb 0))
	X       (putprop x (add1 numb) '$cntr)
	X       (return (concat x numb))))
	X
	X;CONCAT: Make a symbol from a number of symbols
	X(defun concat(&rest x)
	X   (do ((lst x (cdr lst))
	X        (strng nil))
	X       ((null lst)
	X        (intern strng))
	X       (setq strng (concatenate 'string strng (princ-to-string (car lst))))
	X    ))
	X
	X;A general purpose gensym function.  Input is 
	X; [atom], output is [atom]N, where N is a unique integer.
	X; ie. (newsym baz) ==> baz1
	X;     (newsym baz) ==> baz2, etc.
	X
	X(defmacro newsym(x)
	X  `(makesym ',x))
	X
	X
	X(defun exquery()
	X  (mapc #'(lambda(q) (eval `(excise ,q))) *qnames*)
	X  (setq *qnames* nil))
	X
	X;The following is a minimal test for the opsmods programs.
	X;To use it, uncomment it, and load it. The code should load without
	X;blowing up. Complaints about atomic actions in RHS are OK, ignore them. 
	X;Type
	X;(setup)
	X;(cs) -- foo and baz should be in the conflict set.
;Type (run 1), the program should print out a list of blocks.
	X;(run) should continue until only chartreuse blocks are left.
	X;While simple, this code tests for nested use of pattern matches, recursive calls,
	X;and use of pmatch in the rhs of OPS productions.
	X;(i-g-v)
	X;(literalize block a b c)
	X
	X
	X;(p baz 
	X;   { <a> (block ^a <colour> ) }
	X;         (block ^a <> <colour>)
	X;  -->
	X;   (pmatch  (block ^a <> <colour> ) 
	X;       -->
	X;           (find-block-colors ?<colour> )
	X;   (oremove <a> ))
	X;   (make block ^a chartreuse))
	X
	X;Test for recursive use of pmatch. (find-block-colors uses map-pmatch and 
	X;appears in a RHS of another pmatch)
	X;(defun rtest(a )
	X;   ?(pmatch (args a )
	X;    (block ^a <a> <numb>)
	X;        -->
	X;          (find-block-colors 'green)
	X;          (format t "Block color ~a is ~a~%" ?<a> ?<numb>)))
	X
	X;(defun find-block-colors (color)
	X;  ?(map-pmatch (args color)
	X;       (block ^a <color> <numb>)
	X;     -->
	X;   (format t "~%Find-block-colors ~a ~a~%" ?<color> ?<numb>))) 
	X
	X;(defun setup()
	X;  (setq *in-rhs* nil)
	X;  (oremove *)              
	X;  (make block ^a green 1)
	X;  (make block ^a green 2)
	X;  (make block ^a green 3)
	X;  (make block ^a green 4)
	X;  (make block ^a green 5)
	X;  (make block ^a red 6)
	X;  (make block ^a red 7)
	X;  (make block ^a yellow 8)
	X;  (make block ^a blue 9)
	X;  )
	X
	X
	XCLSUP.LIS
	X
	X;Common Lisp Support Functions: 
	X;These functions are not defined in vanilla Common Lisp, but are used
	X;in the OPSMODS.l code and in OPS5.  
	X
	X(defun putprop(name val att)
	X   (setf (get name att) val))
	X
	X(defun memq(obj lis)
	X    (member obj lis :test #'eq))
	X
	X(defun fix(num)
	X    (round num))
	X    
	X
	X(defun assq(item alist)
	X     (assoc item alist :test #'eq))
	X
	X(defun ncons(x) (cons x nil))
	X
	X(defun neq(x y) (not (eq x y)))
	X
	X(defun delq(obj list)
	X   (delete obj list :test #'eq))
	X
	X(defmacro comment(&optional &rest x) nil) ;comment is a noop
	X
	X(defun plus(x y)
	X   (+ x y))
	X
	X(defun quotient(x y)
	X   (/ x y))
	X
	X(defun flatc(x)
	X   (length (princ-to-string x)))
	X
	X
	X
	XCOMMON.OPS
	X
	X;	VPS2 -- Interpreter for OPS5
	X;
	X;	Copyright (C) 1979, 1980, 1981
	X;	Charles L. Forgy,  Pittsburgh, Pennsylvania
	X
	X
	X
	X; Users of this interpreter are requested to contact
	X
	X;
	X;	Charles Forgy
	X;	Computer Science Department
	X;	Carnegie-Mellon University
	X;	Pittsburgh, PA  15213
	X; or
	X;	Forgy@CMUA
	X; 
	X; so that they can be added to the mailing list for OPS5.  The mailing list
	X; is needed when new versions of the interpreter or manual are released.
	X
	X
	X
	X;;; Definitions
	X
	X#+ vax (defun putprop(name val att)
	X   (setf (get name att) val))
	X
	X
	X
	X(proclaim '(special *matrix* *feature-count* *pcount* *vars* *cur-vars*
	X          *curcond* *subnum* *last-node* *last-branch* *first-node*
	X          *sendtocall* *flag-part* *alpha-flag-part* *data-part*
	X          *alpha-data-part* *ce-vars* *virtual-cnt* *real-cnt*
	X          *current-token* *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9*
	X          *c10* *c11* *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19*
	X          *c20* *c21* *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29*
	X          *c30* *c31* *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39*
	X          *c40* *c41* *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49*
	X          *c50* *c51* *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59*
	X          *c60* *c61* *c62* *c63* *c64* *record-array* *result-array* 
	X          *max-cs* *total-cs* *limit-cs* *cr-temp* *side*
	X          *conflict-set* *halt-flag* *phase* *critical*
	X          *cycle-count* *total-token* *max-token* *refracts* 
	X          *limit-token* *total-wm* *current-wm* *max-wm*
	X          *action-count* *wmpart-list* *wm* *data-matched* *p-name*
	X          *variable-memory* *ce-variable-memory* 
	X          *max-index* ; number of right-most field in wm element 
	X          *next-index* *size-result-array* *rest* *build-trace* *last*
	X          *ptrace* *wtrace* *in-rhs* *recording* *accept-file* *trace-file* 
	X          *mtrace* *madeby* ; used to trace and record makers of elements
	X          *write-file* *record-index* *max-record-index* *old-wm*
	X          *record* *filters* *break-flag* *strategy* *remaining-cycles*
	X	  *wm-filter* *rhs-bound-vars* *rhs-bound-ce-vars* *ppline* 
	X	  *ce-count* *brkpts* *class-list* *buckets* *action-type*
	X          *literals*   ;stores literal definitions
	X          *pnames*     ;stores production names
	X	  *externals*  ;tracks external declarations 
	X          *vector-attributes*  ;list of vector-attributes
	X	  ))
	X
	X;(declare (localf ce-gelm gelm peek-sublex sublex
	X;          eval-nodelist sendto and-left and-right not-left not-right
	X;          top-levels-eq add-token real-add-token remove-old
	X;          remove-old-num remove-old-no-num removecs insertcs dsort
	X;          best-of best-of* conflict-set-compare =alg ))
	X
	X
	X;;; Functions that were revised so that they would compile efficiently
	X
	X
	X;* The function == is machine dependent\!
	X;* This function compares small integers for equality.  It uses EQ
	X;* so that it will be fast, and it will consequently not work on all
	X;* Lisps.  It works in Franz Lisp for integers in [-128, 127]
	X
	X
	X;(defun == (&rest z) (= (cadr z) (caddr z)))
	X(defun == (x y) (= x y))
	X
	X; =ALG returns T if A and B are algebraicly equal.
	X
	X(defun =alg (a b) (= a b))
	X
	X(defmacro fast-symeval (&rest z)
	X	 `(cond ((eq ,(car z) '*c1*) *c1*)
	X		((eq ,(car z) '*c2*) *c2*)
	X		((eq ,(car z) '*c3*) *c3*)
	X		((eq ,(car z) '*c4*) *c4*)
	X		((eq ,(car z) '*c5*) *c5*)
	X		((eq ,(car z) '*c6*) *c6*)
	X		((eq ,(car z) '*c7*) *c7*)
	X		(t (eval ,(car z)))  ))
	X
	X; getvector and putvector are fast routines for using one-dimensional
	X; arrays.  these routines do no checking; they assume
	X;	1. the array is a vector with 0 being the index of the first
	X;	   element
	X;	2. the vector holds arbitrary list values
	X;defun versions are useful for tracing
	X
	X; Example call: (putvector array index value)
	X
	X(defmacro putvector (array_ref ind var)
	X      `(setf (aref ,array_ref ,ind) ,var))
	X
	X;(defun putvector (array_ref ind var)
	X;      (setf (aref array_ref ind) var))
	X
	X; Example call: (getvector name index)
	X
	X;(defmacro getvector(&rest z)
	X;     (list 'cxr (caddr z) (cadr z)))
	X
	X(defmacro getvector(array_ref ind)
	X      `(aref ,array_ref ,ind))
	X
	X;(defun getvector (array_ref ind)
	X ;       (aref array_ref ind))
	X
	X(defun ce-gelm (x k)
	X  (prog nil
	X   loop (and (== k 1.) (return (car x)))
	X        (setq k (1- k))
	X        (setq x (cdr x))
	X        (go loop))) 
	X
	X; The loops in gelm were unwound so that fewer calls on DIFFERENCE
	X; would be needed
	X
	X(defun gelm (x k)
	X  (prog (ce sub)
	X        (setq ce  (floor (/ k 10000)))
	X        (setq sub (- k (* ce 10000)))
	X celoop (and (== ce 0) (go ph2))
	X        (setq x (cdr x))
	X        (and (== ce 1) (go ph2))
	X        (setq x (cdr x))
	X        (and (== ce 2) (go ph2))
	X        (setq x (cdr x))
	X        (and (== ce 3) (go ph2))
	X        (setq x (cdr x))
	X        (and (== ce 4) (go ph2))
	X        (setq ce (- ce 4))
	X        (go celoop)
	X   ph2  (setq x (car x))
	X   subloop (and (== sub 0) (go finis))
	X        (setq x (cdr x))
	X        (and (== sub 1) (go finis))
	X        (setq x (cdr x))
	X        (and (== sub 2) (go finis))
	X        (setq x (cdr x))
	X        (and (== sub 3) (go finis))
	X        (setq x (cdr x))
	X        (and (== sub 4) (go finis))
	X        (setq x (cdr x))
	X        (and (== sub 5) (go finis))
	X        (setq x (cdr x))
	X        (and (== sub 6) (go finis))
	X        (setq x (cdr x))
	X        (and (== sub 7) (go finis))
	X        (setq x (cdr x))
	X        (and (== sub 8) (go finis))
	X        (setq sub (- sub 8))
	X        (go subloop)
	X   finis (return (car x)))) 
	X
	X
	X;;; Utility functions
	X
	X
	X
	X(defun printline (x) (mapc (function printline*) x)) 
	X
	X(defun printline* (y) (princ '| |) (print y)) 
	X
	X(defun printlinec (x) (mapc (function printlinec*) x)) 
	X
	X(defun printlinec* (y) (princ '| |) (princ y)) 
	X
	X; intersect two lists using eq for the equality test
	X
	X(defun interq (x y)
	X  (intersection x y :test #'eq))
	X
	X(defun enter (x ll)
	X   (and (not (member x ll :test #'equal))
	X       (push x ll)))
	X
	X
	X;Hack read-macro tables to accept single characters -- right out of CL book.
	X(defun single-macro-character (stream char)
	X   (declare (ignore stream))
	X   (character char))
	X
	X(defun i-g-v nil
	X (prog (x)
	X        (set-macro-character #\{ #'single-macro-character )
	X        (set-macro-character #\} #'single-macro-character )
	X        (set-macro-character #\^ #'single-macro-character )
	X;	(setsyntax '\{ 66.) ;These are already normal characters in CL
	X;	(setsyntax '\} 66.)
	X;	(setsyntax '^ 66.)
	X	(setq *buckets* 64.)		; OPS5 allows 64 named slots
	X	(setq *accept-file* nil)
	X	(setq *write-file* nil)
	X	(setq *trace-file* nil)
	X        (and (boundp '*class-list*)
	X          (mapc #'(lambda(class) (putprop class nil 'att-list)) *class-list*))
	X	(setq *class-list* nil)
	X	(setq *brkpts* nil)
	X	(setq *strategy* 'lex)
	X  	(setq *in-rhs* nil)
	X  	(setq *ptrace* t)
	X  	(setq *wtrace* nil)
	X	(setq *mtrace* t)            ; turn on made-by tracing
	X	(setq *madeby* nil)          ; record makers of wm elements
	X  	(setq *recording* nil)
	X        (setq *refracts* nil)
	X	(setq *real-cnt* (setq *virtual-cnt* 0.))
	X	(setq *max-cs* (setq *total-cs* 0.))
	X  	(setq *limit-token* 1000000.)
	X	(setq *limit-cs* 1000000.)
	X	(setq *critical* nil)
	X	(setq *build-trace* nil)
	X	(setq *wmpart-list* nil)
	X        (setq *pnames* nil)
	X        (setq *literals* nil) ; records literal definitions
	X	(setq *externals* nil) ; records external definitions
	X	(setq *vector-attributes* nil) ;records vector attributes
	X	(setq *size-result-array* 127.)
	X	(setq *result-array* (make-array 128))
	X	(setq *record-array* (make-array 128))
	X	(setq x 0)
	X        (setq *pnames* nil)     ; list of production names
	X  loop	(putvector *result-array* x nil)
	X	(setq x (1+ x))
	X	(and (not (> x *size-result-array*)) (go loop))
	X	(make-bottom-node)
	X	(setq *pcount* 0.)
	X	(initialize-record)
	X	(setq *cycle-count* (setq *action-count* 0.))
	X	(setq *total-token*
	X	       (setq *max-token* (setq *current-token* 0.)))
	X	(setq *total-cs* (setq *max-cs* 0.))
	X	(setq *total-wm* (setq *max-wm* (setq *current-wm* 0.)))
	X	(setq *conflict-set* nil)
	X	(setq *wmpart-list* nil)
	X	(setq *p-name* nil)
	X	(setq *remaining-cycles* 1000000)
	X))
	X
	X; if the size of result-array changes, change the line in i-g-v which
	X; sets the value of *size-result-array*
	X
	X(defun %warn (what where)
	X  (prog nil
	X    (terpri)
	X    (princ '?)
	X    (and *p-name* (princ *p-name*))
	X    (princ '|..|)
	X    (princ where)
	X    (princ '|..|)
	X    (princ what)
	X    (return where))) 
	X
	X(defun %error (what where)
	X    (%warn what where)
	X    (throw '!error! nil)) 
	X
	X
	X(defun top-levels-eq (la lb)
	X  (prog nil
	X   lx   (cond ((eq la lb) (return t))
	X              ((null la) (return nil))
	X              ((null lb) (return nil))
	X              ((not (eq (car la) (car lb))) (return nil)))
	X        (setq la (cdr la))
	X        (setq lb (cdr lb))
	X        (go lx))) 
	X
	X
	X;;; LITERAL and LITERALIZE
	X
	X(defmacro literal (&rest z)
	X  `(prog (atm val old args)
	X        (setq args ',z)
	X   top  (and (atom args) (return 'bound))
	X        (or (eq (cadr args) '=) (return (%warn '|wrong format| args)))
	X        (setq atm (car args))
	X        (setq val (caddr args))
	X        (setq args (cdddr args))
	X        (cond ((not (numberp val))
	X               (%warn '|can bind only to numbers| val))
	X              ((or (not (symbolp atm)) (variablep atm))
	X                (%warn '|can bind only constant atoms| atm))
	X              ((and (setq old (literal-binding-of atm)) (not (equal old val)))
	X               (%warn '|attempt to rebind attribute| atm))
	X              (t (putprop atm val 'ops-bind )))
	X        (go top))) 
	X
	X(defmacro literalize (&rest l)
	X  `(prog (class-name atts)
	X    (setq class-name (car ',l))
	X    (cond ((have-compiled-production)
	X           (%warn '|literalize called after p| class-name)
	X           (return nil))
	X          ((get class-name 'att-list)
	X           (%warn '|attempt to redefine class| class-name)
	X	   (return nil)))
	X    (setq *class-list* (cons class-name *class-list*))
	X    (setq atts (remove-duplicates (cdr ',l)))
	X    (test-attribute-names atts)
	X    (mark-conflicts atts atts)
	X    (putprop class-name  atts 'att-list))) 
	X
	X(defmacro vector-attribute  (&rest l)
	X  `(cond ((have-compiled-production)
	X         (%warn '|vector-attribute called after p| ',l))
	X        (t 
	X         (test-attribute-names ',l)
	X	 (mapc (function vector-attribute2) ',l)))) 
	X
	X(defun vector-attribute2 (att) (putprop att t 'vector-attribute)
	X			       (setq  *vector-attributes* 
	X				   (enter att *vector-attributes*)))
	X
	X(defun is-vector-attribute (att) (get att 'vector-attribute))
	X
	X(defun test-attribute-names (l)
	X  (mapc (function test-attribute-names2) l)) 
	X
	X(defun test-attribute-names2 (atm)
	X  (cond ((or (not (symbolp atm)) (variablep atm))
	X         (%warn '|can bind only constant atoms| atm)))) 
	X
	X(defun finish-literalize nil
	X  (cond ((not (null *class-list*))
	X         (mapc (function note-user-assigns) *class-list*)
	X         (mapc (function assign-scalars) *class-list*)
	X         (mapc (function assign-vectors) *class-list*)
	X         (mapc (function put-ppdat) *class-list*)
	X         (mapc (function erase-literal-info) *class-list*)
	X         (setq *class-list* nil)
	X         (setq *buckets* nil)))) 
	X
	X(defun have-compiled-production nil (not (zerop *pcount*))) 
	X
	X(defun put-ppdat (class)
	X  (prog (al att ppdat)
	X        (setq ppdat nil)
	X        (setq al (get class 'att-list))
	X   top  (cond ((not (atom al))
	X               (setq att (car al))
	X               (setq al (cdr al))
	X               (setq ppdat
	X                     (cons (cons (literal-binding-of att) att)
	X                           ppdat))
	X               (go top)))
	X        (putprop class ppdat 'ppdat))) 
	X
	X; note-user-assigns and note-user-vector-assigns are needed only when
	X; literal and literalize are both used in a program.  They make sure that
	X; the assignments that are made explicitly with literal do not cause problems
	X; for the literalized classes.
	X
	X(defun note-user-assigns (class)
	X  (mapc (function note-user-assigns2) (get class 'att-list)))
	X
	X(defun note-user-assigns2 (att)
	X  (prog (num conf buck clash)
	X        (setq num (literal-binding-of att))
	X	(and (null num) (return nil))
	X	(setq conf (get att 'conflicts))
	X	(setq buck (store-binding att num))
	X	(setq clash (find-common-atom buck conf))
	X	(and clash
	X	     (%warn '|attributes in a class assigned the same number|
	X	            (cons att clash)))
	X        (return nil)))
	X
	X(defun note-user-vector-assigns (att given needed)
	X  (and (> needed given)
	X       (%warn '|vector attribute assigned too small a value in literal| att)))
	X
	X(defun assign-scalars (class)
	X  (mapc (function assign-scalars2) (get class 'att-list))) 
	X
	X(defun assign-scalars2 (att)
	X  (prog (tlist num bucket conf)
	X        (and (literal-binding-of att) (return nil))
	X        (and (is-vector-attribute att) (return nil))
	X        (setq tlist (buckets))
	X        (setq conf (get att 'conflicts))
	X   top  (cond ((atom tlist)
	X               (%warn '|could not generate a binding| att)
	X               (store-binding att -1.)
	X               (return nil)))
	X        (setq num (caar tlist))
	X        (setq bucket (cdar tlist))
	X        (setq tlist (cdr tlist))
	X        (cond ((disjoint bucket conf) (store-binding att num))
	X        (t (go top))))) 
	X
	X(defun assign-vectors (class)
	X  (mapc (function assign-vectors2) (get class 'att-list))) 
	X
	X(defun assign-vectors2 (att)
	X  (prog (big conf new old need)
	X        (and (not (is-vector-attribute att)) (return nil))
	X        (setq big 1.)
	X        (setq conf (get att 'conflicts))
	X   top  (cond ((not (atom conf))
	X               (setq new (car conf))
	X               (setq conf (cdr conf))
	X               (cond ((is-vector-attribute new)
	X                      (%warn '|class has two vector attributes|
	X		              (list att new)))
	X                     (t (setq big (max (literal-binding-of new) big))))
	X               (go top)))
	X        (setq need (1+ big))
	X	(setq old (literal-binding-of att))
	X	(cond (old (note-user-vector-assigns att old need))
	X	      (t (store-binding att need)))
	X        (return nil)))
	X
	X(defun disjoint (la lb) (not (find-common-atom la lb))) 
	X
	X(defun find-common-atom (la lb)
	X  (prog nil
	X   top  (cond ((null la) (return nil))
	X              ((member (car la) lb :test #'eq) (return (car la)))
	X              (t (setq la (cdr la)) (go top))))) 
	X
	X(defun mark-conflicts (rem all)
	X  (cond ((not (null rem))
	X         (mark-conflicts2 (car rem) all)
	X         (mark-conflicts (cdr rem) all)))) 
	X
	X(defun mark-conflicts2 (atm lst)
	X  (prog (l)
	X        (setq l lst)
	X   top  (and (atom l) (return nil))
	X        (conflict atm (car l))
	X        (setq l (cdr l))
	X        (go top))) 
	X
	X(defun conflict (a b)
	X  (prog (old)
	X    (setq old (get a 'conflicts))
	X    (and (not (eq a b))
	X         (not (member b old :test #'eq))
	X         (putprop a (cons b old) 'conflicts )))) 
	X
	X;(defun remove-duplicates (lst)
	X;  (cond ((atom lst) nil)
	X;        ((member (car lst) (cdr lst) :test #'eq) (remove-duplicates (cdr lst)))
	X;        (t (cons (car lst) (remove-duplicates (cdr lst)))))) 
	X
	X(defun literal-binding-of (name) (get name 'ops-bind)) 
	X
	X(defun store-binding (name lit)
	X  (putprop name lit 'ops-bind)
	X  (add-bucket name lit)) 
	X
	X(defun add-bucket (name num)
	X  (prog (buc)
	X    (setq buc (assoc num (buckets)))
	X    (and (not (member name buc :test #'eq))
	X         (rplacd buc (cons name (cdr buc))))
	X    (return buc))) 
	X
	X(defun buckets nil
	X  (and (atom *buckets*) (setq *buckets* (make-nums *buckets*)))
	X  *buckets*) 
	X
	X(defun make-nums (k)
	X  (prog (nums)
	X        (setq nums nil)
	X   l    (and (< k 2.) (return nums))
	X        (setq nums (cons (cons k nil) nums))
	X        (setq k (1- k))
	X        (go l))) 
	X
	X;(defun erase-literal-info (class)
	X;  (mapc (function erase-literal-info2) (get class 'att-list))
	X;  (remprop class 'att-list)) 
	X
	X; modified to record literal info in the variable *literals*
	X(defun erase-literal-info (class)
	X      (setq *literals*
	X            (cons (cons class (get class 'att-list)) *literals*))
	X      (mapc (function erase-literal-info2) (get class 'att-list))
	X      (remprop class 'att-list))
	X
	X
	X(defun erase-literal-info2 (att) (remprop att 'conflicts)) 
	X
	X
	X;;; LHS Compiler
	X
	X(defmacro p (&rest z) 
	X `(progn 
	X   (finish-literalize)
	X   (princ '*) 
	X  ;(drain);drain probably drains a line feed
	X   (compile-production (car ',z) (cdr ',z)))) 
	X
	X(defun compile-production (name matrix)
	X  (prog (erm)
	X        (setq *p-name* name)
	X        (setq erm (catch '!error! (cmp-p name matrix) ))
	X	; following line is modified to save production name on *pnames*
	X        (and (null erm) (setq *pnames* (enter name *pnames*)))
	X	(setq *p-name* nil)
	X	(return erm)))
	X
	X(defun peek-lex nil (car *matrix*)) 
	X
	X(defun lex nil
	X  (prog2 nil (car *matrix*) (setq *matrix* (cdr *matrix*)))) 
	X
	X(defun end-of-p nil (atom *matrix*)) 
	X
	X(defun rest-of-p nil *matrix*) 
	X
	X(defun prepare-lex (prod) (setq *matrix* prod)) 
	X
	X
	X(defun peek-sublex nil (car *curcond*)) 
	X
	X(defun sublex nil
	X  (prog2 nil (car *curcond*) (setq *curcond* (cdr *curcond*)))) 
	X
	X(defun end-of-ce nil (atom *curcond*)) 
	X
	X(defun rest-of-ce nil *curcond*) 
	X
	X(defun prepare-sublex (ce) (setq *curcond* ce)) 
	X
	X(defun make-bottom-node nil (setq *first-node* (list '&bus nil))) 
	X
	X(defun cmp-p (name matrix)
	X  (prog (m bakptrs)
	X        (cond ((or (null name) (listp name))
	X               (%error '|illegal production name| name))
	X              ((equal (get name 'production) matrix)
	X	       (return nil)))
	X        (prepare-lex matrix)
	X        (excise-p name)
	X        (setq bakptrs nil)
	X        (setq *pcount* (1+ *pcount*))
	X        (setq *feature-count* 0.)
	X	(setq *ce-count* 0)
	X        (setq *vars* nil)
	X        (setq *ce-vars* nil)
	X	(setq *rhs-bound-vars* nil)
	X	(setq *rhs-bound-ce-vars* nil)
	X        (setq *last-branch* nil)
	X        (setq m (rest-of-p))
	X   l1   (and (end-of-p) (%error '|no '-->' in production| m))
	X        (cmp-prin)
	X        (setq bakptrs (cons *last-branch* bakptrs))
	X        (or (eq '--> (peek-lex)) (go l1))
	X        (lex)
	X	(check-rhs (rest-of-p))
	X        (link-new-node (list '&p
	X                             *feature-count*
	X                             name
	X                             (encode-dope)
	X                             (encode-ce-dope)
	X                             (cons 'progn (rest-of-p))))
	X        (putprop name (cdr (nreverse bakptrs)) 'backpointers )
	X	(putprop name matrix 'production)
	X        (putprop name *last-node* 'topnode))) 
	X
	X(defun rating-part (pnode) (cadr pnode)) 
	X
	X(defun var-part (pnode) (car (cdddr pnode))) 
	X
	X(defun ce-var-part (pnode) (cadr (cdddr pnode))) 
	X
	X(defun rhs-part (pnode) (caddr (cdddr pnode))) 
	X
	X(defun excise-p (name)
	X  (cond ((and (symbolp name) (get name 'topnode))
	X	 (printline (list name 'is 'excised))
	X         (setq *pcount* (1- *pcount*))
	X         (remove-from-conflict-set name)
	X         (kill-node (get name 'topnode))
	X         (setq *pnames* (delete name *pnames* :test #'eq))
	X	 (remprop name 'production)
	X	 (remprop name 'backpointers)
	X         (remprop name 'topnode)))) 
	X
	X(defun kill-node (node)
	X  (prog nil
	X   top  (and (atom node) (return nil))
	X        (rplaca node '&old)
	X        (setq node (cdr node))
	X        (go top))) 
	X
	X(defun cmp-prin nil
	X  (prog nil
	X        (setq *last-node* *first-node*)
	X        (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta))
	X              ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
	X              (t (cmp-posce) (cmp-and))))) 
	X
	X(defun cmp-negce nil (lex) (cmp-ce)) 
	X
	X(defun cmp-posce nil
	X  (setq *ce-count* (1+ *ce-count*))
	X  (cond ((eq (peek-lex) #\{) (cmp-ce+cevar))
	X        (t (cmp-ce)))) 
	X
	X(defun cmp-ce+cevar nil
	X  (prog (z)
	X        (lex)
	X        (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
	X              (t (cmp-ce) (cmp-cevar)))
	X        (setq z (lex))
	X        (or (eq z #\}) (%error '|missing '}'| z)))) 
	X
	X(defun new-subnum (k)
	X  (or (numberp k) (%error '|tab must be a number| k))
	X  (setq *subnum* (round k))) 
	X
	X(defun incr-subnum nil (setq *subnum* (1+ *subnum*))) 
	X
	X(defun cmp-ce nil
	X  (prog (z)
	X        (new-subnum 0.)
	X        (setq *cur-vars* nil)
	X        (setq z (lex))
	X        (and (atom z)
	X             (%error '|atomic conditions are not allowed| z))
	X        (prepare-sublex z)
	X   la   (and (end-of-ce) (return nil))
	X        (incr-subnum)
	X        (cmp-element)
	X        (go la))) 
	X
	X(defun cmp-element nil
	X        (and (eq (peek-sublex) #\^) (cmp-tab))
	X        (cond ((eq (peek-sublex) '#\{) (cmp-product))
	X              (t (cmp-atomic-or-any))))
	X
	X(defun cmp-atomic-or-any nil
	X        (cond ((eq (peek-sublex) '<<) (cmp-any))
	X              (t (cmp-atomic))))
	X
	X(defun cmp-any nil
	X  (prog (a z)
	X        (sublex)
	X        (setq z nil)
	X   la   (cond ((end-of-ce) (%error '|missing '>>'| a)))
	X        (setq a (sublex))
	X        (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
	X        (link-new-node (list '&any nil (current-field) z)))) 
	X
	X
	X(defun cmp-tab nil
	X  (prog (r)
	X        (sublex)
	X        (setq r (sublex))
	X        (setq r ($litbind r))
	X        (new-subnum r))) 
	X
	X(defun $litbind (x)
	X  (prog (r)
	X        (cond ((and (symbolp x) (setq r (literal-binding-of x)))
	X               (return r))
	X              (t (return x))))) 
	X
	X(defun get-bind (x)
	X  (prog (r)
	X        (cond ((and (symbolp x) (setq r (literal-binding-of x)))
	X               (return r))
	X              (t (return nil))))) 
	X
	X(defun cmp-atomic nil
	X  (prog (test x)
	X        (setq x (peek-sublex))
	X        (cond ((eq x '=) (setq test 'eq) (sublex))
	X              ((eq x '<>) (setq test 'ne) (sublex))
	X              ((eq x '<) (setq test 'lt) (sublex))
	X              ((eq x '<=) (setq test 'le) (sublex))
	X              ((eq x '>) (setq test 'gt) (sublex))
	X              ((eq x '>=) (setq test 'ge) (sublex))
	X              ((eq x '<=>) (setq test 'xx) (sublex))
	X              (t (setq test 'eq)))
	X        (cmp-symbol test))) 
	X
	X(defun cmp-product nil
	X  (prog (save)
	X        (setq save (rest-of-ce))
	X        (sublex)
	X   la   (cond ((end-of-ce)
	X               (cond ((member #\} save) 
	X		      (%error '|wrong contex for '}'| save))
	X		     (t (%error '|missing '}'| save))))
	X              ((eq (peek-sublex) #\}) (sublex) (return nil)))
	X        (cmp-atomic-or-any)
	X        (go la))) 
	X
	X(defun variablep (x) (and (symbolp x) (char-equal (char (symbol-name x) 0) #\<))) 
	X
	X(defun cmp-symbol (test)
	X  (prog (flag)
	X        (setq flag t)
	X        (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil)))
	X        (cond ((and flag (variablep (peek-sublex)))
	X               (cmp-var test))
	X              ((numberp (peek-sublex)) (cmp-number test))
	X              ((symbolp (peek-sublex)) (cmp-constant test))
	X              (t (%error '|unrecognized symbol| (sublex)))))) 
	X
	X(defun concat3(x y z)
	X   (intern (format nil "~s~s~s" x y z)))
	X
	X(defun cmp-constant (test)
	X  (or (member test '(eq ne xx) )
	X      (%error '|non-numeric constant after numeric predicate| (sublex)))
	X  (link-new-node (list (concat3 't test 'a)
	X                       nil
	X                       (current-field)
	X                       (sublex)))) 
	X
	X
	X(defun cmp-number (test)
	X  (link-new-node (list (concat3 't test 'n)
	X                       nil
	X                       (current-field)
	X                       (sublex)))) 
	X
	X(defun current-field nil (field-name *subnum*)) 
	X
	X(defun field-name (num)
	X  (cond ((= num 1.) '*c1*)
	X        ((= num 2.) '*c2*)
	X        ((= num 3.) '*c3*)
	X        ((= num 4.) '*c4*)
	X        ((= num 5.) '*c5*)
	X        ((= num 6.) '*c6*)
	X        ((= num 7.) '*c7*)
	X        ((= num 8.) '*c8*)
	X        ((= num 9.) '*c9*)
	X        ((= num 10.) '*c10*)
	X        ((= num 11.) '*c11*)
	X        ((= num 12.) '*c12*)
	X        ((= num 13.) '*c13*)
	X        ((= num 14.) '*c14*)
	X        ((= num 15.) '*c15*)
	X        ((= num 16.) '*c16*)
	X        ((= num 17.) '*c17*)
	X        ((= num 18.) '*c18*)
	X        ((= num 19.) '*c19*)
	X        ((= num 20.) '*c20*)
	X        ((= num 21.) '*c21*)
	X        ((= num 22.) '*c22*)
	X        ((= num 23.) '*c23*)
	X        ((= num 24.) '*c24*)
	X        ((= num 25.) '*c25*)
	X        ((= num 26.) '*c26*)
	X        ((= num 27.) '*c27*)
	X        ((= num 28.) '*c28*)
	X        ((= num 29.) '*c29*)
	X        ((= num 30.) '*c30*)
	X        ((= num 31.) '*c31*)
	X        ((= num 32.) '*c32*)
	X        ((= num 33.) '*c33*)
	X        ((= num 34.) '*c34*)
	X        ((= num 35.) '*c35*)
	X        ((= num 36.) '*c36*)
	X        ((= num 37.) '*c37*)
	X        ((= num 38.) '*c38*)
	X        ((= num 39.) '*c39*)
	X        ((= num 40.) '*c40*)
	X        ((= num 41.) '*c41*)
	X        ((= num 42.) '*c42*)
	X        ((= num 43.) '*c43*)
	X        ((= num 44.) '*c44*)
	X        ((= num 45.) '*c45*)
	X        ((= num 46.) '*c46*)
	X        ((= num 47.) '*c47*)
	X        ((= num 48.) '*c48*)
	X        ((= num 49.) '*c49*)
	X        ((= num 50.) '*c50*)
	X        ((= num 51.) '*c51*)
	X        ((= num 52.) '*c52*)
	X        ((= num 53.) '*c53*)
	X        ((= num 54.) '*c54*)
	X        ((= num 55.) '*c55*)
	X        ((= num 56.) '*c56*)
	X        ((= num 57.) '*c57*)
	X        ((= num 58.) '*c58*)
	X        ((= num 59.) '*c59*)
	X        ((= num 60.) '*c60*)
	X        ((= num 61.) '*c61*)
	X        ((= num 62.) '*c62*)
	X        ((= num 63.) '*c63*)
	X        ((= num 64.) '*c64*)
	X        (t (%error '|condition is too long| (rest-of-ce))))) 
	X
	X
	X;;; Compiling variables
	X;
	X;
	X;
	X; *cur-vars* are the variables in the condition element currently 
	X; being compiled.  *vars* are the variables in the earlier condition
	X; elements.  *ce-vars* are the condition element variables.  note
	X; that the interpreter will not confuse condition element and regular
	X; variables even if they have the same name.
	X;
	X; *cur-vars* is a list of triples: (name predicate subelement-number)
	X; eg:		( (<x> eq 3)
	X;		  (<y> ne 1)
	X;		  . . . )
	X;
	X; *vars* is a list of triples: (name ce-number subelement-number)
	X; eg:		( (<x> 3 3)
	X;		  (<y> 1 1)
	X;		  . . . )
	X;
	X; *ce-vars* is a list of pairs: (name ce-number)
	X; eg:		( (ce1 1)
	X;		  (<c3> 3)
	X;		  . . . )
	X
	X(defun var-dope (var) (assoc var *vars* :test #'eq))
	X
	X(defun ce-var-dope (var) (assoc var *ce-vars* :test #'eq))
	X
	X(defun cmp-var (test)
	X  (prog (old name)
	X        (setq name (sublex))
	X        (setq old (assoc name *cur-vars* :test #'eq))
	X        (cond ((and old (eq (cadr old) 'eq))
	X               (cmp-old-eq-var test old))
	X              ((and old (eq test 'eq)) (cmp-new-eq-var name old))
	X              (t (cmp-new-var name test))))) 
	X
	X(defun cmp-new-var (name test)
	X  (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*))) 
	X
	X(defun cmp-old-eq-var (test old)
	X  (link-new-node (list (concat3 't test 's)
	X                       nil
	X                       (current-field)
	X                       (field-name (caddr old))))) 
	X
	X(defun cmp-new-eq-var (name old)
	X  (prog (pred next)
	X        (setq *cur-vars* (delete old *cur-vars* :test #'eq))
	X        (setq next (assoc name *cur-vars* :test #'eq))
	X        (cond (next (cmp-new-eq-var name next))
	X              (t (cmp-new-var name 'eq)))
	X        (setq pred (cadr old))
	X        (link-new-node (list (concat3 't pred 's)
	X                             nil
	X                             (field-name (caddr old))
	X                             (current-field))))) 
	X
	X(defun cmp-cevar nil
	X  (prog (name old)
	X        (setq name (lex))
	X        (setq old (assoc name *ce-vars* :test #'eq))
	X        (and old
	X             (%error '|condition element variable used twice| name))
	X        (setq *ce-vars* (cons (list name 0.) *ce-vars*)))) 
	X
	X(defun cmp-not nil (cmp-beta '&not)) 
	X
	X(defun cmp-nobeta nil (cmp-beta nil)) 
	X
	X(defun cmp-and nil (cmp-beta '&and)) 
	X
	X(defun cmp-beta (kind)
	X  (prog (tlist vdope vname vpred vpos old)
	X        (setq tlist nil)
	X   la   (and (atom *cur-vars*) (go lb))
	X        (setq vdope (car *cur-vars*))
	X        (setq *cur-vars* (cdr *cur-vars*))
	X        (setq vname (car vdope))
	X        (setq vpred (cadr vdope))
	X        (setq vpos (caddr vdope))
	X        (setq old (assoc vname *vars* :test #'eq))
	X        (cond (old (setq tlist (add-test tlist vdope old)))
	X              ((not (eq kind '&not)) (promote-var vdope)))
	X        (go la)
	X   lb   (and kind (build-beta kind tlist))
	X        (or (eq kind '&not) (fudge))
	X        (setq *last-branch* *last-node*))) 
	X
	X(defun add-test (list new old)
	X  (prog (ttype lloc rloc)
	X	(setq *feature-count* (1+ *feature-count*))
	X        (setq ttype (concat3 't (cadr new) 'b))
	X        (setq rloc (encode-singleton (caddr new)))
	X        (setq lloc (encode-pair (cadr old) (caddr old)))
	X        (return (cons ttype (cons lloc (cons rloc list)))))) 
	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