koreth@ssyx.ucsc.edu (Steven Grimm) (06/02/88)
Submitted-by: cfc@wjh12.harvard.edu (Christopher F. Chabris)
Posting-number: Volume 1, Issue 49
Archive-name: ops5/part01
[I don't have Cambridge Lisp, so I can't test this. -sg]
In the past, several people have asked me about a version of the OPS5
production system interpreter for Cambridge Lisp on the ST. This version
was given to me by John Fitch, who implemented the ST version of Cambridge
Lisp, about two years ago. I submit it with no claims as to workability,
usefulness, bug-freeness, etc -- it is just here for those who want to hack
with OPS5 and a large program on Cambridge Lisp and the ST. It might also
work for other implementations of Cambridge Lisp on other machines, such as
the Amiga. And of course, I am not responsible in any way for supporting
it. I hope some people enjoy it.
#!/bin/sh
# shar: Shell Archiver (v1.22)
#
# This is part 1 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
#
# Run the following text with /bin/sh to create:
# ops5
#
if test -r s2_seq_.tmp
then echo "Must unpack archives in sequence!"
next=`cat s2_seq_.tmp`; echo "Please unpack part $next next"
exit 1; fi
sed 's/^X//' << 'SHAR_EOF' > ops5 &&
X%========================================================================
X% OPS5 heavily modified by John Fitch to improve efficiency and
X% functionality. This is a Cambridge LISP version.
X
X%%% Compatability for Cambridge LISP
X
X(setsyntax ":=+-*$&?<>" 'break!-character nil)
X(setsyntax ":=+-*$&?<>" 'letter t)
X
X(setq !!excise excise)
X(car!-nil!-legal t)
X
X(dm flatc (n) (list 'length (list 'explode n)))
X
X(dm putprop (x y z) (list 'put x z y)) % Argument order
X(dm !!mapc (x y) (list 'mapc y x)) % Argument order
X(dm !!minus (x) (minus x)) % Possible syntax problem
X(dm prog1 l
X (prog (var)
X (setq var (gensym))
X (return
X `(prog (,var)
X (setq ,var ,(car l))
X ,@(append (cdr l) '((return ,xxx)))))))
X
X(setq !*comp t)
X
X% In general the IO model of Cambridge LISP differs from Franz
X% These functions patch it up a little
X
X(de !!read (prt)
X (prog (x ans)
X (setq x (rds prt))
X (setq ans (read))
X (rds x)
X (return ans)))
X
X(de !!tyipeek (prt)
X (prog (x ans)
X (setq x (rds prt 'input))
X (setq ans (tyipeek))
X (rds x)
X (return ans)))
X
X(de !!princ (x prt)
X (prog (old)
X (setq old (rds prt))
X (princ x)
X (rds old)
X (return x)))
X
X% Useful function not defined in Cambridge LISP
X
X(de delq (a b)
X (cond
X ((null b) nil)
X ((eq a (car b)) (cdr b))
X (t (cons (car b) (delq a (cdr b)))) ))
X
X(fluid
X '(*matrix* *buckets* *accept-file* *write-file* *trace-file*
X *class-list* *brkpts* *strategy* *in-rhs* *ptrace* *wtrace*
X *recording* *refracts* *real-cnt* *virtual-cnt* *max-cs*
X *total-cs* *limit-token* *limit-cs* *critical* *build-trace*
X *wmpart-list* *size-result-array* *result-array*
X *record-array* *result-array* *size-result-array*
X *pcount* *cycle-count* *action-count* *total-token* *max-token*
X *current-token* *total-cs* *max-cs* *total-wm* *max-wm*
X *current-wm* *conflict-set* *wmpart-list* *p-name*
X *remaining-cycles* *first-node* *feature-count* *cur-vars*
X *ce-count* *vars* *ce-vars* *rhs-bound-vars*
X *rhs-bound-ce-vars* *last-branch* *last-node* *subnum*
X *record* *max-record-index* *record-index* *curcond* *sendtocall* *side*
X *flag-part* *data-part* *alpha-flag-part* *alpha-data-part* *wm-filter*
X *wm* *old-wm* *action-type* *data-matched* *last* *variable-memory*
X *filters* *ppline* *halt-flag* *ce-variable-memory* *rest* *max-index*
X *next-index* *break-flag* *phase* *cvec* *cved-least*
X))
X
X
X% =ALG returns T if A and B are algebraicly equal.
X(de =alg (a b) (zerop (difference a b)))
X
X(de ce-gelm (x k)
X (prog nil
Xloop (cond ((eq k 1) (return (car x))))
X (setq k (isub1 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. (JPff comment: Yeak)
X(de gelm (x k)
X (prog (ce sub)
X (setq ce (iquotient k 10000))
X (setq sub (idifference k (itimes ce 10000)))
Xceloop(cond ((eq ce 0) (go ph2)))
X (setq x (cdr x))
X (cond ((eq ce 1) (go ph2)))
X (setq x (cdr x))
X (cond ((eq ce 2) (go ph2)))
X (setq x (cdr x))
X (cond ((eq ce 3) (go ph2)))
X (setq x (cdr x))
X (cond ((eq ce 4) (go ph2)))
X (setq ce (idifference ce 4))
X (go celoop)
Xph2 (setq x (car x))
Xsubloop
X (cond ((eq sub 0) (go finis)))
X (setq x (cdr x))
X (cond ((eq sub 1) (go finis)))
X (setq x (cdr x))
X (cond ((eq sub 2) (go finis)))
X (setq x (cdr x))
X (cond ((eq sub 3) (go finis)))
X (setq x (cdr x))
X (cond ((eq sub 4) (go finis)))
X (setq x (cdr x))
X (cond ((eq sub 5) (go finis)))
X (setq x (cdr x))
X (cond ((eq sub 6) (go finis)))
X (setq x (cdr x))
X (cond ((eq sub 7) (go finis)))
X (setq x (cdr x))
X (cond ((eq sub 8) (go finis)))
X (setq sub (idifference sub 8))
X (go subloop)
Xfinis (return (car x))))
X
X
X%%% Utility functions
X
X(de printline (x)
X (foreach y in x do
X (progn
X (princ " ")
X (print y))))
X
X(de printlinec (x)
X (foreach y in x do
X (progn
X (princ " ")
X (princ y))))
X
X% intersect two lists using eq for the equality test
X(de interq (x y)
X (cond
X ((atom x) nil)
X ((memq (car x) y) (cons (car x) (interq (cdr x) y)))
X (t (interq (cdr x) y))))
X
X(de i-g-v nil
X (prog (x)
X %(sstatus translink t)
X %(setsyntax '{ 66)
X %(setsyntax '} 66)
X %(setsyntax '^ 66)
X (setq *buckets* 64)
X % 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 *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 *size-result-array* 127)
X (setq *result-array* (mkvect *size-result-array*))
X (setq *record-array* (mkvect *size-result-array*))
X %%% Used to be 6 "!!!
X (setq x 0)
Xloop (putv *result-array* x nil)
X (setq x (iadd1 x))
X (cond ((not (igreaterp 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 (setq *cvec* (mkvect 64))
X (setq *cvec-least* 0)))
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(de !%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(de !%error (what where)
X (!%warn what where)
X (throw !!error!! '!!error!!))
X
X(de round (x) (fix (plus 0.5 x)))
X
X(de top-levels-eq (la lb)
X (prog nil
Xlx (cond
X ((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(df literal z
X (prog (atm val old)
Xtop (cond
X ((atom z) (return 'bound))
X ((not (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
X ((not (numberp val))
X (!%warn "can bind only to numbers" val))
X ((or (not (idp atm)) (variablep atm))
X (!%warn "can bind only constant atoms" atm))
X ((and
X (setq old (literal-binding-of atm))
X (not (equal old val)))
X (!%warn "attempt to rebind attribute" atm))
X (t (put atm 'ops-bind val)))
X (go top)))
X
X(dm have-compiled-production nil '(not (izerop *pcount*)))
X
X(df literalize l
X (prog (class-name atts)
X (setq class-name (car l))
X (cond
X ((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 (put class-name 'att-list atts)))
X
X(df vector-attribute l
X (cond
X ((have-compiled-production)
X (!%warn "vector-attribute called after p" l))
X (t (test-attribute-names l)
X (flag l 'vector-attribute))))
X
X(dm is-vector-attribute (att) `(flagp ,att 'vector-attribute))
X
X(de test-attribute-names (l)
X (!!mapc (function test-attribute-names2) l))
X
X(de test-attribute-names2 (atm)
X (cond
X ((or (not (idp atm)) (variablep atm))
X (!%warn "can bind only constant atoms" atm))))
X
X(de finish-literalize nil
X (cond
X ((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(de put-ppdat (class)
X (prog (al att ppdat)
X (setq ppdat nil)
X (setq al (get class 'att-list))
Xtop (cond
X ((not (atom al))
X (setq att (car al))
X (setq al (cdr al))
X (setq ppdat
X (cons (cons (literal-binding-of att) att) ppdat))
X (go top)))
X (putprop class ppdat 'ppdat)))
X
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(de note-user-assigns (class)
X (!!mapc (function note-user-assigns2) (get class 'att-list)))
X
X(de note-user-assigns2 (att)
X (prog (num conf buck clash)
X (setq num (literal-binding-of att))
X (cond ((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
X clash
X (!%warn
X "attributes in a class assigned the same number"
X (cons att clash)))
X (return nil)))
X
X(de note-user-vector-assigns (att given needed)
X (and
X (greaterp needed given)
X (!%warn
X "vector attribute assigned too small a value in literal"
X att)))
X
X(de assign-scalars (class)
X (!!mapc (function assign-scalars2) (get class 'att-list)))
X
X(de assign-scalars2 (att)
X (prog (tlist num bucket conf)
X (cond
X ((literal-binding-of att) (return nil))
X ((is-vector-attribute att) (return nil)))
X (setq tlist (buckets))
X (setq conf (get att 'conflicts))
Xtop (cond
X ((atom tlist)
X (!%warn "could not generate a binding" att)
X (store-binding att (!!minus 1))
X (return nil)))
X (setq num (caar tlist))
X (setq bucket (cdar tlist))
X (setq tlist (cdr tlist))
X (cond
X ((disjoint bucket conf) (store-binding att num))
X (t (go top)))) )
X
X(de assign-vectors (class)
X (!!mapc (function assign-vectors2) (get class 'att-list)))
X
X(de assign-vectors2 (att)
X (prog (big conf new old need)
X (cond ((not (is-vector-attribute att)) (return nil)))
X (setq big 1)
X (setq conf (get att 'conflicts))
Xtop (cond
X ((not (atom conf))
X (setq new (car conf))
X (setq conf (cdr conf))
X (cond
X ((is-vector-attribute new)
X (!%warn
X "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 (iadd1 big))
X (setq old (literal-binding-of att))
X (cond
X (old (note-user-vector-assigns att old need))
X (t (store-binding att need)))
X (return nil)))
X
X(de disjoint (la lb) (not (find-common-atom la lb)))
X
X(de find-common-atom (la lb)
X (prog nil
Xtop (cond
X ((null la) (return nil))
X ((memq (car la) lb) (return (car la)))
X (t (setq la (cdr la)) (go top)))) )
X
X(de mark-conflicts (rem all)
X (cond
X ((not (null rem))
X (mark-conflicts2 (car rem) all)
X (mark-conflicts (cdr rem) all))))
X
X(de mark-conflicts2 (atm lst)
X (prog (l)
X (setq l lst)
Xtop (cond ((atom l) (return nil)))
X (conflict atm (car l))
X (setq l (cdr l))
X (go top)))
X
X(de conflict (a b)
X (prog (old)
X (setq old (get a 'conflicts))
X (and
X (not (eq a b))
X (not (memq b old))
X (putprop a (cons b old) 'conflicts))))
X
X(de remove-duplicates (lst)
X (cond
X ((atom lst) nil)
X ((memq (car lst) (cdr lst)) (remove-duplicates (cdr lst)))
X (t (cons (car lst) (remove-duplicates (cdr lst)))) ))
X
X(de literal-binding-of (name) (get name 'ops-bind))
X
X(de store-binding (name lit)
X (putprop name lit 'ops-bind)
X (add-bucket name lit))
X
X(de add-bucket (name num)
X (prog (buc)
X (setq buc (assoc num (buckets)))
X (and (not (memq name buc)) (rplacd buc (cons name (cdr buc))))
X (return buc)))
X
X(de buckets nil
X (and (atom *buckets*) (setq *buckets* (make-nums *buckets*)))
X *buckets*)
X
X(de make-nums (k)
X (prog (nums)
X (setq nums nil)
Xl (cond ((ilessp k 2) (return nums)))
X (setq nums (cons (ncons k) nums))
X (setq k (isub1 k))
X (go l)))
X
X(de erase-literal-info (class)
X (!!mapc (function erase-literal-info2) (get class 'att-list))
X (remprop class 'att-list))
X
X(de erase-literal-info2 (att) (remprop att 'conflicts))
X
X%%% LHS Compiler
X
X(df p z
X (finish-literalize)
X (princ '*)
X (compile-production (car z) (cdr z))
X (car z))
X
X(de compile-production (name matrix)
X (prog (erm)
X (setq *p-name* name)
X (setq erm (catch !!error!! (cmp-p name matrix)))
X (setq *p-name* nil)))
X
X(de peek-lex nil (car *matrix*))
X
X(de lex nil
X (prog1 (car *matrix*) (setq *matrix* (cdr *matrix*))))
X
X(de end-of-p nil (atom *matrix*))
X
X(de rest-of-p nil *matrix*)
X
X(de prepare-lex (prod) (setq *matrix* prod))
X
X(de peek-sublex nil (car *curcond*))
X
X(de sublex nil
X (prog1 (car *curcond*) (setq *curcond* (cdr *curcond*))))
X
X(de end-of-ce nil (atom *curcond*))
X
X(de rest-of-ce nil *curcond*)
X
X(de prepare-sublex (ce) (setq *curcond* ce))
X
X(de make-bottom-node nil (setq *first-node* (list '&bus nil)))
X
X(de cmp-p (name matrix)
X (prog (m bakptrs)
X (cond
X ((or (null name) (pairp name))
X (!%error "illegal production name" name))
X ((equal (get name 'production) matrix) (return nil)))
X (prepare-lex matrix)
X (excise-p name)
X (setq bakptrs nil)
X (setq *pcount* (iadd1 *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))
Xl1 (and (end-of-p) (!%error "no '-->' in production" m))
X (cmp-prin)
X (setq bakptrs (cons *last-branch* bakptrs))
X (cond ((not (eq '--> (peek-lex))) (go l1)))
X (lex)
X (check-rhs (rest-of-p))
X (link-new-node
X (list '&p *feature-count* name (encode-dope)
X (encode-ce-dope) (cons 'progn (rest-of-p))))
X (putprop name (cdr (reversewoc bakptrs)) 'backpointers)
X (putprop name matrix 'production)
X (putprop name *last-node* 'topnode)))
X
X(de rating-part (pnode) (cadr pnode))
X
X(de var-part (pnode) (car (cdddr pnode)))
X
X(de ce-var-part (pnode) (cadr (cdddr pnode)))
X
X(de rhs-part (pnode) (caddr (cdddr pnode)))
X
X(de excise-p (name)
X (cond
X ((get name 'topnode)
X (printline (list name 'is 'excised))
X (setq *pcount* (isub1 *pcount*))
X (remove-from-conflict-set name)
X (kill-node (get name 'topnode))
X (remprop name 'production)
X (remprop name 'backpointers)
X (remprop name 'topnode))))
X
X(de kill-node (node)
X (prog nil
Xtop (cond ((atom node) (return nil)))
X (rplaca node '&old)
X (setq node (cdr node))
X (go top)))
X
X(de cmp-prin nil
X (prog nil
X (setq *last-node* *first-node*)
X (cond
X ((null *last-branch*) (cmp-posce) (cmp-nobeta))
X ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
X (t (cmp-posce) (cmp-and)))) )
X
X(de cmp-negce nil (lex) (cmp-ce))
X
X(de cmp-posce nil
X (setq *ce-count* (iadd1 *ce-count*))
X (cond ((eq (peek-lex) '!{) (cmp-ce+cevar)) (t (cmp-ce))))
X
X(de cmp-ce+cevar nil
X (prog (z)
X (lex)
X (cond
X ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
X (t (cmp-ce) (cmp-cevar)))
X (setq z (lex))
X (or (eq z '!}) (!%error "missing '}" z))))
X
X(de new-subnum (k)
X (or (numberp k) (!%error "tab must be a number" k))
X (setq *subnum* (fix k)))
X
X(de incr-subnum nil (setq *subnum* (iadd1 *subnum*)))
X
X(de cmp-ce nil
X (prog (z)
X (new-subnum 0)
X (setq *cur-vars* nil)
X (setq z (lex))
X (and (atom z) (!%error "atomic conditions are not allowed" z))
X (prepare-sublex z)
Xla (cond ((end-of-ce) (return nil)))
X (incr-subnum)
X (cmp-element)
X (go la)))
X
X(de cmp-element nil
X (and (eq (peek-sublex) '!^) (cmp-tab))
X (cond
X ((eq (peek-sublex) '!{) (cmp-product))
X (t (cmp-atomic-or-any))))
X
X(de cmp-atomic-or-any nil
X (cond ((eq (peek-sublex) '<<) (cmp-any)) (t (cmp-atomic))))
X
X(de cmp-any nil
X (prog (a z)
X (sublex)
X (setq z nil)
Xla (cond ((end-of-ce) (!%error "missing '>>" a)))
X (setq a (sublex))
X (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
X (link-new-node (list '&any nil (current-field) z))))
X
X(de cmp-tab nil
X (prog (r)
X (sublex)
X (setq r (sublex))
X (setq r ($litbind r))
X (new-subnum r)))
X
X(de $litbind (x)
X (prog (r)
X (cond
X ((and (idp x) (setq r (literal-binding-of x)))
X (return r))
X (t (return x)))) )
X
X(de get-bind (x)
X (prog (r)
X (cond
X ((and (idp x) (setq r (literal-binding-of x)))
X (return r))
X (t (return nil)))) )
X
X(de cmp-atomic nil
X (prog (test x)
X (setq x (peek-sublex))
X (cond
X ((eq x '= ) (setq test 'eq) (sublex))
X ((eq x '<> ) (setq test 'ne) (sublex))
X ((eq x '< ) (setq test 'lt) (sublex))
X ((eq x '<= ) (setq test 'le) (sublex))
X ((eq x '> ) (setq test 'gt) (sublex))
X ((eq x '>= ) (setq test 'ge) (sublex))
X ((eq x '<=>) (setq test 'xx) (sublex))
X (t (setq test 'eq)))
X (cmp-symbol test)))
X
X(de cmp-product nil
X (prog (save)
X (setq save (rest-of-ce))
X (sublex)
Xla (cond
X ((end-of-ce)
X (cond
X ((member '!} save)
X (!%error "wrong contex for '}" save))
X (t (!%error "missing '}" save))))
X ((eq (peek-sublex) '!}) (sublex) (return nil)))
X (cmp-atomic-or-any)
X (go la)))
X
X(de variablep (x)
X (cond ((not (idp x)) nil)
X ((flagp x 'nonvariable) nil)
X ((flagp x 'variable) t)
X ((eq (car (explode x)) '<)
X (flag (list x) 'variable)
X t)
X (t (flag (list x) 'nonvariable) nil)))
X
X(de cmp-symbol (test)
X (prog (flag)
X (setq flag t)
X (cond ((eq (peek-sublex) '!/) (sublex) (setq flag nil)))
X (cond
X ((and flag (variablep (peek-sublex))) (cmp-var test))
X ((numberp (peek-sublex)) (cmp-number test))
X ((idp (peek-sublex)) (cmp-constant test))
X (t (!%error "unrecognized symbol" (sublex)))) ))
X
X(de cmp-constant (test)
X (or
X (memq test '(eq ne xx))
X (!%error
X "non-numeric constant after numeric predicate"
X (sublex)))
X (link-new-node
X (list (get test 'ta) nil (current-field) (sublex))))
X
X(de cmp-number (test)
X (link-new-node
X (list (get test 'tn) nil (current-field) (sublex))))
X
X(de current-field nil (field-name *subnum*))
X
X(de field-name (num)
X (cond
X ((igreaterp num 64) (!%error "condition is too long" (rest-of-ce)))
X (t num)))
X
X%%% Compiling variables
X%
X%
X%
X% *cur-vars* are the variables in the condition element currently
X% being compiled. *vars* are the variables in the earlier condition
X% elements. *ce-vars* are the condition element variables. note
X% that the interpreter will not confuse condition element and regular
X% variables even if they have the same name.
X%
X% *cur-vars* is a list of triples: (name predicate subelement-number)
X% eg: ( (<x> eq 3)
X% (<y> ne 1)
X% . . . )
X%
X% *vars* is a list of triples: (name ce-number subelement-number)
X% eg: ( (<x> 3 3)
X% (<y> 1 1)
X% . . . )
X%
X% *ce-vars* is a list of pairs: (name ce-number)
X% eg: ( (ce1 1)
X% (<c3> 3)
X% . . . )
X(de var-dope (var) (atsoc var *vars*))
X
X(de ce-var-dope (var) (atsoc var *ce-vars*))
X
X(de cmp-var (test)
X (prog (old name)
X (setq name (sublex))
X (setq old (atsoc name *cur-vars*))
X (cond
X ((and old (eq (cadr old) 'eq)) (cmp-old-eq-var test old))
X ((and old (eq test 'eq)) (cmp-new-eq-var name old))
X (t (cmp-new-var name test)))) )
X
X(de cmp-new-var (name test)
X (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*)))
X
X(de cmp-old-eq-var (test old)
X (link-new-node
X (list
X (get test 'ts)
X nil
X (current-field)
X (field-name (caddr old)))) )
X
X(de cmp-new-eq-var (name old)
X (prog (pred next)
X (setq *cur-vars* (delq old *cur-vars*))
X (setq next (atsoc name *cur-vars*))
X (cond
X (next (cmp-new-eq-var name next))
X (t (cmp-new-var name 'eq)))
X (setq pred (cadr old))
X (link-new-node
X (list
X (get pred 'ts)
X nil
X (field-name (caddr old))
X (current-field)))) )
X
X(de cmp-cevar nil
X (prog (name old)
X (setq name (lex))
X (setq old (atsoc name *ce-vars*))
X (and
X old
X (!%error "condition element variable used twice" name))
X (setq *ce-vars* (cons (list name 0) *ce-vars*))))
X
X(de cmp-not nil (cmp-beta '¬))
X
X(de cmp-nobeta nil (cmp-beta nil))
X
X(de cmp-and nil (cmp-beta '&and))
X
X(de cmp-beta (kind)
X (prog (tlist vdope vname vpred vpos old)
X (setq tlist nil)
Xla (cond ((atom *cur-vars*) (go lb)))
X (setq vdope (car *cur-vars*))
X (setq *cur-vars* (cdr *cur-vars*))
X (setq vname (car vdope))
X (setq vpred (cadr vdope))
X (setq vpos (caddr vdope))
X (setq old (atsoc vname *vars*))
X (cond
X (old (setq tlist (add-test tlist vdope old)))
X ((neq kind '¬) (promote-var vdope)))
X (go la)
Xlb (and kind (build-beta kind tlist))
X (or (eq kind '¬) (fudge))
X (setq *last-branch* *last-node*)))
X
X(de add-test (list new old)
X (prog (ttype lloc rloc)
X (setq *feature-count* (iadd1 *feature-count*))
X (setq ttype (get (cadr new) 'tb))
X (setq rloc (encode-singleton (caddr new)))
X (setq lloc (encode-pair (cadr old) (caddr old)))
X (return (cons ttype (cons lloc (cons rloc list)))) ))
X
X% the following two functions encode indices so that gelm can
X% decode them as fast as possible
X(de encode-pair (a b) (iplus (times 10000 (sub1 a)) (isub1 b)))
X
X(de encode-singleton (a) (isub1 a))
X
X(de promote-var (dope)
X (prog (vname vpred vpos new)
X (setq vname (car dope))
X (setq vpred (cadr dope))
X (setq vpos (caddr dope))
X (or
X (eq 'eq vpred)
X (!%error
X "illegal predicate for first occurrence"
X (list vname vpred)))
X (setq new (list vname 0 vpos))
X (setq *vars* (cons new *vars*))))
X
X(de fudge nil
X (!!mapc (function fudge*) *vars*)
X (!!mapc (function fudge*) *ce-vars*))
X
X(de fudge* (z)
X (prog (a)
X (setq a (cdr z))
X (rplaca a (iadd1 (car a)))) )
X
X(de build-beta (type tests)
X (prog (rpred lpred lnode lef)
X (link-new-node (list '&mem nil nil (protomem)))
X (setq rpred *last-node*)
X (cond
X ((eq type '&and)
X (setq lnode (list '&mem nil nil (protomem))))
X (t (setq lnode (list '&two nil nil))))
X (setq lpred (link-to-branch lnode))
X (cond
X ((eq type '&and) (setq lef lpred))
X (t (setq lef (protomem))))
X (link-new-beta-node (list type nil lef rpred tests))))
X
X(de protomem nil (list nil))
X
X(de memory-part (mem-node) (car (cadddr mem-node)))
X
X(de encode-dope nil
X (prog (r all z k)
X (setq r nil)
X (setq all *vars*)
Xla (cond ((atom all) (return r)))
X (setq z (car all))
X (setq all (cdr all))
X (setq k (encode-pair (cadr z) (caddr z)))
X (setq r (cons (car z) (cons k r)))
X (go la)))
X
X(de encode-ce-dope nil
X (prog (r all z k)
X (setq r nil)
X (setq all *ce-vars*)
Xla (cond ((atom all) (return r)))
X (setq z (car all))
X (setq all (cdr all))
X (setq k (cadr z))
X (setq r (cons (car z) (cons k r)))
X (go la)))
X
X%%% Linking the nodes
X
X(de link-new-node (r)
X (cond
X ((not (member (car r) '(&p &mem &two &and ¬)))
X (setq *feature-count* (iadd1 *feature-count*))))
X (setq *virtual-cnt* (iadd1 *virtual-cnt*))
X (setq *last-node* (link-left *last-node* r)))
X
X(de link-to-branch (r)
X (setq *virtual-cnt* (iadd1 *virtual-cnt*))
X (setq *last-branch* (link-left *last-branch* r)))
X
X(de link-new-beta-node (r)
X (setq *virtual-cnt* (iadd1 *virtual-cnt*))
X (setq *last-node* (link-both *last-branch* *last-node* r))
X (setq *last-branch* *last-node*))
X
X(de link-left (pred succ)
X (prog (a r)
X (setq a (left-outs pred))
X (setq r (find-equiv-node succ a))
X (cond (r (return r)))
X (setq *real-cnt* (iadd1 *real-cnt*))
X (attach-left pred succ)
X (return succ)))
X
X(de link-both (left right succ)
X (prog (a r)
X (setq a (interq (left-outs left) (right-outs right)))
X (setq r (find-equiv-beta-node succ a))
X (cond (r (return r)))
X (setq *real-cnt* (iadd1 *real-cnt*))
X (attach-left left succ)
X (attach-right right succ)
X (return succ)))
X
X(de attach-right (old new)
X (rplaca (cddr old) (cons new (caddr old))))
X
X(de attach-left (old new) (rplaca (cdr old) (cons new (cadr old))))
X
X(de right-outs (node) (caddr node))
X
X(de left-outs (node) (cadr node))
X
X(de find-equiv-node (node list)
X (prog (a)
X (setq a list)
Xl1 (cond
X ((atom a) (return nil))
X ((equiv node (car a)) (return (car a))))
X (setq a (cdr a))
X (go l1)))
X
X(de find-equiv-beta-node (node list)
X (prog (a)
X (setq a list)
Xl1 (cond
X ((atom a) (return nil))
X ((beta-equiv node (car a)) (return (car a))))
X (setq a (cdr a))
X (go l1)))
X
X% do not look at the predecessor fields of beta nodes; they have to be
X% identical because of the way the candidate nodes were found
X(de equiv (a b)
X (and
X (eq (car a) (car b))
X (or
X (eq (car a) '&mem)
X (eq (car a) '&two)
X (equal (caddr a) (caddr b)))
X (equal (cdddr a) (cdddr b))))
X
X(de beta-equiv (a b)
X (and
X (eq (car a) (car b))
X (equal (cddddr a) (cddddr b))
X (or (eq (car a) '&and) (equal (caddr a) (caddr b)))) )
X
X% the equivalence tests are set up to consider the contents of
X% node memories, so they are ready for the build action
X
X
X%%% Network interpreter
X
X(de match (flag wme)
X (sendto flag (list wme) 'left (list *first-node*)))
X
X% note that eval-nodelist is not set up to handle building
X% productions. would have to add something like ops4's build-flag
X(de eval-nodelist (nl)
X (prog nil
Xtop (cond ((null nl) (return nil)))
X (setq *sendtocall* nil)
X (setq *last-node* (car nl))
X (apply (caar nl) (cdar nl))
X (setq nl (cdr nl))
X (go top)))
X
X(de sendto (flag data side nl)
X (prog nil
Xtop (cond ((not nl) (return nil)))
X (setq *side* side)
X (setq *flag-part* flag)
X (setq *data-part* data)
X (setq *sendtocall* t)
X (setq *last-node* (car nl))
X (apply (caar nl) (cdar nl))
X (setq nl (cdr nl))
X (go top)))
X
X% &bus sets up the registers for the one-input nodes.
X% Heavily modified by JPff
X
X(de &bus (outs)
X (prog (dp i)
X (setq i 1)
X (setq *alpha-flag-part* *flag-part*)
X (setq dp (car (setq *alpha-data-part* *data-part*)))
X (while dp
X (progn
X (putv *cvec* i (car dp))
X (setq i (iadd1 i))
X (setq dp (cdr dp))))
X (setq i (isub1 i))
X (cond
X ((ilessp i *cvec-least*)
X (prog (j)
X (setq j (iadd1 i))
X (while (ilessp j *cvec-least*)
X (progn (putv *cvec* j nil)
X (setq j (iadd1 j)))))))
X (setq *cvec-least* i)
X (eval-nodelist outs)))
X
X(de &any (outs register const-list)
X (prog (z c)
X (setq z (getv *cvec* register))
X (cond ((numberp z) (go number)))
Xsymbol(cond
X ((null const-list) (return nil))
X ((eq (car const-list) z) (go ok))
X (t (setq const-list (cdr const-list)) (go symbol)))
Xnumber(cond
X ((null const-list) (return nil))
X ((and (numberp (setq c (car const-list))) (=alg c z))
X (go ok))
X (t (setq const-list (cdr const-list)) (go number)))
Xok (eval-nodelist outs)))
X
X(de teqa (outs register constant)
X (and (eq (getv *cvec* register) constant) (eval-nodelist outs)))
X
X(put 'eq 'ta 'teqa)
X
X(de tnea (outs register constant)
X (and
X (not (eq (getv *cvec* register) constant))
X (eval-nodelist outs)))
X
X(put 'ne 'ta 'tnea)
X
X(de txxa (outs register constant)
X (and (idp (getv *cvec* register)) (eval-nodelist outs)))
X
X(put 'xx 'ta 'txxa)
X
X(de teqn (outs register constant)
X (prog (z)
X (setq z (getv *cvec* register))
X (and (numberp z) (=alg z constant) (eval-nodelist outs))))
X
X(put 'eq 'tn 'teqn)
X
X(de tnen (outs register constant)
X (prog (z)
X (setq z (getv *cvec* register))
X (and
X (or (not (numberp z)) (not (=alg z constant)))
X (eval-nodelist outs))))
X
X(put 'ne 'tn 'tnen)
X
X(de txxn (outs register constant)
X (and (numberp (getv *cvec* register)) (eval-nodelist outs)))
X
X(put 'xx 'tn 'txxn)
X
X(de tltn (outs register constant)
X (prog (z)
X (setq z (getv *cvec* register))
X (and (numberp z) (greaterp constant z) (eval-nodelist outs))))
X
X(put 'lt 'tn 'tltn)
X
X(de tgtn (outs register constant)
X (prog (z)
X (setq z (getv *cvec* register))
X (and (numberp z) (greaterp z constant) (eval-nodelist outs))))
X
X(put 'gt 'tn 'tgtn)
X
X(de tgen (outs register constant)
X (prog (z)
X (setq z (getv *cvec* register))
X (and
X (numberp z)
X (not (greaterp constant z))
X (eval-nodelist outs))))
X
X(put 'ge 'tn 'tgen)
X
X(de tlen (outs register constant)
X (prog (z)
X (setq z (getv *cvec* register))
SHAR_EOF
echo "End of part 1, continue with part 2"
echo "2" > s2_seq_.tmp
exit 0