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


	X               (return nil)))
	X        (setq elm (get-ce-var-bind (car ',l)))
	X        (cond ((null elm)
	X               (%warn '|first argument to substr must be a ce var|
	X                        ',l)
	X               (return nil)))
	X        (setq start ($varbind (cadr ',l)))
	X	(setq start ($litbind start))
	X        (cond ((not (numberp start))
	X               (%warn '|second argument to substr must be a number|
	X                        ',l)
	X               (return nil)))
	X	;if a variable is bound to INF, the following
	X	;will get the binding and treat it as INF is
	X	;always treated.  that may not be good
	X        (setq end ($varbind (caddr ',l)))
	X        (cond ((eq end 'inf) (setq end (length elm))))
	X	(setq end ($litbind end))
	X        (cond ((not (numberp end))
	X               (%warn '|third argument to substr must be a number|
	X                        ',l)
	X               (return nil)))
	X        ;this loop does not check for the end of elm
	X        ;instead it relies on cdr of nil being nil
	X        ;this may not work in all versions of lisp
	X        (setq k 1.)
	X   la   (cond ((> k end) (return nil))
	X              ((not (< k start)) ($value (car elm))))
	X        (setq elm (cdr elm))
	X        (setq k (1+ k))
	X        (go la))) 
	X
	X
	X(defmacro compute (&rest z) `($value (ari ',z))) 
	X
	X; arith is the obsolete form of compute
	X(defmacro arith (&rest z) `($value (ari ',z))) 
	X
	X(defun ari (x)
	X  (cond ((atom x)
	X         (%warn '|bad syntax in arithmetic expression | x)
	X	 0.)
	X        ((atom (cdr x)) (ari-unit (car x)))
	X        ((eq (cadr x) '+)
	X         (+ (ari-unit (car x)) (ari (cddr x))))
	X        ((eq (cadr x) '-)
	X         (difference (ari-unit (car x)) (ari (cddr x))))
	X        ((eq (cadr x) '*)
	X         (times (ari-unit (car x)) (ari (cddr x))))
	X        ((eq (cadr x) '//)
	X         (/ (ari-unit (car x)) (ari (cddr x))))
	X        ((eq (cadr x) '\\)
	X         (mod (round (ari-unit (car x))) (round (ari (cddr x)))))
	X        (t (%warn '|bad syntax in arithmetic expression | x) 0.))) 
	X
	X(defun ari-unit (a)
	X  (prog (r)
	X        (cond ((listp a) (setq r (ari a)))
	X              (t (setq r ($varbind a))))
	X        (cond ((not (numberp r))
	X               (%warn '|bad value in arithmetic expression| a)
	X               (return 0.))
	X              (t (return r))))) 
	X
	X(defun genatom nil ($value (gensym))) 
	X
	X(defmacro litval (&rest z)
	X  `(prog (r)
	X	(cond ((not (= (length ',z) 1.))
	X	       (%warn '|litval: wrong number of arguments| ',z)
	X	       ($value 0) 
	X	       (return nil))
	X	      ((numberp (car ',z)) ($value (car ',z)) (return nil)))
	X	(setq r ($litbind ($varbind (car ',z))))
	X	(cond ((numberp r) ($value r) (return nil)))
	X	(%warn '|litval: argument has no literal binding| (car ',z))
	X	($value 0)))
	X
	X
	X(defmacro rjust (&rest z)
	X  `(prog (val)
	X        (cond ((not (= (length ',z) 1.))
	X	       (%warn '|rjust: wrong number of arguments| ',z)
	X               (return nil)))
	X        (setq val ($varbind (car ',z)))
	X	(cond ((or (not (numberp val)) (< val 1.) (> val 127.))
	X	       (%warn '|rjust: illegal value for field width| val)
	X	       (return nil)))
	X        ($value '|=== R J U S T ===|)
	X	($value val)))
	X
	X
	X(defmacro crlf()
	X     ($value '|=== C R L F ===|))
	X
	X(defmacro tabto (&rest z)
	X  `(prog (val)
	X        (cond ((not (= (length ',z) 1.))
	X	       (%warn '|tabto: wrong number of arguments| ',z)
	X	       (return nil)))
	X        (setq val ($varbind (car ',z)))
	X	(cond ((or (not (numberp val)) (< val 1.) (> val 127.))
	X	       (%warn '|tabto: illegal column number| ',z)
	X	       (return nil)))
	X        ($value '|=== T A B T O ===|)
	X	($value val)))
	X
	X
	X
	X;;; Printing WM
	X
	X(defmacro ppwm (&rest z)
	X  `(prog (next a avlist)
	X        (setq avlist ',z)
	X        (setq *filters* nil)
	X        (setq next 1.)
	X   l   (and (atom avlist) (go print))
	X        (setq a (car avlist))
	X        (setq avlist (cdr avlist))
	X        (cond ((eq a #\^)
	X               (setq next (car avlist))
	X               (setq avlist (cdr avlist))
	X               (setq next ($litbind next))
	X               (and (floatp next) (setq next (round next)))
	X               (cond ((or (not (numberp next))
	X                          (> next *size-result-array*)
	X                          (> 1. next))
	X                      (%warn '|illegal index after ^| next)
	X                      (return nil))))
	X              ((variablep a)
	X               (%warn '|ppwm does not take variables| a)
	X               (return nil))
	X              (t (setq *filters* (cons next (cons a *filters*)))
	X                 (setq next (1+ next))))
	X        (go l)
	X   print (mapwm (function ppwm2))
	X        (terpri)
	X        (return nil))) 
	X
	X(defun ppwm2 (elm-tag)
	X  (cond ((filter (car elm-tag)) (terpri) (ppelm (car elm-tag) t)))) 
	X
	X(defun filter (elm)
	X  (prog (fl indx val)
	X        (setq fl *filters*)
	X   top  (and (atom fl) (return t))
	X        (setq indx (car fl))
	X        (setq val (cadr fl))
	X        (setq fl (cddr fl))
	X        (and (ident (nth (1- indx) elm) val) (go top))
	X        (return nil))) 
	X
	X(defun ident (x y)
	X  (cond ((eq x y) t)
	X        ((not (numberp x)) nil)
	X        ((not (numberp y)) nil)
	X        ((=alg x y) t)
	X        (t nil))) 
	X
	X; the new ppelm is designed especially to handle literalize format
	X; however, it will do as well as the old ppelm on other formats
	X
	X(defun ppelm (elm port)
	X  (prog (ppdat sep val att mode lastpos)
	X	(princ (creation-time elm) port)
	X	(princ '|:  | port)
	X        (setq mode 'vector)
	X	(setq ppdat (get (car elm) 'ppdat))
	X	(and ppdat (setq mode 'a-v))
	X	(setq sep '|(|)
	X        (setq lastpos 0)
	X	(do
	X	 ((curpos 1 (1+ curpos)) (vlist elm (cdr vlist)))
	X	 ((atom vlist) nil)
	X	 (setq val (car vlist))
	X	 (setq att (assoc curpos ppdat))
	X	 (cond (att (setq att (cdr att)))
	X	       (t (setq att curpos)))
	X         (and (symbolp att) (is-vector-attribute att) (setq mode 'vector))
	X	 (cond ((or (not (null val)) (eq mode 'vector))
	X		(princ sep port)
	X		(ppval val att lastpos port)
	X		(setq sep '|    |)
	X		(setq lastpos curpos))))
	X	(princ '|)| port)))
	X
	X(defun ppval (val att lastpos port)
	X  (cond ((not (equal att (1+ lastpos)))
	X         (princ '^ port)
	X         (princ att port)
	X         (princ '| | port)))
	X  (princ val port))
	X
	X
	X
	X;;; printing production memory
	X
	X(defmacro pm (&rest z)  `(progn (mapc #'pprule ',z) (terpri) nil)) 
	X
	X;Major modification here, because Common Lisp doesn't have a standard method
	X;for determining the column position of the cursor.  So we have to keep count.
	X;So colprinc records the current column number and prints the symbol.
	X
	X(proclaim '(special *current-col*))
	X(setq *current-col* 0)
	X
	X(defun nflatc(x)
	X   (length (princ-to-string x)))
	X
	X(defun colprinc(x)
	X    (setq *current-col* (+ *current-col* (nflatc x)))
	X    (princ x))
	X
	X(defun pprule (name)
	X  (prog (matrix next lab)
	X        (terpri)
	X        (setq *current-col* 0)
	X        (and (not (symbolp name)) (return nil))
	X        (setq matrix (get name 'production))
	X	(and (null matrix) (return nil))
	X	(terpri)
	X	(colprinc '|(p |)
	X	(colprinc name)
	X   top	(and (atom matrix) (go fin))
	X        (setq next (car matrix))
	X	(setq matrix (cdr matrix))
	X	(setq lab nil)
	X	(terpri)
	X	(cond ((eq next '-)
	X	       (colprinc '|  - |)
	X	       (setq next (car matrix))
	X	       (setq matrix (cdr matrix)))
	X	      ((eq next '-->)
	X	       (colprinc '|  |))
	X	      ((and (eq next '{) (atom (car matrix)))
	X	       (colprinc '|   {|)
	X	       (setq lab (car matrix))
	X	       (setq next (cadr matrix))
	X	       (setq matrix (cdddr matrix)))
	X	      ((eq next '{)
	X	       (colprinc '|   {|)
	X	       (setq lab (cadr matrix))
	X	       (setq next (car matrix))
	X	       (setq matrix (cdddr matrix)))
	X	      (t (colprinc '|    |)))
	X        (ppline next)
	X	(cond (lab (colprinc '| |) (colprinc lab) (colprinc '})))
	X	(go top)
	X    fin	(colprinc '|)|)))
	X
	X(defun ppline (line)
	X  (prog ()
	X	(cond ((atom line) (colprinc line))
	X              ((equalp (symbol-name (car line)) "DISPLACED") ;don't print expanded macros
	X               (ppline (cadr line)))
	X	      (t
	X	       (colprinc '|(|)
	X	       (setq *ppline* line)
	X	       (ppline2)
	X	       (colprinc '|)|)))
	X        (return nil)))
	X
	X(defun ppline2 ()
	X  (prog (needspace)
	X        (setq needspace nil)
	X   top  (and (atom *ppline*) (return nil))
	X        (and needspace (colprinc '| |))
	X        (cond ((eq (car *ppline*) #\^) (ppattval))
	X	      (t (pponlyval)))
	X        (setq needspace t)
	X        (go top)))
	X
	X;NWRITN, sort of. 
	X(defun nwritn(&optional port)
	X   (- 76 *current-col*))
	X
	X(defun ppattval ()
	X  (prog (att val)
	X        (setq att (cadr *ppline*))
	X	(setq *ppline* (cddr *ppline*))
	X	(setq val (getval))
	X	(cond ((> (+ (nwritn) (nflatc att) (nflatc val)) 76.)
	X	       (terpri)
	X	       (colprinc '|        |)))
	X        (colprinc '^)
	X	(colprinc att)
	X	(mapc (function (lambda (z) (colprinc '| |) (colprinc z))) val)))
	X
	X(defun pponlyval ()
	X  (prog (val needspace)
	X	(setq val (getval))
	X	(setq needspace nil)
	X	(cond ((> (+ (nwritn) (nflatc val)) 76.)
	X	       (setq needspace nil)
	X	       (terpri)
	X	       (colprinc '|        |)))
	X    top	(and (atom val) (return nil))
	X        (and needspace (colprinc '| |))
	X	(setq needspace t)
	X	(colprinc (car val))
	X	(setq val (cdr val))
	X	(go top)))
	X
	X(defun getval ()
	X  (prog (res v1)
	X        (setq v1 (car *ppline*))
	X	(setq *ppline* (cdr *ppline*))
	X	(cond ((member v1 '(= <> < <= => > <=>) :test #'eq)
	X	       (setq res (cons v1 (getval))))
	X	      ((eq v1 '{)
	X	       (setq res (cons v1 (getupto '}))))
	X	      ((eq v1 '<<)
	X	       (setq res (cons v1 (getupto '>>))))
	X	      ((eq v1 '//)
	X	       (setq res (list v1 (car *ppline*)))
	X	       (setq *ppline* (cdr *ppline*)))
	X	      (t (setq res (list v1))))
	X        (return res)))
	X
	X(defun getupto (end)
	X  (prog (v)
	X        (and (atom *ppline*) (return nil))
	X	(setq v (car *ppline*))
	X	(setq *ppline* (cdr *ppline*))
	X	(cond ((eq v end) (return (list v)))
	X	      (t (return (cons v (getupto end))))))) 
	X
	X
	X
	X
	X
	X
	X;;; backing up
	X
	X
	X
	X(defun record-index-plus (k)
	X  (setq *record-index* (+ k *record-index*))
	X  (cond ((< *record-index* 0.)
	X         (setq *record-index* *max-record-index*))
	X        ((> *record-index* *max-record-index*)
	X         (setq *record-index* 0.)))) 
	X
	X; the following routine initializes the record.  putting nil in the
	X; first slot indicates that that the record does not go back further
	X; than that.  (when the system backs up, it writes nil over the used
	X; records so that it will recognize which records it has used.  thus
	X; the system is set up anyway never to back over a nil.)
	X
	X(defun initialize-record nil
	X  (setq *record-index* 0.)
	X  (setq *recording* nil)
	X  (setq *max-record-index* 31.)
	X  (putvector *record-array* 0. nil)) 
	X
	X; *max-record-index* holds the maximum legal index for record-array
	X; so it and the following must be changed at the same time
	X
	X(defun begin-record (p data)
	X  (setq *recording* t)
	X  (setq *record* (list '=>refract p data))) 
	X
	X(defun end-record nil
	X  (cond (*recording*
	X         (setq *record*
	X               (cons *cycle-count* (cons *p-name* *record*)))
	X         (record-index-plus 1.)
	X         (putvector *record-array* *record-index* *record*)
	X         (setq *record* nil)
	X         (setq *recording* nil)))) 
	X
	X(defun record-change (direct time elm)
	X  (cond (*recording*
	X         (setq *record*
	X               (cons direct (cons time (cons elm *record*))))))) 
	X
	X; to maintain refraction information, need keep only one piece of information:
	X; need to record all unsuccessful attempts to delete things from the conflict
	X; set.  unsuccessful deletes are caused by attempting to delete refracted
	X; instantiations.  when backing up, have to avoid putting things back into the
	X; conflict set if they were not deleted when running forward
	X
	X(defun record-refract (rule data)
	X  (and *recording*
	X       (setq *record* (cons '<=refract (cons rule (cons data *record*))))))
	X
	X(defun refracted (rule data)
	X  (prog (z)
	X        (and (null *refracts*) (return nil))
	X	(setq z (cons rule data))
	X	(return (member z *refracts*))))
	X
	X(defun back (k)
	X  (prog (r)
	X   l   (and (< k 1.) (return nil))
	X        (setq r (getvector *record-array* *record-index*))
	X        (and (null r) (return '|nothing more stored|))
	X        (putvector *record-array* *record-index* nil)
	X        (record-index-plus -1.)
	X        (undo-record r)
	X        (setq k (1- k))
	X        (go l))) 
	X
	X(defun undo-record (r)
	X  (prog (save act a b rate)
	X        ;*recording* must be off during back up
	X        (setq save *recording*)
	X        (setq *refracts* nil)
	X        (setq *recording* nil)
	X        (and *ptrace* (back-print (list 'undo (car r) (cadr r))))
	X        (setq r (cddr r))
	X   top  (and (atom r) (go fin))
	X        (setq act (car r))
	X        (setq a (cadr r))
	X        (setq b (caddr r))
	X        (setq r (cdddr r))
	X        (and *wtrace* (back-print (list 'undo act a)))
	X        (cond ((eq act '<=wm) (add-to-wm b a))
	X              ((eq act '=>wm) (remove-from-wm b))
	X              ((eq act '<=refract)
	X               (setq *refracts* (cons (cons a b) *refracts*)))
	X              ((and (eq act '=>refract) (still-present b))
	X	       (setq *refracts* (delete (cons a b) *refracts*))
	X               (setq rate (rating-part (get a 'topnode)))
	X               (removecs a b)
	X               (insertcs a b rate))
	X              (t (%warn '|back: cannot undo action| (list act a))))
	X        (go top)
	X   fin  (setq *recording* save)
	X        (setq *refracts* nil)
	X        (return nil))) 
	X
	X; still-present makes sure that the user has not deleted something
	X; from wm which occurs in the instantiation about to be restored; it
	X; makes the check by determining whether each wme still has a time tag.
	X
	X(defun still-present (data)
	X  (prog nil
	X   l   (cond ((atom data) (return t))
	X              ((creation-time (car data))
	X               (setq data (cdr data))
	X               (go l))
	X              (t (return nil))))) 
	X
	X
	X(defun back-print (x) 
	X  (prog (port)
	X        (setq port (trace-file))
	X        (terpri port)
	X	(print x port)))
	X
	X
	X
	X
	X;;; Functions to show how close rules are to firing
	X
	X(defmacro matches (&rest rule-list)
	X  `(progn 
	X    (mapc (function matches2) ',rule-list)
	X    (terpri)) )
	X
	X(defun matches2 (p)
	X  (cond ((atom p)
	X         (terpri)
	X         (terpri)
	X         (princ p)
	X         (matches3 (get p 'backpointers) 2. (cons 1. nil))))) 
	X
	X(defun matches3 (nodes ce part)
	X  (cond ((not (null nodes))
	X         (terpri)
	X         (princ '| ** matches for |)
	X         (princ part)
	X         (princ '| ** |)
	X         (mapc (function write-elms) (find-left-mem (car nodes)))
	X         (terpri)
	X         (princ '| ** matches for |)
	X         (princ (cons ce nil))
	X         (princ '| ** |)
	X         (mapc (function write-elms) (find-right-mem (car nodes)))
	X         (matches3 (cdr nodes) (1+ ce) (cons ce part))))) 
	X
	X(defun write-elms (wme-or-count)
	X  (cond ((listp wme-or-count)
	X	 (terpri)
	X	 (mapc (function write-elms2) wme-or-count)))) 
	X
	X(defun write-elms2 (x)
	X  (princ '|  |)
	X  (princ (creation-time x)))
	X
	X(defun find-left-mem (node)
	X  (cond ((eq (car node) '&and) (memory-part (caddr node)))
	X        (t (car (caddr node))))) 
	X
	X(defun find-right-mem (node) (memory-part (cadddr node))) 
	X
	X
	X;;; Check the RHSs of productions 
	X
	X
	X(defun check-rhs (rhs) (mapc (function check-action) rhs))
	X
	X(defun check-action (x)
	X  (prog (a)
	X    (cond ((atom x)
	X           (%warn '|atomic action| x)
	X	   (return nil)))
	X    (setq a  (car x))
	X    (cond ((eq a 'bind) (check-bind x))
	X          ((eq a 'cbind) (check-cbind x))
	X          ((eq a 'make) (check-make x))
	X          ((eq a 'modify) (check-modify x))
	X          ((eq a 'oremove) (check-remove x))
	X          ((eq a 'owrite) (check-write x))
	X          ((eq a 'ocall) (check-call x))
	X          ((eq a 'halt) (check-halt x))
	X          ((eq a 'openfile) (check-openfile x))
	X          ((eq a 'closefile) (check-closefile x))
	X          ((eq a 'default) (check-default x))
	X          ((eq a 'build) (check-build x))
	X          ;;the following section is responsible for replacing standard ops RHS actions
	X          ;;with actions which don't conflict with existing CL functions.  The RPLACA function
	X          ;;is used so that the change will be reflected in the production body.
	X          ((eq a 'remove) (rplaca x 'oremove) 
	X                          (check-remove x))
	X          ((eq a 'write)   (rplaca x 'owrite)
	X                          (check-write x)) 
	X          ((eq a 'call)   (rplaca x 'ocall)
	X                          (check-call x))
	X          (t (%warn '|undefined rhs action| a))))) 
	X
	X(defun check-build (z)
	X  (and (null (cdr z)) (%warn '|needs arguments| z))
	X  (check-build-collect (cdr z)))
	X
	X(defun check-build-collect (args)
	X  (prog (r)
	X    top	(and (null args) (return nil))
	X	(setq r (car args))
	X	(setq args (cdr args))
	X	(cond ((listp r) (check-build-collect r))
	X	      ((eq r '\\)
	X	       (and (null args) (%warn '|nothing to evaluate| r))
	X	       (check-rhs-value (car args))
	X	       (setq args (cdr args))))
	X	(go top)))
	X
	X(defun check-remove (z) 
	X  (and (null (cdr z)) (%warn '|needs arguments| z))
	X  (mapc (function check-rhs-ce-var) (cdr z))) 
	X
	X(defun check-make (z)
	X  (and (null (cdr z)) (%warn '|needs arguments| z))
	X  (check-change& (cdr z))) 
	X
	X(defun check-openfile (z)
	X  (and (null (cdr z)) (%warn '|needs arguments| z))
	X  (check-change& (cdr z))) 
	X
	X(defun check-closefile (z)
	X  (and (null (cdr z)) (%warn '|needs arguments| z))
	X  (check-change& (cdr z))) 
	X
	X(defun check-default (z)
	X  (and (null (cdr z)) (%warn '|needs arguments| z))
	X  (check-change& (cdr z))) 
	X
	X(defun check-modify (z)
	X  (and (null (cdr z)) (%warn '|needs arguments| z))
	X  (check-rhs-ce-var (cadr z))
	X  (and (null (cddr z)) (%warn '|no changes to make| z))
	X  (check-change& (cddr z))) 
	X
	X(defun check-write (z)
	X  (and (null (cdr z)) (%warn '|needs arguments| z))
	X  (check-change& (cdr z))) 
	X
	X(defun check-call (z)
	X  (prog (f)
	X    (and (null (cdr z)) (%warn '|needs arguments| z))
	X    (setq f (cadr z))
	X    (and (variablep f)
	X         (%warn '|function name must be a constant| z))
	X    (or (symbolp f)
	X        (%warn '|function name must be a symbolic atom| f))
	X    (or (externalp f)
	X        (%warn '|function name not declared external| f))
	X    (check-change& (cddr z)))) 
	X
	X(defun check-halt (z)
	X  (or (null (cdr z)) (%warn '|does not take arguments| z))) 
	X
	X(defun check-cbind (z)
	X  (prog (v)
	X    (or (= (length z) 2.) (%warn '|takes only one argument| z))
	X    (setq v (cadr z))
	X    (or (variablep v) (%warn '|takes variable as argument| z))
	X    (note-ce-variable v))) 
	X
	X(defun check-bind (z)
	X  (prog (v)
	X    (or (> (length z) 1.) (%warn '|needs arguments| z))
	X    (setq v (cadr z))
	X    (or (variablep v) (%warn '|takes variable as argument| z))
	X    (note-variable v)
	X    (check-change& (cddr z)))) 
	X
	X
	X(defun check-change& (z)
	X  (prog (r tab-flag)
	X        (setq tab-flag nil)
	X   la   (and (atom z) (return nil))
	X        (setq r (car z))
	X        (setq z (cdr z))
	X        (cond ((eq r #\^)
	X               (and tab-flag
	X                    (%warn '|no value before this tab| (car z)))
	X               (setq tab-flag t)
	X               (check-tab-index (car z))
	X               (setq z (cdr z)))
	X              ((eq r '//) (setq tab-flag nil) (setq z (cdr z)))
	X              (t (setq tab-flag nil) (check-rhs-value r)))
	X        (go la))) 
	X
	X(defun check-rhs-ce-var (v)
	X  (cond ((and (not (numberp v)) (not (ce-bound? v)))
	X         (%warn '|unbound element variable| v))
	X        ((and (numberp v) (or (< v 1.) (> v *ce-count*)))
	X         (%warn '|numeric element designator out of bounds| v)))) 
	X
	X(defun check-rhs-value (x)
	X  (cond ((and x (listp x)) (check-rhs-function x))
	X        (t (check-rhs-atomic x)))) 
	X
	X(defun check-rhs-atomic (x)
	X  (and (variablep x) 
	X       (not (bound? x)) 
	X       (%warn '|unbound variable| x)))
	X
	X(defun check-rhs-function (x)
	X  (prog (a)
	X    (setq a (car x))
	X    (cond ((eq a 'compute) (check-compute x))
	X          ((eq a 'arith) (check-compute x))
	X          ((eq a 'substr) (check-substr x))
	X          ((eq a 'accept) (check-accept x))
	X          ((eq a 'acceptline) (check-acceptline x))
	X          ((eq a 'crlf) (check-crlf x))
	X          ((eq a 'genatom) (check-genatom x))
	X	  ((eq a 'litval) (check-litval x))
	X          ((eq a 'tabto) (check-tabto x))
	X	  ((eq a 'rjust) (check-rjust x))
	X	  ((not (externalp a))
	X	   (%warn '"rhs function not declared external" a)))))
	X
	X(defun check-litval (x) 
	X  (or (= (length x) 2) (%warn '|wrong number of arguments| x))
	X  (check-rhs-atomic (cadr x)))
	X
	X(defun check-accept (x)
	X  (cond ((= (length x) 1) nil)
	X        ((= (length x) 2) (check-rhs-atomic (cadr x)))
	X	(t (%warn '|too many arguments| x))))
	X
	X(defun check-acceptline (x)
	X  (mapc (function check-rhs-atomic) (cdr x)))
	X
	X(defun check-crlf (x) 
	X  (check-0-args x)) 
	X
	X(defun check-genatom (x) (check-0-args x)) 
	X
	X(defun check-tabto (x)
	X  (or (= (length x) 2) (%warn '|wrong number of arguments| x))
	X  (check-print-control (cadr x)))
	X
	X(defun check-rjust (x)
	X  (or (= (length x) 2) (%warn '|wrong number of arguments| x))
	X  (check-print-control (cadr x)))
	X
	X(defun check-0-args (x)
	X  (or (= (length x) 1.) (%warn '|should not have arguments| x))) 
	X
	X(defun check-substr (x)
	X  (or (= (length x) 4.) (%warn '|wrong number of arguments| x))
	X  (check-rhs-ce-var (cadr x))
	X  (check-substr-index (caddr x))
	X  (check-last-substr-index (cadddr x))) 
	X
	X(defun check-compute (x) (check-arithmetic (cdr x))) 
	X
	X(defun check-arithmetic (l)
	X  (cond ((atom l)
	X         (%warn '|syntax error in arithmetic expression| l))
	X        ((atom (cdr l)) (check-term (car l)))
	X        ((not (member (cadr l) '(+ - * // \\) :test #'eq))
	X         (%warn '|unknown operator| l))
	X        (t (check-term (car l)) (check-arithmetic (cddr l))))) 
	X
	X(defun check-term (x)
	X  (cond ((listp x) (check-arithmetic x))
	X        (t (check-rhs-atomic x)))) 
	X
	X(defun check-last-substr-index (x)
	X  (or (eq x 'inf) (check-substr-index x))) 
	X
	X(defun check-substr-index (x)
	X  (prog (v)
	X    (cond ((bound? x) (return x)))
	X    (setq v ($litbind x))
	X    (cond ((not (numberp v))
	X           (%warn '|unbound symbol used as index in substr| x))
	X          ((or (< v 1.) (> v 127.))
	X           (%warn '|index out of bounds in tab| x))))) 
	X
	X(defun check-print-control (x)
	X  (prog ()
	X    (cond ((bound? x) (return x)))
	X    (cond ((or (not (numberp x)) (< x 1.) (> x 127.))
	X           (%warn '|illegal value for printer control| x))))) 
	X
	X(defun check-tab-index (x)
	X  (prog (v)
	X    (cond ((bound? x) (return x)))
	X    (setq v ($litbind x))
	X    (cond ((not (numberp v))
	X           (%warn '|unbound symbol occurs after ^| x))
	X          ((or (< v 1.) (> v 127.))
	X           (%warn '|index out of bounds after ^| x))))) 
	X
	X(defun note-variable (var)
	X  (setq *rhs-bound-vars* (cons var *rhs-bound-vars*)))
	X
	X(defun bound? (var)
	X  (or (member var *rhs-bound-vars* :test #'eq)
	X      (var-dope var)))
	X
	X(defun note-ce-variable (ce-var)
	X  (setq *rhs-bound-ce-vars* (cons ce-var *rhs-bound-ce-vars*)))
	X
	X(defun ce-bound? (ce-var)
	X  (or (member ce-var *rhs-bound-ce-vars* :test #'eq)
	X      (ce-var-dope ce-var)))
	X
	X;;; Top level routines
	X
	X(defun process-changes (adds dels)
	X  (prog (x)
	X   process-deletes (and (atom dels) (go process-adds))
	X        (setq x (car dels))
	X        (setq dels (cdr dels))
	X        (remove-from-wm x)
	X        (go process-deletes)
	X   process-adds (and (atom adds) (return nil))
	X        (setq x (car adds))
	X        (setq adds (cdr adds))
	X        (add-to-wm x nil)
	X        (go process-adds))) 
	X
	X(defun main nil
	X  (prog (instance r)
	X        (setq *halt-flag* nil)
	X        (setq *break-flag* nil)
	X        (setq instance nil)
	X   dil  (setq *phase* 'conflict-resolution)
	X        (cond (*halt-flag*
	X               (setq r '|end -- explicit halt|)
	X               (go finis))
	X	      ((zerop *remaining-cycles*)
	X	       (setq r '***break***)
	X	       (setq *break-flag* t)
	X	       (go finis))
	X              (*break-flag* (setq r '***break***) (go finis)))
	X	(setq *remaining-cycles* (1- *remaining-cycles*))
	X        (setq instance (conflict-resolution))
	X        (cond ((not instance)
	X               (setq r '|end -- no production true|)
	X               (go finis)))
	X        (setq *phase* (car instance))
	X        (accum-stats)
	X        (eval-rhs (car instance) (cdr instance))
	X        (check-limits)
	X	(and (broken (car instance)) (setq *break-flag* t))
	X        (go dil)
	X  finis (setq *p-name* nil)
	X        (return r))) 
	X
	X(defun do-continue (wmi)
	X    (cond (*critical*
	X           (terpri)
	X           (princ '|warning: network may be inconsistent|)))
	X    (process-changes wmi nil)
	X    (print-times (main))) 
	X
	X(defun accum-stats nil
	X  (setq *cycle-count* (1+ *cycle-count*))
	X  (setq *total-token* (+ *total-token* *current-token*))
	X  (cond ((> *current-token* *max-token*)
	X         (setq *max-token* *current-token*)))
	X  (setq *total-wm* (+ *total-wm* *current-wm*))
	X  (cond ((> *current-wm* *max-wm*) (setq *max-wm* *current-wm*)))) 
	X
	X
	X(defun print-times (mess)
	X  (prog (cc ac)
	X    	(cond (*break-flag* (terpri) (return mess)))
	X        (setq cc (+ (float *cycle-count*) 1.0e-20))
	X        (setq ac (+ (float *action-count*) 1.0e-20))
	X        (terpri)
	X        (princ mess)
	X        (pm-size)
	X        (printlinec (list *cycle-count*
	X                          'firings
	X                          (list *action-count* 'rhs 'actions)))
	X        (terpri)
	X        (printlinec (list (round (/ (float *total-wm*) cc))
	X                          'mean 'working 'memory 'size
	X                          (list *max-wm* 'maximum)))
	X        (terpri)
	X        (printlinec (list (round (/ (float *total-cs*) cc))
	X                          'mean 'conflict 'set 'size
	X                          (list *max-cs* 'maximum)))
	X        (terpri)
	X        (printlinec (list (round (/ (float *total-token*) cc))
	X                          'mean 'token 'memory 'size
	X                          (list *max-token* 'maximum)))
	X        (terpri))) 
	X
	X(defun pm-size nil
	X  (terpri)
	X  (printlinec (list *pcount*
	X                    'productions
	X                    (list *real-cnt* '// *virtual-cnt* 'nodes)))
	X  (terpri)) 
	X
	X(defun check-limits nil
	X  (cond ((> (length *conflict-set*) *limit-cs*)
	X         (terpri)
	X         (terpri)
	X         (printlinec (list '|conflict set size exceeded the limit of|
	X                           *limit-cs*
	X                           '|after|
	X                           *p-name*))
	X         (setq *halt-flag* t)))
	X  (cond ((> *current-token* *limit-token*)
	X         (terpri)
	X         (terpri)
	X         (printlinec (list '|token memory size exceeded the limit of|
	X                           *limit-token*
	X                           '|after|
	X                           *p-name*))
	X         (setq *halt-flag* t)))) 
	X
	X
	X(defun top-level-remove (z)
	X  (cond ((equal z '(*)) (process-changes nil (get-wm nil)))
	X        (t (process-changes nil (get-wm z))))) 
	X
	X(defmacro excise (&rest z) `(mapc (function excise-p) ',z))
	X
	X(defmacro run (&rest z)
	X  `(cond ((null ',z) (setq *remaining-cycles* 1000000.) (do-continue nil))
	X        ((and (atom (cdr ',z)) (numberp (car ',z)) (> (car ',z) 0.))
	X         (setq *remaining-cycles* (car ',z))
	X         (do-continue nil))
	X        (t 'what\?))) 
	X
	X(defmacro strategy (&rest z)
	X  `(cond ((atom ',z) *strategy*)
	X        ((equal ',z '(lex)) (setq *strategy* 'lex))
	X        ((equal ',z '(mea)) (setq *strategy* 'mea))
	X        (t 'what\?))) 
	X
	X(defmacro cs (&optional z)
	X  `(cond ((null ',z) (conflict-set))
	X        (t 'what?))) 
	X
	X(defmacro watch (&rest z)
	X  `(cond ((equal ',z '(0.))
	X         (setq *wtrace* nil)
	X         (setq *ptrace* nil)
	X         0.)
	X        ((equal ',z '(1.)) (setq *wtrace* nil) (setq *ptrace* t) 1.)
	X        ((equal ',z '(2.)) (setq *wtrace* t) (setq *ptrace* t) 2.)
	X        ((equal ',z '(3.))
	X         (setq *wtrace* t)
	X         (setq *ptrace* t)
	X         '(2. -- conflict set trace not supported))
	X        ((and (atom ',z) (null *ptrace*)) 0.)
	X        ((and (atom ',z) (null *wtrace*)) 1.)
	X        ((atom ',z) 2.)
	X        (t 'what\?))) 
	X
	X(defmacro external  (&rest z) `(catch (external2 ',z) '!error!))
	X
	X(defun external2 (z) (mapc (function external3) z))
	X
	X(defun external3 (x) 
	X  (cond ((symbolp x) (putprop x t 'external-routine)
	X		     (setq *externals* (enter x *externals*)))
	X	(t (%error '|not a legal function name| x))))
	X
	X(defun externalp (x)
	X  (cond ((symbolp x) (get x 'external-routine))
	X	(t (%warn '|not a legal function name| x) nil)))
	X
	X(defmacro pbreak (&rest z)
	X  `(cond ((atom ',z) (terpri) *brkpts*)
	X	(t (mapc (function pbreak2) ',z) nil)))
	X
	X(defun pbreak2 (rule)
	X  (cond ((not (symbolp rule)) (%warn '|illegal name| rule))
	X	((not (get rule 'topnode)) (%warn '|not a production| rule))
	X	((member rule *brkpts* :test #'eq) (setq *brkpts* (rematm rule *brkpts*)))
	X	(t (setq *brkpts* (cons rule *brkpts*)))))
	X
	X(defun rematm (atm list)
	X  (cond ((atom list) list)
	X	((eq atm (car list)) (rematm atm (cdr list)))
	X	(t (cons (car list) (rematm atm (cdr list))))))
	X
	X(defun broken (rule) (member rule *brkpts* :test #'eq))
	X
	X
	XFRANZ.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;	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
	X;   Modifications added starting July, 1982 to make it easier to build 
	X;   user environment - Ruven Brooks
	X;                      ITT Integrated Systems Center
	X;                      1 Research Drive
	X;                      Shelton, CT.
	X
	X;;; Definitions
	X
	X
	X
	X(declare (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(def == (macro (z) `(eq ,(cadr z) ,(caddr z))))
	X
	X; =ALG returns T if A and B are algebraicly equal.
	X
	X(defun =alg (a b) (zerop (difference a b)))
	X
	X(def fast-symeval 
	X  (macro (z)
	X	 `(cond ((eq ,(cadr z) '*c1*) *c1*)
	X		((eq ,(cadr z) '*c2*) *c2*)
	X		((eq ,(cadr z) '*c3*) *c3*)
	X		((eq ,(cadr z) '*c4*) *c4*)
	X		((eq ,(cadr z) '*c5*) *c5*)
	X		((eq ,(cadr z) '*c6*) *c6*)
	X		((eq ,(cadr z) '*c7*) *c7*)
	X		(t (eval ,(cadr 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
	X; Example call: (putvector array index value)
	X
	X(def putvector
	X  (macro (z)
	X    (list '*rplacx (caddr z) (cadr z) (cadddr z))]
	X
	X; Example call: (getvector name index)
	X
	X(def getvector
	X  (macro (z)
	X    (list 'cxr (caddr z) (cadr z))]
	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 (/ 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  (cond ((atom x) nil)
	X        ((memq (car x) y) (cons (car x) (interq (cdr x) y)))
	X        (t (interq (cdr x) y)))) 
	X
	X(defun enter (x ll)
	X   (and (not (member x ll)) (setq ll (cons x ll))))
	X
	X; later versions of Franz have this standard
	X(defun neq (x y)
	X   (not (eq x y)))
	X(defun i-g-v nil
	X (prog (x)
	X	(sstatus translink t)
	X	(setsyntax '\{ 66.)
	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	(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* (*makhunk 6))
	X	(setq *record-array* (*makhunk 6))
	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; 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\! \!error\!)) 
	X
	X(defun round (x) (fix (plus 0.5 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(defun literal fexpr (z)
	X  (prog (atm val old)
	X   top  (and (atom z) (return 'bound))
	X        (or (eq (cadr z) '=) (return (%warn '|wrong format| z)))
	X        (setq atm (car z))
	X        (setq val (caddr z))
	X        (setq z (cdddr z))
	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(defun literalize fexpr (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(defun vector-attribute fexpr (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              ((memq (car la) lb) (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 (memq b old))
	X         (putprop a (cons b old) 'conflicts)))) 
	X
	X(defun remove-duplicates (lst)
	X  (cond ((atom lst) nil)
	X        ((memq (car lst) (cdr lst)) (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 (memq name buc))
	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 (ncons k) 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(def erase-literal-info
	X     (lambda (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(defun p fexpr (z) 
	X  (finish-literalize)
	X  (princ '*) 
	X  (drain)
	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 (cmp-p name matrix) \!error\!))
	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) (dtpr 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))
-- 
---------------
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