koreth@ssyx.ucsc.edu (Steven Grimm) (06/02/88)
Submitted-by: cfc@wjh12.harvard.edu (Christopher F. Chabris)
Posting-number: Volume 1, Issue 50
Archive-name: ops5/part02
#!/bin/sh
# this is part 2 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file ops5 continued
#
CurArch=2
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 (and
X (numberp z)
X (not (greaterp z constant))
X (eval-nodelist outs))))
X
X(put 'le 'tn 'tlen)
X
X(de teqs (outs vara varb)
X (prog (a b)
X (setq a (getv *cvec* vara))
X (setq b (getv *cvec* varb))
X (cond
X ((eq a b) (eval-nodelist outs))
X ((and (numberp a) (numberp b) (=alg a b))
X (eval-nodelist outs)))) )
X
X(put 'eq 'ts 'teqs)
X
X(de tnes (outs vara varb)
X (prog (a b)
X (setq a (getv *cvec* vara))
X (setq b (getv *cvec* varb))
X (cond
X ((eq a b) (return nil))
X ((and (numberp a) (numberp b) (=alg a b)) (return nil))
X (t (eval-nodelist outs)))) )
X
X(put 'ne 'ts 'tnes)
X
X(de txxs (outs vara varb)
X (prog (a b)
X (setq a (getv *cvec* vara))
X (setq b (getv *cvec* varb))
X (cond
X ((and (numberp a) (numberp b)) (eval-nodelist outs))
X ((and (not (numberp a)) (not (numberp b)))
X (eval-nodelist outs)))) )
X
X(put 'xx 'ts 'txxs)
X
X(de tlts (outs vara varb)
X (prog (a b)
X (setq a (getv *cvec* vara))
X (setq b (getv *cvec* varb))
X (and
X (numberp a)
X (numberp b)
X (greaterp b a)
X (eval-nodelist outs))))
X
X(put 'lt 'ts 'tlts)
X
X(de tgts (outs vara varb)
X (prog (a b)
X (setq a (getv *cvec* vara))
X (setq b (getv *cvec* varb))
X (and
X (numberp a)
X (numberp b)
X (greaterp a b)
X (eval-nodelist outs))))
X
X(put 'gt 'ts 'tgts)
X
X(de tges (outs vara varb)
X (prog (a b)
X (setq a (getv *cvec* vara))
X (setq b (getv *cvec* varb))
X (and
X (numberp a)
X (numberp b)
X (not (greaterp b a))
X (eval-nodelist outs))))
X
X(put 'ge 'ts 'tges)
X
X(de tles (outs vara varb)
X (prog (a b)
X (setq a (getv *cvec* vara))
X (setq b (getv *cvec* varb))
X (and
X (numberp a)
X (numberp b)
X (not (greaterp a b))
X (eval-nodelist outs))))
X
X(put 'le 'ts 'tles)
X
X(de &two (left-outs right-outs)
X (prog (fp dp)
X (cond
X (*sendtocall* (setq fp *flag-part*) (setq dp *data-part*))
X (t (setq fp *alpha-flag-part*) (setq dp *alpha-data-part*)))
X (sendto fp dp 'left left-outs)
X (sendto fp dp 'right right-outs)))
X
X(de &mem (left-outs right-outs memory-list)
X (prog (fp dp)
X (cond
X (*sendtocall* (setq fp *flag-part*) (setq dp *data-part*))
X (t (setq fp *alpha-flag-part*) (setq dp *alpha-data-part*)))
X (sendto fp dp 'left left-outs)
X (add-token memory-list fp dp nil)
X (sendto fp dp 'right right-outs)))
X
X(de &and (outs lpred rpred tests)
X (prog (mem)
X (cond
X ((eq *side* 'right)
X (cond
X ((not (setq mem (memory-part lpred))) (return nil))
X (t (and-right outs mem tests))))
X ((not (setq mem (memory-part rpred))) (return nil))
X (t (and-left outs mem tests)))))
X
X(de and-left (outs mem tests)
X (prog (fp dp memdp tlist tst lind rind res)
X (setq fp *flag-part*)
X (setq dp *data-part*)
Xfail (cond ((null mem) (return nil)))
X (setq memdp (car mem))
X (setq mem (cdr mem))
X (setq tlist tests)
Xtloop (cond ((null tlist) (go succ)))
X (setq tst (car tlist))
X (setq tlist (cdr tlist))
X (setq lind (car tlist))
X (setq tlist (cdr tlist))
X (setq rind (car tlist))
X (setq tlist (cdr tlist))
X %% the next line differs in and-left & -right
X (setq res (tst (gelm memdp rind) (gelm dp lind)))
X (cond (res (go tloop)) (t (go fail)))
Xsucc %% the next line differs in and-left & -right
X (sendto fp (cons (car memdp) dp) 'left outs)
X (go fail)))
X
X(de and-right (outs mem tests)
X (prog (fp dp memdp tlist tst lind rind res)
X (setq fp *flag-part*)
X (setq dp *data-part*)
Xfail (cond ((null mem) (return nil)))
X (setq memdp (car mem))
X (setq mem (cdr mem))
X (setq tlist tests)
Xtloop (cond ((null tlist) (go succ)))
X (setq tst (car tlist))
X (setq tlist (cdr tlist))
X (setq lind (car tlist))
X (setq tlist (cdr tlist))
X (setq rind (car tlist))
X (setq tlist (cdr tlist))
X %% the next line differs in and-left & -right
X (setq res (tst (gelm dp rind) (gelm memdp lind)))
X (cond (res (go tloop)) (t (go fail)))
Xsucc %% the next line differs in and-left & -right
X (sendto fp (cons (car dp) memdp) 'right outs)
X (go fail)))
X
X(de teqb (new eqvar)
X (cond
X ((eq new eqvar) t)
X ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((=alg new eqvar) t)
X (t nil)))
X
X(put 'eq 'tb 'teqb)
X
X(de tneb (new eqvar)
X (cond
X ((eq new eqvar) nil)
X ((not (numberp new)) t)
X ((not (numberp eqvar)) t)
X ((=alg new eqvar) nil)
X (t t)))
X
X(put 'ne 'tb 'tneb)
X
X(de tltb (new eqvar)
X (cond
X ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((greaterp eqvar new) t)
X (t nil)))
X
X(put 'lt 'tb 'tltb)
X
X(de tgtb (new eqvar)
X (cond
X ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((greaterp new eqvar) t)
X (t nil)))
X
X(put 'gt 'tb 'tgtb)
X
X(de tgeb (new eqvar)
X (cond
X ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((not (greaterp eqvar new)) t)
X (t nil)))
X
X(put 'ge 'tb 'tgeb)
X
X(de tleb (new eqvar)
X (cond
X ((not (numberp new)) nil)
X ((not (numberp eqvar)) nil)
X ((not (greaterp new eqvar)) t)
X (t nil)))
X
X(put 'le 'tb 'tleb)
X
X(de txxb (new eqvar)
X (cond
X ((numberp new) (cond ((numberp eqvar) t) (t nil)))
X (t (cond ((numberp eqvar) nil) (t t)))) )
X
X(put 'xx 'tb 'txxb)
X
X(de &p (rating name var-dope ce-var-dope rhs)
X (prog (fp dp)
X (cond
X (*sendtocall* (setq fp *flag-part*) (setq dp *data-part*))
X (t (setq fp *alpha-flag-part*) (setq dp *alpha-data-part*)))
X (and (memq fp '(nil old)) (removecs name dp))
X (and fp (insertcs name dp rating))))
X
X(de &old (a b c d e) nil)
X
X(de ¬ (outs lmem rpred tests)
X (cond
X ((eq *side* 'right)
X (cond ((eq *flag-part* 'old) nil)
X (t (not-right outs (car lmem) tests))))
X (t (not-left outs (memory-part rpred) tests lmem))))
X
X(de not-left (outs mem tests own-mem)
X (prog (fp dp memdp tlist tst lind rind res c)
X (setq fp *flag-part*)
X (setq dp *data-part*)
X (setq c 0)
Xfail (cond ((null mem) (go fin)))
X (setq memdp (car mem))
X (setq mem (cdr mem))
X (setq tlist tests)
Xtloop (cond ((null tlist) (setq c (iadd1 c)) (go fail)))
X (setq tst (car tlist))
X (setq tlist (cdr tlist))
X (setq lind (car tlist))
X (setq tlist (cdr tlist))
X (setq rind (car tlist))
X (setq tlist (cdr tlist))
X %% the next line differs in not-left & -right
X (setq res (tst (gelm memdp rind) (gelm dp lind)))
X (cond (res (go tloop)) (t (go fail)))
Xfin (add-token own-mem fp dp c)
X (cond ((izerop c) (sendto fp dp 'left outs)))))
X
X(de not-right (outs mem tests)
X (prog (fp dp memdp tlist tst lind rind res newfp inc newc)
X (setq fp *flag-part*)
X (setq dp *data-part*)
X (cond
X ((not fp) (setq inc (!!minus 1)) (setq newfp 'new))
X ((eq fp 'new) (setq inc 1) (setq newfp nil))
X (t (return nil)))
Xfail (cond ((null mem) (return nil)))
X (setq memdp (car mem))
X (setq newc (cadr mem))
X (setq tlist tests)
Xtloop (cond ((null tlist) (go succ)))
X (setq tst (car tlist))
X (setq tlist (cdr tlist))
X (setq lind (car tlist))
X (setq tlist (cdr tlist))
X (setq rind (car tlist))
X (setq tlist (cdr tlist))
X %% the next line differs in not-left & -right
X (setq res (tst (gelm dp rind) (gelm memdp lind)))
X (cond (res (go tloop)) (t (setq mem (cddr mem)) (go fail)))
Xsucc (setq newc (iplus inc newc))
X (rplaca (cdr mem) newc)
X (cond
X ((or
X (and (eq inc (!!minus 1)) (eq newc 0))
X (and (eq inc 1) (eq newc 1)))
X (sendto newfp memdp 'right outs)))
X (setq mem (cddr mem))
X (go fail)))
X
X%%% Node memories
X
X%(de add-token (memlis flag data-part num)
X% (prog (was-present)
X% (cond
X% ((eq flag 'new)
X% (setq was-present nil)
X% (real-add-token memlis data-part num))
X% ((not flag)
X% (setq was-present (remove-old memlis data-part num)))
X% ((eq flag 'old) (setq was-present t)))
X% (return was-present)))
X(de add-token (memlis flag data-part num)
X (cond
X ((eq flag 'new) (real-add-token memlis data-part num) nil)
X ((not flag) (remove-old memlis data-part num) nil)
X ((eq flag 'old) t)
X (t nil)))
X
X(de real-add-token (lis data-part num)
X (setq *current-token* (iadd1 *current-token*))
X (cond (num (rplaca lis (cons num (car lis)))) )
X (rplaca lis (cons data-part (car lis))))
X
X(de remove-old (lis data num)
X (cond
X (num (remove-old-num lis data))
X (t (remove-old-no-num lis data))))
X
X(de remove-old-num (lis data)
X (prog (m next last)
X (setq m (car lis))
X (cond
X ((atom m) (return nil))
X ((top-levels-eq data (car m))
X (setq *current-token* (isub1 *current-token*))
X (rplaca lis (cddr m))
X (return (car m))))
X (setq next m)
Xloop (setq last next)
X (setq next (cddr next))
X (cond
X ((atom next) (return nil))
X ((top-levels-eq data (car next))
X (rplacd (cdr last) (cddr next))
X (setq *current-token* (isub1 *current-token*))
X (return (car next)))
X (t (go loop)))) )
X
X(de remove-old-no-num (lis data)
X (prog (m next last)
X (setq m (car lis))
X (cond
X ((atom m) (return nil))
X ((top-levels-eq data (car m))
X (setq *current-token* (isub1 *current-token*))
X (rplaca lis (cdr m))
X (return (car m))))
X (setq next m)
Xloop (setq last next)
X (setq next (cdr next))
X (cond
X ((atom next) (return nil))
X ((top-levels-eq data (car next))
X (rplacd last (cdr next))
X (setq *current-token* (isub1 *current-token*))
X (return (car next)))
X (t (go loop)))) )
X
X%%% Conflict Resolution
X%
X%
X% each conflict set element is a list of the following form:
X% ((p-name . data-part) (sorted wm-recency) special-case-number)
X
X(de removecs (name data)
X (prog (cr-data inst cs)
X (setq cr-data (cons name data))
X (setq cs *conflict-set*)
Xl: (cond ((null cs) (record-refract name data) (return nil)))
X (setq inst (car cs))
X (setq cs (cdr cs))
X (cond ((not (top-levels-eq (car inst) cr-data)) (go l:)))
X (setq *conflict-set* (delq inst *conflict-set*))))
X
X(de insertcs (name data rating)
X (prog (instan)
X (cond ((refracted name data) (return nil)))
X (setq instan (list (cons name data) (order-tags data) rating))
X (and (atom *conflict-set*) (setq *conflict-set* nil))
X (return (setq *conflict-set* (cons instan *conflict-set*)))) )
X
X(de order-tags (dat)
X (prog (tags)
X (setq tags nil)
Xl1: (cond ((atom dat) (go l2:)))
X (setq tags (cons (creation-time (car dat)) tags))
X (setq dat (cdr dat))
X (go l1:)
Xl2: (cond
X ((eq *strategy* 'mea)
X (return (cons (car tags) (dsort (cdr tags)))) )
X (t (return (dsort tags)))) ))
X
X% destructively sort x into descending order
X(de dsort (x)
X (prog (sorted cur next cval nval)
X (cond ((atom (cdr x)) (return x)))
Xloop (setq sorted t)
X (setq cur x)
X (setq next (cdr x))
Xchek (setq cval (car cur))
X (setq nval (car next))
X (cond
X ((greaterp nval cval)
X (setq sorted nil)
X (rplaca cur nval)
X (rplaca next cval)))
X (setq cur next)
X (setq next (cdr cur))
X (cond
X ((not (null next)) (go chek))
X (sorted (return x))
X (t (go loop)))) )
X
X(de conflict-resolution nil
X (prog (best len)
X (setq len (length *conflict-set*))
X (cond ((igreaterp len *max-cs*) (setq *max-cs* len)))
X (setq *total-cs* (iplus *total-cs* len))
X (cond
X (*conflict-set*
X (setq best (best-of *conflict-set*))
X (setq *conflict-set* (delq best *conflict-set*))
X (return (pname-instantiation best)))
X (t (return nil)))) )
X
X(de best-of (set) (best-of* (car set) (cdr set)))
X
X(de best-of* (best rem)
X (cond
X ((not rem) best)
X ((conflict-set-compare best (car rem))
X (best-of* best (cdr rem)))
X (t (best-of* (car rem) (cdr rem)))) )
X
X(de remove-from-conflict-set (name)
X (prog (cs entry)
Xl1 (setq cs *conflict-set*)
Xl2 (cond ((atom cs) (return nil)))
X (setq entry (car cs))
X (setq cs (cdr cs))
X (cond
X ((eq name (caar entry))
X (setq *conflict-set* (delq entry *conflict-set*))
X (go l1))
X (t (go l2)))) )
X
X(de pname-instantiation (conflict-elem) (car conflict-elem))
X
X(de order-part (conflict-elem) (cdr conflict-elem))
X
X(de instantiation (conflict-elem)
X (cdr (pname-instantiation conflict-elem)))
X
X(de conflict-set-compare (x y)
X (prog (x-order y-order xl yl xv yv)
X (setq x-order (order-part x))
X (setq y-order (order-part y))
X (setq xl (car x-order))
X (setq yl (car y-order))
Xdata (cond
X ((and (null xl) (null yl)) (go ps))
X ((null yl) (return t))
X ((null xl) (return nil)))
X (setq xv (car xl))
X (setq yv (car yl))
X (cond
X ((greaterp xv yv) (return t))
X ((greaterp yv xv) (return nil)))
X (setq xl (cdr xl))
X (setq yl (cdr yl))
X (go data)
Xps (setq xl (cdr x-order))
X (setq yl (cdr y-order))
Xpsl (cond ((null xl) (return t)))
X (setq xv (car xl))
X (setq yv (car yl))
X (cond
X ((greaterp xv yv) (return t))
X ((greaterp yv xv) (return nil)))
X (setq xl (cdr xl))
X (setq yl (cdr yl))
X (go psl)))
X
X(de conflict-set nil
X (prog (cnts cs p z best)
X (setq cnts nil)
X (setq cs *conflict-set*)
Xl1: (cond ((atom cs) (go l2:)))
X (setq p (caaar cs))
X (setq cs (cdr cs))
X (setq z (atsoc p cnts))
X (cond
X ((null z) (setq cnts (cons (cons p 1) cnts)))
X (t (rplacd z (iadd1 (cdr z)))) )
X (go l1:)
Xl2: (cond
X ((atom cnts)
X (setq best (best-of *conflict-set*))
X (terpri)
X (return (list (caar best) 'dominates))))
X (terpri)
X (princ (caar cnts))
X (cond
X ((greaterp (cdar cnts) 1)
X (princ " (")
X (princ (cdar cnts))
X (princ " occurrences)")))
X (setq cnts (cdr cnts))
X (go l2:)))
X
X%%% WM maintaining functions
X%
X% The order of operations in the following two functions is critical.
X% add-to-wm order: (1) change wm (2) record change (3) match
X% remove-from-wm order: (1) record change (2) match (3) change wm
X% (back will not restore state properly unless wm changes are recorded
X% before the cs changes that they cause) (match will give errors if
X% the thing matched is not in wm at the time)
X
X(de add-to-wm (wme override)
X (prog (fa z part timetag port)
X (setq *critical* t)
X (setq *current-wm* (iadd1 *current-wm*))
X (and
X (greaterp *current-wm* *max-wm*)
X (setq *max-wm* *current-wm*))
X (setq *action-count* (iadd1 *action-count*))
X (setq fa (wm-hash wme))
X (or
X (memq fa *wmpart-list*)
X (setq *wmpart-list* (cons fa *wmpart-list*)))
X (setq part (get fa 'wmpart*))
X (cond
X (override (setq timetag override))
X (t (setq timetag *action-count*)))
X (setq z (cons wme timetag))
X (putprop fa (cons z part) 'wmpart*)
X (record-change '=>wm *action-count* wme)
X (match 'new wme)
X (setq *critical* nil)
X (cond
X ((and *in-rhs* *wtrace*)
X (setq port (trace-file))
X (terpri port)
X (!!princ "=>wm: " port)
X (ppelm wme port)))) )
X
X% remove-from-wm uses eq, not equal to determine if wme is present
X(de remove-from-wm (wme)
X (prog (fa z part timetag port)
X (setq fa (wm-hash wme))
X (setq part (get fa 'wmpart*))
X (setq z (atsoc wme part))
X (cond ((null z) (return nil)))
X (setq timetag (cdr z))
X (cond
X ((and *wtrace* *in-rhs*)
X (setq port (trace-file))
X (terpri port)
X (!!princ "<=wm: " port)
X (ppelm wme port)))
X (setq *action-count* (iadd1 *action-count*))
X (setq *critical* t)
X (setq *current-wm* (sub1 *current-wm*))
X (record-change '<=wm timetag wme)
X (match nil wme)
X (putprop fa (delq z part) 'wmpart*)
X (setq *critical* nil)))
X
X% mapwm maps down the elements of wm, applying fn to each element
X% each element is of form (datum . creation-time)
X(de mapwm (fn)
X (prog (wmpl part)
X (setq wmpl *wmpart-list*)
Xlab1 (cond ((atom wmpl) (return nil)))
X (setq part (get (car wmpl) 'wmpart*))
X (setq wmpl (cdr wmpl))
X (!!mapc fn part)
X (go lab1)))
X
X(df wm a
X (!!mapc (function (lambda (z) (terpri) (ppelm z nil))) (get-wm a))
X nil)
X
X(de get-wm (z)
X (setq *wm-filter* z)
X (setq *wm* nil)
X (mapwm (function get-wm2))
X (prog1 *wm* (setq *wm* nil)))
X
X(de get-wm2 (elem)
X (cond
X ((or (null *wm-filter*) (member (cdr elem) *wm-filter*))
X (setq *wm* (cons (car elem) *wm*)))) )
X
X(de wm-hash (x)
X (cond
X ((not x) '<default>)
X ((not (car x)) (wm-hash (cdr x)))
X ((idp (car x)) (car x))
X (t (wm-hash (cdr x)))) )
X
X(de creation-time (wme)
X (cdr (atsoc wme (get (wm-hash wme) 'wmpart*))))
X
X(de refresh nil
X (prog nil
X (setq *old-wm* nil)
X (mapwm (function refresh-collect))
X (!!mapc (function refresh-del) *old-wm*)
X (!!mapc (function refresh-add) *old-wm*)
X (setq *old-wm* nil)))
X
X(de refresh-collect (x) (setq *old-wm* (cons x *old-wm*)))
X
X(de refresh-del (x) (remove-from-wm (car x)))
X
X(de refresh-add (x) (add-to-wm (car x) (cdr x)))
X
X(de trace-file ()
X (prog (port)
X (setq port nil)
X (cond
X (*trace-file*
X (setq port ($ofile *trace-file*))
X (cond
X ((null port)
X (!%warn "trace: file has been closed" *trace-file*)
X (setq port nil)))) )
X (return port)))
X
X%%% Basic functions for RHS evaluation
X
X(de eval-rhs (pname data)
X (prog (node port)
X (cond
X (*ptrace*
X (setq port (trace-file))
X (terpri port)
X (!!princ *cycle-count* port)
X (!!princ ". " port)
X (!!princ pname port)
X (time-tag-print data port)))
X (setq *data-matched* data)
X (setq *p-name* pname)
X (setq *last* nil)
X (setq node (get pname 'topnode))
X (init-var-mem (var-part node))
X (init-ce-var-mem (ce-var-part node))
X (begin-record pname data)
X (setq *in-rhs* t)
X (eval (rhs-part node))
X (setq *in-rhs* nil)
X (end-record)))
X
X(de time-tag-print (data port)
X (cond
X ((not (null data))
X (time-tag-print (cdr data) port)
X (!!princ " " port)
X (!!princ (creation-time (car data)) port))))
X
X(de init-var-mem (vlist)
X (prog (v ind r)
X (setq *variable-memory* nil)
Xtop (cond ((atom vlist) (return nil)))
X (setq v (car vlist))
X (setq ind (cadr vlist))
X (setq vlist (cddr vlist))
X (setq r (gelm *data-matched* ind))
X (setq *variable-memory* (cons (cons v r) *variable-memory*))
X (go top)))
X
X(de init-ce-var-mem (vlist)
X (prog (v ind r)
X (setq *ce-variable-memory* nil)
Xtop (cond ((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(de make-ce-var-bind (var elem)
X (setq *ce-variable-memory*
X (cons (cons var elem) *ce-variable-memory*)))
X
X(de make-var-bind (var elem)
X (setq *variable-memory* (cons (cons var elem) *variable-memory*)))
X
X(de $varbind (x)
X (prog (r)
X (cond ((not *in-rhs*) (return x)))
X (setq r (atsoc x *variable-memory*))
X (cond (r (return (cdr r))) (t (return x)))) )
X
X(de get-ce-var-bind (x)
X (prog (r)
X (cond ((numberp x) (return (get-num-ce x))))
X (setq r (atsoc x *ce-variable-memory*))
X (cond (r (return (cdr r))) (t (return nil)))) )
X
X(de get-num-ce (x)
X (prog (r l d)
X (setq r *data-matched*)
X (setq l (length r))
X (setq d (difference l x))
X (cond ((greaterp 0 d) (return nil)))
Xla (cond
X ((null r) (return nil))
X ((greaterp 1 d) (return (car r))))
X (setq d (sub1 d))
X (setq r (cdr r))
X (go la)))
X
X(de build-collect (z)
X (prog (r)
Xla (cond ((atom z) (return nil)))
X (setq r (car z))
X (setq z (cdr z))
X (cond
X ((pairp r) ($value '!() (build-collect r) ($value '!) ))
X ((eq r '!!) ($change (car z)) (setq z (cdr z)))
X (t ($value r)))
X (go la)))
X
X(de unflat (x) (setq *rest* x) (unflat*))
X
X(de unflat* nil
X (prog (c)
X (cond ((atom *rest*) (return nil)))
X (setq c (car *rest*))
X (setq *rest* (cdr *rest*))
X (cond
X ((eq c '!() (return (cons (unflat*) (unflat*))))
X ((eq c '!)) (return nil))
X (t (return (cons c (unflat*)))) )))
X
X(de $change (x)
X (prog nil
X (cond
X ((pairp x) (eval-function x))
X (t ($value ($varbind x)))) ))
X
X(de eval-args (z)
X (prog (r)
X (rhs-tab 1)
Xla (cond ((atom z) (return nil)))
X (setq r (car z))
X (setq z (cdr z))
X (cond
X ((eq r '!^)
X (rhs-tab (car z))
X (setq r (cadr z))
X (setq z (cddr z))))
X (cond
X ((eq r '!/) ($value (car z)) (setq z (cdr z)))
X (t ($change r)))
X (go la)))
X
X(de eval-function (form)
X (cond
X ((not *in-rhs*)
X (!%warn "functions cannot be used at top level" (car form)))
X (t (eval form))))
X
X
X%%% Functions to manipulate the result array
X
X(de $reset nil (setq *max-index* 0) (setq *next-index* 1))
X
X% rhs-tab implements the tab ('^') function in the rhs. it has
X% four responsibilities:
X% - to move the array pointers
X% - to watch for tabbing off the left end of the array
X% (ie, to watch for pointers less than 1)
X% - to watch for tabbing off the right end of the array
X% - to write nil in all the slots that are skipped
X% the last is necessary if the result array is not to be cleared
X% after each use% if rhs-tab did not do this, $reset
X% would be much slower.
X
X(de rhs-tab (z) ($tab ($varbind z)))
X
X(de $tab (z)
X (prog (edge next)
X (setq next ($litbind z))
X (and (floatp next) (setq next (fix next)))
X (cond
X ((or
X (not (numberp next))
X (greaterp next *size-result-array*)
X (greaterp 1 next))
X (!%warn "illegal index after ^" next)
X (return *next-index*)))
X (setq edge (isub1 next))
X (cond ((greaterp *max-index* edge) (go ok)))
Xclear (cond ((eq *max-index* edge) (go ok)))
X (putv *result-array* edge nil)
X (setq edge (isub1 edge))
X (go clear)
Xok (setq *next-index* next)
X (return next)))
X
X(de $value (v)
X (cond
X ((greaterp *next-index* *size-result-array*)
X (!%warn "index too large" *next-index*))
X (t (and
X (greaterp *next-index* *max-index*)
X (setq *max-index* *next-index*))
X (putv *result-array* *next-index* v)
X (setq *next-index* (iadd1 *next-index*)))) )
X
X(de use-result-array nil
X (prog (k r)
X (setq k *max-index*)
X (setq r nil)
Xtop (cond ((eq k 0) (return r)))
X (setq r (cons (getv *result-array* k) r))
X (setq k (isub1 k))
X (go top)))
X
X(de $assert nil
X (setq *last* (use-result-array))
X (add-to-wm *last* nil))
X
X(de $parametercount nil *max-index*)
X
X(de $parameter (k)
X (cond
X ((or
X (not (numberp k))
X (igreaterp k *size-result-array*)
X (ilessp k 1))
X (!%warn "illegal parameter number " k)
X nil)
X ((igreaterp k *max-index*) nil)
X (t (getv *result-array* k))))
X
X%%% RHS actions
X
X(df make z
X (prog nil
X ($reset)
X (eval-args z)
X ($assert)))
X
X(df modify z
X (prog (old)
X (cond
X ((not *in-rhs*)
X (!%warn "cannot be called at top level" 'modify)
X (return nil)))
X (setq old (get-ce-var-bind (car z)))
X (cond
X ((null old)
X (!%warn
X "modify: first argument must be an element variable"
X (car z))
X (return nil)))
X (remove-from-wm old)
X (setq z (cdr z))
X ($reset)
Xcopy (cond ((atom old) (go fin)))
X ($change (car old))
X (setq old (cdr old))
X (go copy)
Xfin (eval-args z)
X ($assert)))
X
X(df bind z
X (prog (val)
X (cond
X ((not *in-rhs*)
X (!%warn "cannot be called at top level" 'bind)
X (return nil)))
X (cond
X ((ilessp (length z) 1)
X (!%warn "bind: wrong number of arguments to" z)
X (return nil))
X ((not (idp (car z)))
X (!%warn "bind: illegal argument" (car z))
X (return nil))
X ((eq (length z) 1) (setq val (gensym)))
X (t ($reset) (eval-args (cdr z)) (setq val ($parameter 1))))
X (make-var-bind (car z) val)))
X
X(df cbind z
X (cond
X ((not *in-rhs*)
X (!%warn "cannot be called at top level" 'cbind))
X ((not (eq (length z) 1))
X (!%warn "cbind: wrong number of arguments" z))
X ((not (idp (car z)))
X (!%warn "cbind: illegal argument" (car z)))
X ((null *last*) (!%warn "cbind: nothing added yet" (car z)))
X (t (make-ce-var-bind (car z) *last*))))
X
X(df remove z
X (prog (old)
X (cond ((not *in-rhs*) (return (top-level-remove z))))
Xtop (cond ((atom z) (return nil)))
X (setq old (get-ce-var-bind (car z)))
X (cond
X ((null old)
X (!%warn
X "remove: argument not an element variable"
X (car z))
X (return nil)))
X (remove-from-wm old)
X (setq z (cdr z))
X (go top)))
X
X(df call z
X (prog (f)
X (setq f (car z))
X ($reset)
X (eval-args (cdr z))
X (f)))
X
X(df write z
X (prog (port max k x needspace)
X (cond
X ((not *in-rhs*)
X (!%warn "cannot be called at top level" 'write)
X (return nil)))
X ($reset)
X (eval-args z)
X (setq k 1)
X (setq max ($parametercount))
X (cond
X ((ilessp max 1)
X (!%warn "write: nothing to print" z)
X (return nil)))
X (setq port (default-write-file))
X (setq x ($parameter 1))
X (cond
X ((and (idp x) ($ofile x))
X (setq port ($ofile x))
X (setq k 2)))
X (setq needspace t)
Xla (cond ((greaterp k max) (return nil)))
X (setq x ($parameter k))
X (cond
X ((eq x "=== C R L F ===")
X (setq needspace nil)
X (terpri port))
X ((eq x "=== R J U S T ===")
X (setq k (iplus 2 k))
X (do-rjust ($parameter (isub1 k)) ($parameter k) port))
X ((eq x "=== T A B T O ===")
X (setq needspace nil)
X (setq k (iadd1 k))
X (do-tabto ($parameter k) port))
X (t (and needspace (!!princ " " port))
X (setq needspace t)
X (!!princ x port)))
X (setq k (iadd1 k))
X (go la)))
X
X(de default-write-file ()
X (prog (port)
X (setq port nil)
X (cond
X (*write-file*
X (setq port ($ofile *write-file*))
X (cond
X ((null port)
X (!%warn "write: file has been closed" *write-file*)
X (setq port nil)))) )
X (return port)))
X
X(de do-rjust (width value port k)
X (prog (size)
X (cond
X ((eq value "=== T A B T O ===")
X (!%warn "rjust cannot precede this function" 'tabto)
X (return nil))
X ((eq value "=== C R L F ===")
X (!%warn "rjust cannot precede this function" 'crlf)
X (return nil))
X ((eq value "=== R J U S T ===")
X (!%warn "rjust cannot precede this function" 'rjust)
X (return nil)))
X (setq size (flatc value (iadd1 width)))
X (cond
X ((greaterp size width)
X (!!princ " " port)
X (!!princ value port)
X (return nil)))
X (setq k (difference width size))
X (while (greaterp k 0)
X (progn (setq k (isub1 k))
X (!!princ " " port)))
X (!!princ value port)))
X
X(de do-tabto (col port)
X (prog (pos k)
X (setq pos (iadd1 (posn port)))
X (cond ((greaterp pos col) (terpri port) (setq pos 1)))
X (setq k (difference col pos))
X (while (greaterp k 0)
X (progn (setq k (isub1 k))
X (!!princ " " port)))
X (return nil)))
X
X(de halt nil
X (cond
X ((not *in-rhs*) (!%warn "cannot be called at top level" 'halt))
X (t (setq *halt-flag* t))))
X
X(de build z
X (prog (r)
X (cond
X ((not *in-rhs*)
X (!%warn "cannot be called at top level" 'build)
X (return nil)))
X ($reset)
X (build-collect z)
X (setq r (unflat (use-result-array)))
X (and *build-trace* (*build-trace* r))
X (compile-production (car r) (cdr r))))
X
X(df openfile z
X (prog (file mode id)
X ($reset)
X (eval-args z)
X (cond
X ((not (eq ($parametercount) 3))
X (!%warn "openfile: wrong number of arguments" z)
X (return nil)))
X (setq id ($parameter 1))
X (setq file ($parameter 2))
X (setq mode ($parameter 3))
X (cond
X ((not (idp id))
X (!%warn "openfile: file id must be a symbolic atom" id)
X (return nil))
X ((null id)
X (!%warn
X "openfile: 'nil' is reserved for the terminal"
X nil)
X (return nil))
X ((or ($ifile id) ($ofile id))
X (!%warn "openfile: name already in use" id)
X (return nil)))
X (cond
X ((eq mode 'in) (putprop id (open file 'input) 'inputfile))
X ((eq mode 'out) (putprop id (open file 'output) 'outputfile))
X (t (!%warn "openfile: illegal mode" mode) (return nil)))
X (return nil)))
X
X(de $ifile (x) (get x 'inputfile))
X
X(de $ofile (x) (get x 'outputfile))
X
X(df closefile z
X ($reset)
X (eval-args z)
X (!!mapc (function closefile2) (use-result-array)))
X
X(de closefile2 (file)
X (prog (port)
X (cond
X ((not (idp file))
X (!%warn "closefile: illegal file identifier" file))
X ((setq port ($ifile file))
X (close port)
X (remprop file 'inputfile))
X ((setq port ($ofile file))
X (close port)
X (remprop file 'outputfile)))
X (return nil)))
X
X(df default z
X (prog (file use)
X ($reset)
X (eval-args z)
X (cond
X ((not (eq ($parametercount) 2))
X (!%warn "default: wrong number of arguments" z)
X (return nil)))
X (setq file ($parameter 1))
X (setq use ($parameter 2))
X (cond
X ((not (idp file))
X (!%warn "default: illegal file identifier" file)
X (return nil))
X ((not (memq use '(write accept trace)))
X (!%warn "default: illegal use for a file" use)
X (return nil))
X ((and
X (memq use '(write trace))
X (not (null file))
X (not ($ofile file)))
X (!%warn
X "default: file has not been opened for output"
X file)
X (return nil))
X ((and
X (eq use 'accept)
X (not (null file))
X (not ($ifile file)))
X (!%warn
X "default: file has not been opened for input"
SHAR_EOF
echo "End of part 2, continue with part 3"
echo "3" > s2_seq_.tmp
exit 0