koreth@ssyx.ucsc.edu (Steven Grimm) (06/02/88)
Submitted-by: cfc@wjh12.harvard.edu (Christopher F. Chabris)
Posting-number: Volume 1, Issue 51
Archive-name: ops5/part03
#!/bin/sh
# this is part 3 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file ops5 continued
#
CurArch=3
if test ! -r s2_seq_.tmp
then echo "Please unpack part 1 first!"
exit 1; fi
( read Scheck
if test "$Scheck" != $CurArch
then echo "Please unpack part $Scheck next!"
exit 1;
else exit 0; fi
) < s2_seq_.tmp || exit 1
sed 's/^X//' << 'SHAR_EOF' >> ops5
X file)
X (return nil))
X ((eq use 'write) (setq *write-file* file))
X ((eq use 'accept) (setq *accept-file* file))
X ((eq use 'trace) (setq *trace-file* file)))
X (return nil)))
X
X
X%%% RHS Functions
X
X(df accept z
X (prog (port arg)
X (cond
X ((igreaterp (length z) 1)
X (!%warn "accept: wrong number of arguments" z)
X (return nil)))
X (setq port nil)
X (cond
X (*accept-file*
X (setq port ($ifile *accept-file*))
X (cond
X ((null port)
X (!%warn
X "accept: file has been closed"
X *accept-file*)
X (return nil)))) )
X (cond
X ((eq (length z) 1)
X (setq arg ($varbind (car z)))
X (cond
X ((not (idp arg))
X (!%warn "accept: illegal file name" arg)
X (return nil)))
X (setq port ($ifile arg))
X (cond
X ((null port)
X (!%warn "accept: file not open for input" arg)
X (return nil)))) )
X (cond
X ((eq (!!tyipeek port) (!!minus 1))
X ($value 'end-of-file)
X (return nil)))
X (flat-value (!!read port))))
X
X(de flat-value (x)
X (cond ((atom x) ($value x)) (t (!!mapc (function flat-value) x))))
X
X(de span-chars (x prt)
X (prog (ch)
X (setq ch (!!tyipeek prt))
X (while (member ch x)
X (progn (!!readc prt) (setq ch (!!tyipeek prt))))))
X
X(df acceptline z
X (prog (c def arg port)
X (setq port nil)
X (setq def z)
X (cond
X (*accept-file*
X (setq port ($ifile *accept-file*))
X (cond
X ((null port)
X (!%warn
X "acceptline: file has been closed"
X *accept-file*)
X (return nil)))) )
X (cond
X ((pairp def) %% replaces the awful (greaterp (length def) 0)
X (setq arg ($varbind (car def)))
X (cond
X ((and (idp arg) ($ifile arg))
X (setq port ($ifile arg))
X (setq def (cdr def)))) ))
X (span-chars '(9 41) port)
X (setq c (tyi port))
X (cond
X ((memq (!!tyipeek port) '(-1 10))
X (!!mapc (function $change) def)
X (return nil)))
Xl: (flat-value (!!read port))
X (span-chars '(9 41) port)
X (cond
X ((not (memq (!!tyipeek port) '(difference1 10)))
X (go l:)))) )
X
X(df substr l
X (prog (k elm start end)
X (cond
X ((not (eq (length l) 3))
X (!%warn "substr: wrong number of arguments" l)
X (return nil)))
X (setq elm (get-ce-var-bind (car l)))
X (cond
X ((null elm)
X (!%warn "first argument to substr must be a ce var" l)
X (return nil)))
X (setq start ($varbind (cadr l)))
X (setq start ($litbind start))
X (cond
X ((not (numberp start))
X (!%warn "second argument to substr must be a number" 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
X ((not (numberp end))
X (!%warn "third argument to substr must be a number" 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)
Xla (cond
X ((igreaterp k end) (return nil))
X ((not (ilessp k start)) ($value (car elm))))
X (setq elm (cdr elm))
X (setq k (iadd1 k))
X (go la)))
X
X(df compute z ($value (ari z)))
X
X% arith is the obsolete form of compute
X(df arith z ($value (ari z)))
X
X(de ari (x)
X (cond
X ((atom x) (!%warn "bad syntax in arithmetic expression " x) 0)
X ((atom (cdr x)) (ari-unit (car x)))
X ((eq (cadr x) '+) (plus (ari-unit (car x)) (ari (cddr x))))
X ((eq (cadr x) '-)
X (difference (ari-unit (car x)) (ari (cddr x))))
X ((eq (cadr x) '*) (times (ari-unit (car x)) (ari (cddr x))))
X ((eq (cadr x) '!/)
X (quotient (ari-unit (car x)) (ari (cddr x))))
X ((eq (cadr x) '!!)
X (mod (fix (ari-unit (car x))) (fix (ari (cddr x)))) )
X (t (!%warn "bad syntax in arithmetic expression " x) 0)))
X
X(de ari-unit (a)
X (prog (r)
X (cond ((pairp a) (setq r (ari a))) (t (setq r ($varbind a))))
X (cond
X ((not (numberp r))
X (!%warn "bad value in arithmetic expression" a)
X (return 0))
X (t (return r)))) )
X
X(de genatom nil ($value (gensym)))
X
X(df litval z
X (prog (r)
X (cond
X ((not (eq (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(df rjust z
X (prog (val)
X (cond
X ((not (eq (length z) 1))
X (!%warn "rjust: wrong number of arguments" z)
X (return nil)))
X (setq val ($varbind (car z)))
X (cond
X ((or (not (numberp val)) (ilessp val 1) (igreaterp 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(df crlf z
X (cond
X (z (!%warn "crlf: does not take arguments" z))
X (t ($value "=== C R L F ==="))))
X
X(df tabto z
X (prog (val)
X (cond
X ((not (eq (length z) 1))
X (!%warn "tabto: wrong number of arguments" z)
X (return nil)))
X (setq val ($varbind (car z)))
X (cond
X ((or (not (numberp val)) (ilessp val 1) (igreaterp val 127))
X (!%warn "tabto: illegal column number" z)
X (return nil)))
X ($value "=== T A B T O ===")
X ($value val)))
X
X%%% Printing WM
X
X(df ppwm avlist
X (prog (next a)
X (setq *filters* nil)
X (setq next 1)
Xl: (cond ((atom avlist) (go print)))
X (setq a (car avlist))
X (setq avlist (cdr avlist))
X (cond
X ((eq a '!^)
X (setq next (car avlist))
X (setq avlist (cdr avlist))
X (setq next ($litbind next))
X (and (floatp next) (setq next (fix next)))
X (cond
X ((or
X (not (numberp next))
X (igreaterp next *size-result-array*)
X (igreaterp 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 (iadd1 next))))
X (go l:)
Xprint (mapwm (function ppwm2))
X (terpri)
X (return nil)))
X
X(de ppwm2 (elm-tag)
X (cond ((filter (car elm-tag)) (terpri) (ppelm (car elm-tag) nil))))
X
X(de filter (elm)
X (prog (fl indx val)
X (setq fl *filters*)
Xtop (cond ((atom fl) (return t)))
X (setq indx (car fl))
X (setq val (cadr fl))
X (setq fl (cddr fl))
X (cond ((ident (nth (isub1 indx) elm) val) (go top)))
X (return nil)))
X
X(de ident (x y)
X (cond
X ((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(de ppelm (elm port)
X (prog (ppdat sep val att mode lastpos curpos vlist)
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 (setq curpos 1) (setq vlist elm)
X (while (not (atom vlist))
X (progn
X (setq val (car vlist))
X (setq att (assoc curpos ppdat))
X (cond (att (setq att (cdr att))) (t (setq att curpos)))
X (and
X (idp att)
X (is-vector-attribute att)
X (setq mode 'vector))
X (cond
X ((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 (setq curpos (iadd1 curpos))
X (setq vlist (cdr vlist))))
X (!!princ ")" port)))
X
X(de ppval (val att lastpos port)
X (cond
X ((not (eq att (iadd1 lastpos)))
X (!!princ '!^ port)
X (!!princ att port)
X (!!princ " " port)))
X (!!princ val port))
X
X%%% printing production memory
X
X(df pm z (!!mapc (function pprule) z) (terpri) nil)
X
X(de pprule (name)
X (prog (matrix next lab)
X (cond ((not (idp name)) (return nil)))
X (setq matrix (get name 'production))
X (cond ((null matrix) (return nil)))
X (terpri)
X (princ "(p ")
X (princ name)
Xtop (cond ((atom matrix) (go fin)))
X (setq next (car matrix))
X (setq matrix (cdr matrix))
X (setq lab nil)
X (terpri)
X (cond
X ((eq next '-)
X (princ " - ")
X (setq next (car matrix))
X (setq matrix (cdr matrix)))
X ((eq next '-->) (princ " "))
X ((and (eq next '!{) (atom (car matrix)))
X (princ " {")
X (setq lab (car matrix))
X (setq next (cadr matrix))
X (setq matrix (cdddr matrix)))
X ((eq next '!{)
X (princ " {")
X (setq lab (cadr matrix))
X (setq next (car matrix))
X (setq matrix (cdddr matrix)))
X (t (princ " ")))
X (ppline next)
X (cond (lab (princ " ") (princ lab) (princ '!})))
X (go top)
Xfin (princ ")")))
X
X(de ppline (line)
X (prog ()
X (cond
X ((atom line) (princ line))
X (t (princ "(") (setq *ppline* line) (ppline2) (princ ")")))
X (return nil)))
X
X(de ppline2 ()
X (prog (needspace)
X (setq needspace nil)
Xtop (cond ((atom *ppline*) (return nil)))
X (and needspace (princ " "))
X (cond ((eq (car *ppline*) '!^) (ppattval)) (t (pponlyval)))
X (setq needspace t)
X (go top)))
X
X(de ppattval ()
X (prog (att val)
X (setq att (cadr *ppline*))
X (setq *ppline* (cddr *ppline*))
X (setq val (getval))
X (cond
X ((greaterp (iplus (posn) (flatc att) (flatc val)) 76)
X (terpri)
X (princ " ")))
X (princ '!^)
X (princ att)
X (!!mapc (function (lambda (z) (princ " ") (princ z))) val)))
X
X(de pponlyval ()
X (prog (val needspace)
X (setq val (getval))
X (setq needspace nil)
X (cond
X ((greaterp (iplus (posn) (flatc val)) 76)
X (setq needspace nil)
X (terpri)
X (princ " ")))
Xtop (cond ((atom val) (return nil)))
X (and needspace (princ " "))
X (setq needspace t)
X (princ (car val))
X (setq val (cdr val))
X (go top)))
X
X(de getval ()
X (prog (res v1)
X (setq v1 (car *ppline*))
X (setq *ppline* (cdr *ppline*))
X (cond
X ((memq v1 '(= <> < <= => > <=>))
X (setq res (cons v1 (getval))))
X ((eq v1 '!{) (setq res (cons v1 (getupto '!}))))
X ((eq v1 '<<) (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(de getupto (end)
X (prog (v)
X (cond ((atom *ppline*) (return nil)))
X (setq v (car *ppline*))
X (setq *ppline* (cdr *ppline*))
X (cond
X ((eq v end) (return (list v)))
X (t (return (cons v (getupto end)))) )))
X
X
X%%% backing up
X
X(de record-index-plus (k)
X (setq *record-index* (iplus k *record-index*))
X (cond
X ((lessp *record-index* 0)
X (setq *record-index* *max-record-index*))
X ((greaterp *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(de initialize-record nil
X (setq *record-index* 0)
X (setq *recording* nil)
X (setq *max-record-index* 31)
X (putv *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(de begin-record (p data)
X (setq *recording* t)
X (setq *record* (list '=>refract p data)))
X
X(de end-record nil
X (cond
X (*recording*
X (setq *record*
X (cons *cycle-count* (cons *p-name* *record*)))
X (record-index-plus 1)
X (putv *record-array* *record-index* *record*)
X (setq *record* nil)
X (setq *recording* nil))))
X
X(de record-change (direct time elm)
X (cond
X (*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(de record-refract (rule data)
X (and
X *recording*
X (setq *record*
X (cons '<=refract (cons rule (cons data *record*)))) ))
X
X(de refracted (rule data)
X (prog (z)
X (cond ((null *refracts*) (return nil)))
X (setq z (cons rule data))
X (return (member z *refracts*))))
X
X(de back (k)
X (prog (r)
Xl: (cond ((lessp k 1) (return nil)))
X (setq r (getv *record-array* *record-index*))
X (cond ((null r) (return "nothing more stored")))
X (putv *record-array* *record-index* nil)
X (record-index-plus (!!minus 1))
X (undo-record r)
X (setq k (isub1 k))
X (go l:)))
X
X(de 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))
Xtop (cond ((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
X ((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)
Xfin (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(de still-present (data)
X (prog nil
Xl: (cond
X ((atom data) (return t))
X ((creation-time (car data)) (setq data (cdr data)) (go l:))
X (t (return nil)))) )
X
X(de back-print (x)
X (prog (port)
X (setq port (trace-file))
X (terpri port)
X (print x port)))
X
X%%% Functions to show how close rules are to firing
X
X(df matches rule-list
X (!!mapc (function matches2) rule-list)
X (terpri))
X
X(de matches2 (p)
X (cond
X ((atom p)
X (terpri)
X (terpri)
X (princ p)
X (matches3 (get p 'backpointers) 2 (ncons 1)))) )
X
X(de matches3 (nodes ce part)
X (cond
X ((not (null nodes))
X (terpri)
X (princ " ** matches for ")
X (princ part)
X (princ " ** ")
X (!!mapc (function write-elms) (find-left-mem (car nodes)))
X (terpri)
X (princ " ** matches for ")
X (princ (ncons ce))
X (princ " ** ")
X (!!mapc (function write-elms) (find-right-mem (car nodes)))
X (matches3 (cdr nodes) (iadd1 ce) (cons ce part)))) )
X
X(de write-elms (wme-or-count)
X (cond
X ((pairp wme-or-count)
X (terpri)
X (!!mapc (function write-elms2) wme-or-count))))
X
X(de write-elms2 (x) (princ " ") (princ (creation-time x)))
X
X(de find-left-mem (node)
X (cond
X ((eq (car node) '&and) (memory-part (caddr node)))
X (t (car (caddr node)))) )
X
X(de find-right-mem (node) (memory-part (cadddr node)))
X
X%%% Check the RHSs of productions
X
X(de check-rhs (rhs) (!!mapc (function check-action) rhs))
X
X(de check-action (x)
X (prog (a)
X (cond ((atom x) (!%warn "atomic action" x) (return nil)))
X (setq a (setq *action-type* (car x)))
X (cond
X ((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 '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(de check-build (z)
X (and (null (cdr z)) (!%warn "needs arguments" z))
X (check-build-collect (cdr z)))
X
X(de check-build-collect (args)
X (prog (r)
Xtop (cond ((null args) (return nil)))
X (setq r (car args))
X (setq args (cdr args))
X (cond
X ((pairp 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(de check-remove (z)
X (and (null (cdr z)) (!%warn "needs arguments" z))
X (!!mapc (function check-rhs-ce-var) (cdr z)))
X
X(de check-make (z)
X (and (null (cdr z)) (!%warn "needs arguments" z))
X (check-change& (cdr z)))
X
X(de check-openfile (z)
X (and (null (cdr z)) (!%warn "needs arguments" z))
X (check-change& (cdr z)))
X
X(de check-closefile (z)
X (and (null (cdr z)) (!%warn "needs arguments" z))
X (check-change& (cdr z)))
X
X(de check-default (z)
X (and (null (cdr z)) (!%warn "needs arguments" z))
X (check-change& (cdr z)))
X
X(de 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(de check-write (z)
X (and (null (cdr z)) (!%warn "needs arguments" z))
X (check-change& (cdr z)))
X
X(de check-call (z)
X (prog (f)
X (and (null (cdr z)) (!%warn "needs arguments" z))
X (setq f (cadr z))
X (and
X (variablep f)
X (!%warn "function name must be a constant" z))
X (or
X (idp f)
X (!%warn "function name must be a symbolic atom" f))
X (or
X (externalp f)
X (!%warn "function name not declared external" f))
X (check-change& (cddr z))))
X
X(de check-halt (z)
X (or (null (cdr z)) (!%warn "does not take arguments" z)))
X
X(de check-cbind (z)
X (prog (v)
X (or (eq (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(de check-bind (z)
X (prog (v)
X (or (igreaterp (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(de check-change& (z)
X (prog (r tab-flag)
X (setq tab-flag nil)
Xla (cond ((atom z) (return nil)))
X (setq r (car z))
X (setq z (cdr z))
X (cond
X ((eq r '!^)
X (and
X 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(de check-rhs-ce-var (v)
X (cond
X ((and (not (numberp v)) (not (ce-bound? v)))
X (!%warn "unbound element variable" v))
X ((and (numberp v) (or (lessp v 1) (greaterp v *ce-count*)))
X (!%warn "numeric element designator out of bounds" v))))
X
X(de check-rhs-value (x)
X (cond ((pairp x) (check-rhs-function x)) (t (check-rhs-atomic x))))
X
X(de check-rhs-atomic (x)
X (and
X (variablep x)
X (not (bound? x))
X (!%warn "unbound variable" x)))
X
X(de check-rhs-function (x)
X (prog (a)
X (setq a (car x))
X (cond
X ((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(de check-litval (x)
X (or (eq (length x) 2) (!%warn "wrong number of arguments" x))
X (check-rhs-atomic (cadr x)))
X
X(de check-accept (x)
X (cond
X ((eq (length x) 1) nil)
X ((eq (length x) 2) (check-rhs-atomic (cadr x)))
X (t (!%warn "too many arguments" x))))
X
X(de check-acceptline (x)
X (!!mapc (function check-rhs-atomic) (cdr x)))
X
X(de check-crlf (x) (check-0-args x))
X
X(de check-genatom (x) (check-0-args x))
X
X(de check-tabto (x)
X (or (eq (length x) 2) (!%warn "wrong number of arguments" x))
X (check-print-control (cadr x)))
X
X(de check-rjust (x)
X (or (eq (length x) 2) (!%warn "wrong number of arguments" x))
X (check-print-control (cadr x)))
X
X(de check-0-args (x)
X (or (eq (length x) 1) (!%warn "should not have arguments" x)))
X
X(de check-substr (x)
X (or (eq (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(de check-compute (x) (check-arithmetic (cdr x)))
X
X(de check-arithmetic (l)
X (cond
X ((atom l) (!%warn "syntax error in arithmetic expression" l))
X ((atom (cdr l)) (check-term (car l)))
X ((not (memq (cadr l) '(+ - * !/)))
X (!%warn "unknown operator" l))
X (t (check-term (car l)) (check-arithmetic (cddr l)))) )
X
X(de check-term (x)
X (cond ((pairp x) (check-arithmetic x)) (t (check-rhs-atomic x))))
X
X(de check-last-substr-index (x)
X (or (eq x 'inf) (check-substr-index x)))
X
X(de check-substr-index (x)
X (prog (v)
X (cond ((bound? x) (return x)))
X (setq v ($litbind x))
X (cond
X ((not (numberp v))
X (!%warn "unbound symbol used as index in substr" x))
X ((or (lessp v 1) (greaterp v 127))
X (!%warn "index out of bounds in tab" x)))) )
X
X(de check-print-control (x)
X (prog ()
X (cond ((bound? x) (return x)))
X (cond
X ((or (not (numberp x)) (lessp x 1) (greaterp x 127))
X (!%warn "illegal value for printer control" x)))) )
X
X(de check-tab-index (x)
X (prog (v)
X (cond ((bound? x) (return x)))
X (setq v ($litbind x))
X (cond
X ((not (numberp v))
X (!%warn "unbound symbol occurs after ^" x))
X ((or (lessp v 1) (greaterp v 127))
X (!%warn "index out of bounds after ^" x)))) )
X
X(de note-variable (var)
X (setq *rhs-bound-vars* (cons var *rhs-bound-vars*)))
X
X(de bound? (var) (or (memq var *rhs-bound-vars*) (var-dope var)))
X
X(de note-ce-variable (ce-var)
X (setq *rhs-bound-ce-vars* (cons ce-var *rhs-bound-ce-vars*)))
X
X(de ce-bound? (ce-var)
X (or (memq ce-var *rhs-bound-ce-vars*) (ce-var-dope ce-var)))
X
X%%% Top level routines
X
X(de process-changes (adds dels)
X (prog (x)
Xprocess-deletes
X (cond ((atom dels) (go process-adds)))
X (setq x (car dels))
X (setq dels (cdr dels))
X (remove-from-wm x)
X (go process-deletes)
Xprocess-adds
X (cond ((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(de main nil
X (prog (instance r)
X (setq *halt-flag* nil)
X (setq *break-flag* nil)
X (setq instance nil)
Xdil (setq *phase* 'conflict-resolution)
X (cond
X (*halt-flag* (setq r "end -- explicit halt") (go finis))
X ((izerop *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* (isub1 *remaining-cycles*))
X (setq instance (conflict-resolution))
X (cond
X ((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)
Xfinis (setq *p-name* nil)
X (return r)))
X
X(de do-continue (wmi)
X (cond
X (*critical*
X (terpri)
X (princ "warning: network may be inconsistent")))
X (process-changes wmi nil)
X (print-times (main)))
X
X(de accum-stats nil
X (setq *cycle-count* (iadd1 *cycle-count*))
X (setq *total-token* (iplus *total-token* *current-token*))
X (cond
X ((igreaterp *current-token* *max-token*)
X (setq *max-token* *current-token*)))
X (setq *total-wm* (iplus *total-wm* *current-wm*))
X (cond
X ((greaterp *current-wm* *max-wm*)
X (setq *max-wm* *current-wm*))))
X
X(de print-times (mess)
X (prog (cc ac)
X (cond (*break-flag* (terpri) (return mess)))
X (setq cc (plus (float *cycle-count*) 10.0e-20))
X (setq ac (plus (float *action-count*) 1.0e-20))
X (terpri)
X (princ mess)
X (pm-size)
X (printlinec
X (list
X *cycle-count*
X 'firings
X (list *action-count* 'rhs 'actions)))
X (terpri)
X (printlinec
X (list
X (round (quotient (float *total-wm*) cc))
X 'mean
X 'working
X 'memory
X 'size
X (list *max-wm* 'maximum)))
X (terpri)
X (printlinec
X (list
X (round (quotient (float *total-cs*) cc))
X 'mean
X 'conflict
X 'set
X 'size
X (list *max-cs* 'maximum)))
X (terpri)
X (printlinec
X (list
X (round (quotient (float *total-token*) cc))
X 'mean
X 'token
X 'memory
X 'size
X (list *max-token* 'maximum)))
X (terpri)))
X
X(de pm-size nil
X (terpri)
X (printlinec
X (list
X *pcount*
X 'productions
X (list *real-cnt* '!/ *virtual-cnt* 'nodes)))
X (terpri))
X
X(de check-limits nil
X (cond
X ((igreaterp (length *conflict-set*) *limit-cs*)
X (terpri)
X (terpri)
X (printlinec
X (list
X "conflict set size exceeded the limit of"
X *limit-cs*
X "after"
X *p-name*))
X (setq *halt-flag* t)))
X (cond
X ((igreaterp *current-token* *limit-token*)
X (terpri)
X (terpri)
X (printlinec
X (list
X "token memory size exceeded the limit of"
X *limit-token*
X "after"
X *p-name*))
X (setq *halt-flag* t))))
X
X(de top-level-remove (z)
X (cond
X ((equal z '(*)) (process-changes nil (get-wm nil)))
X (t (process-changes nil (get-wm z)))) )
X
X(df excise z (!!mapc (function excise-p) z))
X
X(df run z
X (cond
X ((atom z) (setq *remaining-cycles* 1000000) (do-continue nil))
X ((and (atom (cdr z)) (numberp (car z)) (greaterp (car z) 0))
X (setq *remaining-cycles* (car z))
X (do-continue nil))
X (t 'what?)))
X
X(df strategy z
X (cond
X ((atom z) *strategy*)
X ((equal z '(lex)) (setq *strategy* 'lex))
X ((equal z '(mea)) (setq *strategy* 'mea))
X (t 'what?)))
X
X(df cs z (cond ((atom z) (conflict-set)) (t 'what?)))
X
X(df watch z
X (cond
X ((equal z '(0)) (setq *wtrace* nil) (setq *ptrace* nil) 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(df external z (catch !!error!! (external2 z)))
X
X(de external2 (z) (!!mapc (function external3) z))
X
X(de external3 (x)
X (cond
X ((idp x) (putprop x t 'external-routine))
X (t (!%error "not a legal function name" x))))
X
X(de externalp (x)
X (cond
X ((idp x) (get x 'external-routine))
X (t (!%warn "not a legal function name" x) nil)))
X
X(df pbreak z
X (cond
X ((atom z) (terpri) *brkpts*)
X (t (!!mapc (function pbreak2) z) nil)))
X
X(de pbreak2 (rule)
X (cond
X ((not (idp rule)) (!%warn "illegal name" rule))
X ((not (get rule 'topnode)) (!%warn "not a production" rule))
X ((memq rule *brkpts*) (setq *brkpts* (rematm rule *brkpts*)))
X (t (setq *brkpts* (cons rule *brkpts*)))) )
X
X(de rematm (atm list)
X (cond
X ((atom list) list)
X ((eq atm (car list)) (rematm atm (cdr list)))
X (t (cons (car list) (rematm atm (cdr list)))) ))
X
X(de broken (rule) (memq rule *brkpts*))
X
X(i-g-v)
X
X(setsyntax '!{ 'read!-macro nil)
X(setsyntax "{}" 'letter t)
X(setsyntax "{}" 'break-character nil)
X(car!-nil!-legal t)
X
X
Xfin
X
SHAR_EOF
chmod 0600 ops5 || echo "restore of ops5 fails"
rm -f s2_seq_.tmp
echo "You have unpacked the last part"
exit 0