home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e051 / 3.ddi / MAC / VPS2.MCL < prev   
Encoding:
Text File  |  1985-01-07  |  98.8 KB  |  3,265 lines
  1. ;    VPS2 -- Interpreter for OPS5
  2. ;
  3. ;    Copyright (C) 1979, 1980, 1981
  4. ;    Charles L. Forgy,  Pittsburgh, Pennsylvania
  5.  
  6.  
  7.  
  8. ; Users of this interpreter are requested to contact
  9. ;
  10. ;    Charles Forgy
  11. ;    Computer Science Department
  12. ;    Carnegie-Mellon University
  13. ;    Pittsburgh, PA  15213
  14. ; or
  15. ;    Forgy@CMUA
  16. ;
  17. ; so that they can be added to the mailing list for OPS5.  The mailing list
  18. ; is needed when new versions of the interpreter or manual are released.
  19.  
  20.  
  21. ;;; Definitions
  22.  
  23.  
  24.  
  25. (declare (special *matrix* *feature-count* *pcount* *vars* *cur-vars*
  26.           *curcond* *subnum* *last-node* *last-branch* *first-node*
  27.           *sendtocall* *flag-part* *alpha-flag-part* *data-part*
  28.           *alpha-data-part* *ce-vars* *virtual-cnt* *real-cnt*
  29.           *current-token* *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9*
  30.           *c10* *c11* *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19*
  31.           *c20* *c21* *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29*
  32.           *c30* *c31* *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39*
  33.           *c40* *c41* *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49*
  34.           *c50* *c51* *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59*
  35.           *c60* *c61* *c62* *c63* *c64* *record-array* *result-array*
  36.           *max-cs* *total-cs* *limit-cs* *cr-temp* *side*
  37.           *conflict-set* *halt-flag* *phase* *critical*
  38.           *cycle-count* *total-token* *max-token* *refracts*
  39.           *limit-token* *total-wm* *current-wm* *max-wm*
  40.           *action-count* *wmpart-list* *wm* *data-matched* *p-name*
  41.           *variable-memory* *ce-variable-memory* *max-index*
  42.           *next-index* *size-result-array* *rest* *build-trace* *last*
  43.           *ptrace* *wtrace* *in-rhs* *recording* *accept-file* *trace-file*
  44.           *write-file* *record-index* *max-record-index* *old-wm*
  45.           *record* *filters* *break-flag* *strategy* *remaining-cycles*
  46.       *wm-filter* *rhs-bound-vars* *rhs-bound-ce-vars* *ppline*
  47.       *ce-count* *brkpts* *class-list* *buckets* *action-type*))
  48.  
  49.  
  50. ;;; Changes that had to be made to allow running in MACLISP
  51.  
  52. ; use DEFMACRO instead of DEF
  53. ; change the function / to //
  54. ; use / for quote rather than \
  55. ; redefine FAST-SYMEVAL
  56. ; redefine ==
  57. ; eliminate LOCALF declarations
  58. ; use ))))))) instead of ]
  59. ; give different arguments to SETSYNTAX
  60. ; eliminate second argument to FLATC
  61. ; do not set TRANSLINK
  62. ; always have an argument for NWRITN
  63. ; change INTERQ to INTRQ (to avoid name clash with slurp)
  64. ; change *RPLACX to RPLACX
  65. ; add mode argument to TYIPEEK
  66. ; add end-of-file argument to TYI and TYIPEEK
  67. ; change ACCEPT & ACCEPTLINE extensively
  68.  
  69. ; define the following functions
  70.  
  71. (defun dtpr (z) (eq (typep z) 'list))
  72.  
  73. (defun infile (x) (open x '(in)))
  74.  
  75. (defun outfile (x) (open x '(out)))
  76.  
  77. (defun nwritn (x) (charpos x))
  78.  
  79. (defun mod (x y) (remainder x y))
  80.  
  81. (defun readc (x) (readch x))
  82.  
  83. (defun concat (a b c)
  84.   (readlist (nconc (explode a) (explode b) (explode c))))
  85.  
  86. (defun drain () nil)
  87.  
  88. (defun *makhunk (x) (makhunk (^ 2 (1+ x))))
  89.  
  90. (defun exit fexpr (z) (quit))
  91.  
  92.  
  93. ;;; Functions that were revised so that they would compile efficiently
  94.  
  95.  
  96. ;* The function == is machine dependent!
  97. ;* This function compares small integers for equality.  It uses EQ
  98. ;* so that it will be fast, and it will consequently not work on all
  99. ;* Lisps.  It works in Franz Lisp for integers in [-128, 127]
  100. ;*
  101. ;*(def == (macro (z) `(eq ,(cadr z) ,(caddr z))))
  102.  
  103. (defmacro == (x y) `(= ,x ,y))
  104.  
  105. ; =ALG returns T if A and B are algebraicly equal.
  106.  
  107. (defun =alg (a b) (zerop (difference a b)))
  108.  
  109. (defmacro fast-symeval (x) `(symeval ,x))
  110.  
  111. ; getvector and putvector are fast routines for using one-dimensional
  112. ; arrays.  these routines do no checking; they assume
  113. ;    1. the array is a vector with 0 being the index of the first
  114. ;       element
  115. ;    2. the vector holds arbitrary list values
  116.  
  117. ; Example call: (putvector array index value)
  118.  
  119. (defmacro putvector (hunk indx val) `(rplacx ,indx ,hunk ,val))
  120.  
  121. ; Example call: (getvector name index)
  122.  
  123. (defmacro getvector (hunk indx) `(cxr ,indx ,hunk))
  124.  
  125. (defun ce-gelm (x k)
  126.   (prog nil
  127.    loop (and (== k 1.) (return (car x)))
  128.         (setq k (1- k))
  129.         (setq x (cdr x))
  130.         (go loop)))
  131.  
  132. ; The loops in gelm were unwound so that fewer calls on DIFFERENCE
  133. ; would be needed
  134.  
  135. (defun gelm (x k)
  136.   (prog (ce sub)
  137.         (setq ce (// k 10000.))
  138.         (setq sub (- k (* ce 10000.)))
  139.    celoop (and (== ce 0.) (go ph2))
  140.         (setq x (cdr x))
  141.         (and (== ce 1.) (go ph2))
  142.         (setq x (cdr x))
  143.         (and (== ce 2.) (go ph2))
  144.         (setq x (cdr x))
  145.         (and (== ce 3.) (go ph2))
  146.         (setq x (cdr x))
  147.         (and (== ce 4.) (go ph2))
  148.         (setq ce (- ce 4.))
  149.         (go celoop)
  150.    ph2  (setq x (car x))
  151.    subloop (and (== sub 0.) (go finis))
  152.         (setq x (cdr x))
  153.         (and (== sub 1.) (go finis))
  154.         (setq x (cdr x))
  155.         (and (== sub 2.) (go finis))
  156.         (setq x (cdr x))
  157.         (and (== sub 3.) (go finis))
  158.         (setq x (cdr x))
  159.         (and (== sub 4.) (go finis))
  160.         (setq x (cdr x))
  161.         (and (== sub 5.) (go finis))
  162.         (setq x (cdr x))
  163.         (and (== sub 6.) (go finis))
  164.         (setq x (cdr x))
  165.         (and (== sub 7.) (go finis))
  166.         (setq x (cdr x))
  167.         (and (== sub 8.) (go finis))
  168.         (setq sub (- sub 8.))
  169.         (go subloop)
  170.    finis (return (car x))))
  171.  
  172.  
  173. ;;; Utility functions
  174.  
  175.  
  176. (defmacro neq (a b) `(not (eq ,a ,b)))
  177.  
  178.  
  179. (defun printline (x) (mapc (function printline*) x))
  180.  
  181. (defun printline* (y) (princ '| |) (print y))
  182.  
  183. (defun printlinec (x) (mapc (function printlinec*) x))
  184.  
  185. (defun printlinec* (y) (princ '| |) (princ y))
  186.  
  187. ; intersect two lists using eq for the equality test
  188.  
  189. (defun intrq (x y)
  190.   (cond ((atom x) nil)
  191.         ((memq (car x) y) (cons (car x) (intrq (cdr x) y)))
  192.         (t (intrq (cdr x) y))))
  193.  
  194. (defun i-g-v nil
  195.   (prog (x)
  196.     (setsyntax '/{ 'single nil)
  197.     (setsyntax '/} 'single nil)
  198.     (setsyntax '^ 'single nil)
  199.     (setq *buckets* 64.)        ; OPS5 allows 64 named slots
  200.     (setq *accept-file* nil)
  201.     (setq *write-file* nil)
  202.     (setq *trace-file* nil)
  203.     (setq *class-list* nil)
  204.     (setq *brkpts* nil)
  205.     (setq *strategy* 'lex)
  206.       (setq *in-rhs* nil)
  207.       (setq *ptrace* t)
  208.       (setq *wtrace* nil)
  209.       (setq *recording* nil)
  210.         (setq *refracts* nil)
  211.     (setq *real-cnt* (setq *virtual-cnt* 0.))
  212.     (setq *max-cs* (setq *total-cs* 0.))
  213.       (setq *limit-token* 1000000.)
  214.     (setq *limit-cs* 1000000.)
  215.     (setq *critical* nil)
  216.     (setq *build-trace* nil)
  217.     (setq *wmpart-list* nil)
  218.     (setq *size-result-array* 127.)
  219.     (setq *result-array* (*makhunk 6))
  220.     (setq *record-array* (*makhunk 6))
  221.     (setq x 0)
  222.   loop    (putvector *result-array* x nil)
  223.     (setq x (1+ x))
  224.     (and (not (> x *size-result-array*)) (go loop))
  225.     (make-bottom-node)
  226.     (setq *pcount* 0.)
  227.     (initialize-record)
  228.     (setq *cycle-count* (setq *action-count* 0.))
  229.     (setq *total-token*
  230.            (setq *max-token* (setq *current-token* 0.)))
  231.     (setq *total-cs* (setq *max-cs* 0.))
  232.     (setq *total-wm* (setq *max-wm* (setq *current-wm* 0.)))
  233.     (setq *conflict-set* nil)
  234.     (setq *wmpart-list* nil)
  235.     (setq *p-name* nil)
  236.     (setq *remaining-cycles* 1000000)))))))
  237.  
  238. ; if the size of result-array changes, change the line in i-g-v which
  239. ; sets the value of *size-result-array*
  240.  
  241. (defun %warn (what where)
  242.   (prog nil
  243.     (terpri)
  244.     (princ '?)
  245.     (and *p-name* (princ *p-name*))
  246.     (princ '|..|)
  247.     (princ where)
  248.     (princ '|..|)
  249.     (princ what)
  250.     (return where)))
  251.  
  252. (defun %error (what where)
  253.     (%warn what where)
  254.     (throw '!error! !error!))
  255.  
  256. (defun round (x) (fix (plus 0.5 x)))
  257.  
  258. (defun top-levels-eq (la lb)
  259.   (prog nil
  260.    lx   (cond ((eq la lb) (return t))
  261.               ((null la) (return nil))
  262.               ((null lb) (return nil))
  263.               ((not (eq (car la) (car lb))) (return nil)))
  264.         (setq la (cdr la))
  265.         (setq lb (cdr lb))
  266.         (go lx)))
  267.  
  268.  
  269. ;;; LITERAL and LITERALIZE
  270.  
  271. (defun literal fexpr (z)
  272.   (prog (atm val old)
  273.    top  (and (atom z) (return 'bound))
  274.         (or (eq (cadr z) '=) (return (%warn '|wrong format| z)))
  275.         (setq atm (car z))
  276.         (setq val (caddr z))
  277.         (setq z (cdddr z))
  278.         (cond ((not (numberp val))
  279.                (%warn '|can bind only to numbers| val))
  280.               ((or (not (symbolp atm)) (variablep atm))
  281.                (%warn '|can bind only constant atoms| atm))
  282.               ((and (setq old (literal-binding-of atm)) (not (equal old val)))
  283.                (%warn '|attempt to rebind attribute| atm))
  284.               (t (putprop atm val 'ops-bind)))
  285.         (go top)))
  286.  
  287. (defun literalize fexpr (l)
  288.   (prog (class-name atts)
  289.     (setq class-name (car l))
  290.     (cond ((have-compiled-production)
  291.            (%warn '|literalize called after p| class-name)
  292.            (return nil))
  293.           ((get class-name 'att-list)
  294.            (%warn '|attempt to redefine class| class-name)
  295.        (return nil)))
  296.     (setq *class-list* (cons class-name *class-list*))
  297.     (setq atts (remove-duplicates (cdr l)))
  298.     (test-attribute-names atts)
  299.     (mark-conflicts atts atts)
  300.     (putprop class-name atts 'att-list)))
  301.  
  302. (defun vector-attribute fexpr (l)
  303.   (cond ((have-compiled-production)
  304.          (%warn '|vector-attribute called after p| l))
  305.         (t
  306.          (test-attribute-names l)
  307.      (mapc (function vector-attribute2) l))))
  308.  
  309. (defun vector-attribute2 (att) (putprop att t 'vector-attribute))
  310.  
  311. (defun is-vector-attribute (att) (get att 'vector-attribute))
  312.  
  313. (defun test-attribute-names (l)
  314.   (mapc (function test-attribute-names2) l))
  315.  
  316. (defun test-attribute-names2 (atm)
  317.   (cond ((or (not (symbolp atm)) (variablep atm))
  318.          (%warn '|can bind only constant atoms| atm))))
  319.  
  320. (defun finish-literalize nil
  321.   (cond ((not (null *class-list*))
  322.          (mapc (function note-user-assigns) *class-list*)
  323.          (mapc (function assign-scalars) *class-list*)
  324.          (mapc (function assign-vectors) *class-list*)
  325.          (mapc (function put-ppdat) *class-list*)
  326.          (mapc (function erase-literal-info) *class-list*)
  327.          (setq *class-list* nil)
  328.          (setq *buckets* nil))))
  329.  
  330. (defun have-compiled-production nil (not (zerop *pcount*)))
  331.  
  332. (defun put-ppdat (class)
  333.   (prog (al att ppdat)
  334.         (setq ppdat nil)
  335.         (setq al (get class 'att-list))
  336.    top  (cond ((not (atom al))
  337.                (setq att (car al))
  338.                (setq al (cdr al))
  339.                (setq ppdat
  340.                      (cons (cons (literal-binding-of att) att)
  341.                            ppdat))
  342.                (go top)))
  343.         (putprop class ppdat 'ppdat)))
  344.  
  345. ; note-user-assigns and note-user-vector-assigns are needed only when
  346. ; literal and literalize are both used in a program.  They make sure that
  347. ; the assignments that are made explicitly with literal do not cause problems
  348. ; for the literalized classes.
  349.  
  350. (defun note-user-assigns (class)
  351.   (mapc (function note-user-assigns2) (get class 'att-list)))
  352.  
  353. (defun note-user-assigns2 (att)
  354.   (prog (num conf buck clash)
  355.         (setq num (literal-binding-of att))
  356.     (and (null num) (return nil))
  357.     (setq conf (get att 'conflicts))
  358.     (setq buck (store-binding att num))
  359.     (setq clash (find-common-atom buck conf))
  360.     (and clash
  361.          (%warn '|attributes in a class assigned the same number|
  362.                 (cons att clash)))
  363.         (return nil)))
  364.  
  365. (defun note-user-vector-assigns (att given needed)
  366.   (and (> needed given)
  367.        (%warn '|vector attribute assigned too small a value in literal| att)))
  368.  
  369. (defun assign-scalars (class)
  370.   (mapc (function assign-scalars2) (get class 'att-list)))
  371.  
  372. (defun assign-scalars2 (att)
  373.   (prog (tlist num bucket conf)
  374.         (and (literal-binding-of att) (return nil))
  375.         (and (is-vector-attribute att) (return nil))
  376.         (setq tlist (buckets))
  377.         (setq conf (get att 'conflicts))
  378.    top  (cond ((atom tlist)
  379.                (%warn '|could not generate a binding| att)
  380.                (store-binding att -1.)
  381.                (return nil)))
  382.         (setq num (caar tlist))
  383.         (setq bucket (cdar tlist))
  384.         (setq tlist (cdr tlist))
  385.         (cond ((disjoint bucket conf) (store-binding att num))
  386.         (t (go top)))))
  387.  
  388. (defun assign-vectors (class)
  389.   (mapc (function assign-vectors2) (get class 'att-list)))
  390.  
  391. (defun assign-vectors2 (att)
  392.   (prog (big conf new old need)
  393.         (and (not (is-vector-attribute att)) (return nil))
  394.         (setq big 1.)
  395.         (setq conf (get att 'conflicts))
  396.    top  (cond ((not (atom conf))
  397.                (setq new (car conf))
  398.                (setq conf (cdr conf))
  399.                (cond ((is-vector-attribute new)
  400.                       (%warn '|class has two vector attributes|
  401.                       (list att new)))
  402.                      (t (setq big (max (literal-binding-of new) big))))
  403.                (go top)))
  404.         (setq need (1+ big))
  405.     (setq old (literal-binding-of att))
  406.     (cond (old (note-user-vector-assigns att old need))
  407.           (t (store-binding att need)))
  408.         (return nil)))
  409.  
  410. (defun disjoint (la lb) (not (find-common-atom la lb)))
  411.  
  412. (defun find-common-atom (la lb)
  413.   (prog nil
  414.    top  (cond ((null la) (return nil))
  415.               ((memq (car la) lb) (return (car la)))
  416.               (t (setq la (cdr la)) (go top)))))
  417.  
  418. (defun mark-conflicts (rem all)
  419.   (cond ((not (null rem))
  420.          (mark-conflicts2 (car rem) all)
  421.          (mark-conflicts (cdr rem) all))))
  422.  
  423. (defun mark-conflicts2 (atm lst)
  424.   (prog (l)
  425.         (setq l lst)
  426.    top  (and (atom l) (return nil))
  427.         (conflict atm (car l))
  428.         (setq l (cdr l))
  429.         (go top)))
  430.  
  431. (defun conflict (a b)
  432.   (prog (old)
  433.     (setq old (get a 'conflicts))
  434.     (and (not (eq a b))
  435.          (not (memq b old))
  436.          (putprop a (cons b old) 'conflicts))))
  437.  
  438. (defun remove-duplicates (lst)
  439.   (cond ((atom lst) nil)
  440.         ((memq (car lst) (cdr lst)) (remove-duplicates (cdr lst)))
  441.         (t (cons (car lst) (remove-duplicates (cdr lst))))))
  442.  
  443. (defun literal-binding-of (name) (get name 'ops-bind))
  444.  
  445. (defun store-binding (name lit)
  446.   (putprop name lit 'ops-bind)
  447.   (add-bucket name lit))
  448.  
  449. (defun add-bucket (name num)
  450.   (prog (buc)
  451.     (setq buc (assoc num (buckets)))
  452.     (and (not (memq name buc))
  453.          (rplacd buc (cons name (cdr buc))))
  454.     (return buc)))
  455.  
  456. (defun buckets nil
  457.   (and (atom *buckets*) (setq *buckets* (make-nums *buckets*)))
  458.   *buckets*)
  459.  
  460. (defun make-nums (k)
  461.   (prog (nums)
  462.         (setq nums nil)
  463.    l    (and (< k 2.) (return nums))
  464.         (setq nums (cons (ncons k) nums))
  465.         (setq k (1- k))
  466.         (go l)))
  467.  
  468. (defun erase-literal-info (class)
  469.   (mapc (function erase-literal-info2) (get class 'att-list))
  470.   (remprop class 'att-list))
  471.  
  472. (defun erase-literal-info2 (att) (remprop att 'conflicts))
  473.  
  474.  
  475. ;;; LHS Compiler
  476.  
  477. (defun p fexpr (z)
  478.   (finish-literalize)
  479.   (princ '*)
  480.   (drain)
  481.   (compile-production (car z) (cdr z)))
  482.  
  483. (defun compile-production (name matrix)
  484.   (prog (erm)
  485.         (setq *p-name* name)
  486.         (setq erm (catch (cmp-p name matrix) !error!))
  487.     (setq *p-name* nil)))
  488.  
  489. (defun peek-lex nil (car *matrix*))
  490.  
  491. (defun lex nil
  492.   (prog2 nil (car *matrix*) (setq *matrix* (cdr *matrix*))))
  493.  
  494. (defun end-of-p nil (atom *matrix*))
  495.  
  496. (defun rest-of-p nil *matrix*)
  497.  
  498. (defun prepare-lex (prod) (setq *matrix* prod))
  499.  
  500.  
  501. (defun peek-sublex nil (car *curcond*))
  502.  
  503. (defun sublex nil
  504.   (prog2 nil (car *curcond*) (setq *curcond* (cdr *curcond*))))
  505.  
  506. (defun end-of-ce nil (atom *curcond*))
  507.  
  508. (defun rest-of-ce nil *curcond*)
  509.  
  510. (defun prepare-sublex (ce) (setq *curcond* ce))
  511.  
  512. (defun make-bottom-node nil (setq *first-node* (list '&bus nil)))
  513.  
  514. (defun cmp-p (name matrix)
  515.   (prog (m bakptrs)
  516.         (cond ((or (null name) (dtpr name))
  517.                (%error '|illegal production name| name))
  518.               ((equal (get name 'production) matrix)
  519.            (return nil)))
  520.         (prepare-lex matrix)
  521.         (excise-p name)
  522.         (setq bakptrs nil)
  523.         (setq *pcount* (1+ *pcount*))
  524.         (setq *feature-count* 0.)
  525.     (setq *ce-count* 0)
  526.         (setq *vars* nil)
  527.         (setq *ce-vars* nil)
  528.     (setq *rhs-bound-vars* nil)
  529.     (setq *rhs-bound-ce-vars* nil)
  530.         (setq *last-branch* nil)
  531.         (setq m (rest-of-p))
  532.    l1   (and (end-of-p) (%error '|no '-->' in production| m))
  533.         (cmp-prin)
  534.         (setq bakptrs (cons *last-branch* bakptrs))
  535.         (or (eq '--> (peek-lex)) (go l1))
  536.         (lex)
  537.     (check-rhs (rest-of-p))
  538.         (link-new-node (list '&p
  539.                              *feature-count*
  540.                              name
  541.                              (encode-dope)
  542.                              (encode-ce-dope)
  543.                              (cons 'progn (rest-of-p))))
  544.         (putprop name (cdr (nreverse bakptrs)) 'backpointers)
  545.     (putprop name matrix 'production)
  546.         (putprop name *last-node* 'topnode)))
  547.  
  548. (defun rating-part (pnode) (cadr pnode))
  549.  
  550. (defun var-part (pnode) (car (cdddr pnode)))
  551.  
  552. (defun ce-var-part (pnode) (cadr (cdddr pnode)))
  553.  
  554. (defun rhs-part (pnode) (caddr (cdddr pnode)))
  555.  
  556. (defun excise-p (name)
  557.   (cond ((and (symbolp name) (get name 'topnode))
  558.      (printline (list name 'is 'excised))
  559.          (setq *pcount* (1- *pcount*))
  560.          (remove-from-conflict-set name)
  561.          (kill-node (get name 'topnode))
  562.      (remprop name 'production)
  563.      (remprop name 'backpointers)
  564.          (remprop name 'topnode))))
  565.  
  566. (defun kill-node (node)
  567.   (prog nil
  568.    top  (and (atom node) (return nil))
  569.         (rplaca node '&old)
  570.         (setq node (cdr node))
  571.         (go top)))
  572.  
  573. (defun cmp-prin nil
  574.   (prog nil
  575.         (setq *last-node* *first-node*)
  576.         (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta))
  577.               ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
  578.               (t (cmp-posce) (cmp-and)))))
  579.  
  580. (defun cmp-negce nil (lex) (cmp-ce))
  581.  
  582. (defun cmp-posce nil
  583.   (setq *ce-count* (1+ *ce-count*))
  584.   (cond ((eq (peek-lex) '/{) (cmp-ce+cevar))
  585.         (t (cmp-ce))))
  586.  
  587. (defun cmp-ce+cevar nil
  588.   (prog (z)
  589.         (lex)
  590.         (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
  591.               (t (cmp-ce) (cmp-cevar)))
  592.         (setq z (lex))
  593.         (or (eq z '/}) (%error '|missing '}'| z))))
  594.  
  595. (defun new-subnum (k)
  596.   (or (numberp k) (%error '|tab must be a number| k))
  597.   (setq *subnum* (fix k)))
  598.  
  599. (defun incr-subnum nil (setq *subnum* (1+ *subnum*)))
  600.  
  601. (defun cmp-ce nil
  602.   (prog (z)
  603.         (new-subnum 0.)
  604.         (setq *cur-vars* nil)
  605.         (setq z (lex))
  606.         (and (atom z)
  607.              (%error '|atomic conditions are not allowed| z))
  608.         (prepare-sublex z)
  609.    la   (and (end-of-ce) (return nil))
  610.         (incr-subnum)
  611.         (cmp-element)
  612.         (go la)))
  613.  
  614. (defun cmp-element nil
  615.         (and (eq (peek-sublex) '^) (cmp-tab))
  616.         (cond ((eq (peek-sublex) '/{) (cmp-product))
  617.               (t (cmp-atomic-or-any))))
  618.  
  619. (defun cmp-atomic-or-any nil
  620.         (cond ((eq (peek-sublex) '<<) (cmp-any))
  621.               (t (cmp-atomic))))
  622.  
  623. (defun cmp-any nil
  624.   (prog (a z)
  625.         (sublex)
  626.         (setq z nil)
  627.    la   (cond ((end-of-ce) (%error '|missing '>>'| a)))
  628.         (setq a (sublex))
  629.         (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
  630.         (link-new-node (list '&any nil (current-field) z))))
  631.  
  632.  
  633. (defun cmp-tab nil
  634.   (prog (r)
  635.         (sublex)
  636.         (setq r (sublex))
  637.         (setq r ($litbind r))
  638.         (new-subnum r)))
  639.  
  640. (defun $litbind (x)
  641.   (prog (r)
  642.         (cond ((and (symbolp x) (setq r (literal-binding-of x)))
  643.                (return r))
  644.               (t (return x)))))
  645.  
  646. (defun get-bind (x)
  647.   (prog (r)
  648.         (cond ((and (symbolp x) (setq r (literal-binding-of x)))
  649.                (return r))
  650.               (t (return nil)))))
  651.  
  652. (defun cmp-atomic nil
  653.   (prog (test x)
  654.         (setq x (peek-sublex))
  655.         (cond ((eq x '=) (setq test 'eq) (sublex))
  656.               ((eq x '<>) (setq test 'ne) (sublex))
  657.               ((eq x '<) (setq test 'lt) (sublex))
  658.               ((eq x '<=) (setq test 'le) (sublex))
  659.               ((eq x '>) (setq test 'gt) (sublex))
  660.               ((eq x '>=) (setq test 'ge) (sublex))
  661.               ((eq x '<=>) (setq test 'xx) (sublex))
  662.               (t (setq test 'eq)))
  663.         (cmp-symbol test)))
  664.  
  665. (defun cmp-product nil
  666.   (prog (save)
  667.         (setq save (rest-of-ce))
  668.         (sublex)
  669.    la   (cond ((end-of-ce)
  670.                (cond ((member '/} save)
  671.               (%error '|wrong contex for '}'| save))
  672.              (t (%error '|missing '}'| save))))
  673.               ((eq (peek-sublex) '/}) (sublex) (return nil)))
  674.         (cmp-atomic-or-any)
  675.         (go la)))
  676.  
  677. (defun variablep (x) (and (symbolp x) (eq (getchar x 1.) '<)))
  678.  
  679. (defun cmp-symbol (test)
  680.   (prog (flag)
  681.         (setq flag t)
  682.         (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil)))
  683.         (cond ((and flag (variablep (peek-sublex)))
  684.                (cmp-var test))
  685.               ((numberp (peek-sublex)) (cmp-number test))
  686.               ((symbolp (peek-sublex)) (cmp-constant test))
  687.               (t (%error '|unrecognized symbol| (sublex))))))
  688.  
  689. (defun cmp-constant (test)
  690.   (or (memq test '(eq ne xx))
  691.       (%error '|non-numeric constant after numeric predicate| (sublex)))
  692.   (link-new-node (list (concat 't test 'a)
  693.                        nil
  694.                        (current-field)
  695.                        (sublex))))
  696.  
  697. (defun cmp-number (test)
  698.   (link-new-node (list (concat 't test 'n)
  699.                        nil
  700.                        (current-field)
  701.                        (sublex))))
  702.  
  703. (defun current-field nil (field-name *subnum*))
  704.  
  705. (defun field-name (num)
  706.   (cond ((= num 1.) '*c1*)
  707.         ((= num 2.) '*c2*)
  708.         ((= num 3.) '*c3*)
  709.         ((= num 4.) '*c4*)
  710.         ((= num 5.) '*c5*)
  711.         ((= num 6.) '*c6*)
  712.         ((= num 7.) '*c7*)
  713.         ((= num 8.) '*c8*)
  714.         ((= num 9.) '*c9*)
  715.         ((= num 10.) '*c10*)
  716.         ((= num 11.) '*c11*)
  717.         ((= num 12.) '*c12*)
  718.         ((= num 13.) '*c13*)
  719.         ((= num 14.) '*c14*)
  720.         ((= num 15.) '*c15*)
  721.         ((= num 16.) '*c16*)
  722.         ((= num 17.) '*c17*)
  723.         ((= num 18.) '*c18*)
  724.         ((= num 19.) '*c19*)
  725.         ((= num 20.) '*c20*)
  726.         ((= num 21.) '*c21*)
  727.         ((= num 22.) '*c22*)
  728.         ((= num 23.) '*c23*)
  729.         ((= num 24.) '*c24*)
  730.         ((= num 25.) '*c25*)
  731.         ((= num 26.) '*c26*)
  732.         ((= num 27.) '*c27*)
  733.         ((= num 28.) '*c28*)
  734.         ((= num 29.) '*c29*)
  735.         ((= num 30.) '*c30*)
  736.         ((= num 31.) '*c31*)
  737.         ((= num 32.) '*c32*)
  738.         ((= num 33.) '*c33*)
  739.         ((= num 34.) '*c34*)
  740.         ((= num 35.) '*c35*)
  741.         ((= num 36.) '*c36*)
  742.         ((= num 37.) '*c37*)
  743.         ((= num 38.) '*c38*)
  744.         ((= num 39.) '*c39*)
  745.         ((= num 40.) '*c40*)
  746.         ((= num 41.) '*c41*)
  747.         ((= num 42.) '*c42*)
  748.         ((= num 43.) '*c43*)
  749.         ((= num 44.) '*c44*)
  750.         ((= num 45.) '*c45*)
  751.         ((= num 46.) '*c46*)
  752.         ((= num 47.) '*c47*)
  753.         ((= num 48.) '*c48*)
  754.         ((= num 49.) '*c49*)
  755.         ((= num 50.) '*c50*)
  756.         ((= num 51.) '*c51*)
  757.         ((= num 52.) '*c52*)
  758.         ((= num 53.) '*c53*)
  759.         ((= num 54.) '*c54*)
  760.         ((= num 55.) '*c55*)
  761.         ((= num 56.) '*c56*)
  762.         ((= num 57.) '*c57*)
  763.         ((= num 58.) '*c58*)
  764.         ((= num 59.) '*c59*)
  765.         ((= num 60.) '*c60*)
  766.         ((= num 61.) '*c61*)
  767.         ((= num 62.) '*c62*)
  768.         ((= num 63.) '*c63*)
  769.         ((= num 64.) '*c64*)
  770.         (t (%error '|condition is too long| (rest-of-ce)))))
  771.  
  772.  
  773. ;;; Compiling variables
  774. ;
  775. ;
  776. ;
  777. ; *cur-vars* are the variables in the condition element currently
  778. ; being compiled.  *vars* are the variables in the earlier condition
  779. ; elements.  *ce-vars* are the condition element variables.  note
  780. ; that the interpreter will not confuse condition element and regular
  781. ; variables even if they have the same name.
  782. ;
  783. ; *cur-vars* is a list of triples: (name predicate subelement-number)
  784. ; eg:        ( (<x> eq 3)
  785. ;          (<y> ne 1)
  786. ;          . . . )
  787. ;
  788. ; *vars* is a list of triples: (name ce-number subelement-number)
  789. ; eg:        ( (<x> 3 3)
  790. ;          (<y> 1 1)
  791. ;          . . . )
  792. ;
  793. ; *ce-vars* is a list of pairs: (name ce-number)
  794. ; eg:        ( (ce1 1)
  795. ;          (<c3> 3)
  796. ;          . . . )
  797.  
  798. (defun var-dope (var) (assq var *vars*))
  799.  
  800. (defun ce-var-dope (var) (assq var *ce-vars*))
  801.  
  802. (defun cmp-var (test)
  803.   (prog (old name)
  804.         (setq name (sublex))
  805.         (setq old (assq name *cur-vars*))
  806.         (cond ((and old (eq (cadr old) 'eq))
  807.                (cmp-old-eq-var test old))
  808.               ((and old (eq test 'eq)) (cmp-new-eq-var name old))
  809.               (t (cmp-new-var name test)))))
  810.  
  811. (defun cmp-new-var (name test)
  812.   (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*)))
  813.  
  814. (defun cmp-old-eq-var (test old)
  815.   (link-new-node (list (concat 't test 's)
  816.                        nil
  817.                        (current-field)
  818.                        (field-name (caddr old)))))
  819.  
  820. (defun cmp-new-eq-var (name old)
  821.   (prog (pred next)
  822.         (setq *cur-vars* (delq old *cur-vars*))
  823.         (setq next (assq name *cur-vars*))
  824.         (cond (next (cmp-new-eq-var name next))
  825.               (t (cmp-new-var name 'eq)))
  826.         (setq pred (cadr old))
  827.         (link-new-node (list (concat 't pred 's)
  828.                              nil
  829.                              (field-name (caddr old))
  830.                              (current-field)))))
  831.  
  832. (defun cmp-cevar nil
  833.   (prog (name old)
  834.         (setq name (lex))
  835.         (setq old (assq name *ce-vars*))
  836.         (and old
  837.              (%error '|condition element variable used twice| name))
  838.         (setq *ce-vars* (cons (list name 0.) *ce-vars*))))
  839.  
  840. (defun cmp-not nil (cmp-beta '¬))
  841.  
  842. (defun cmp-nobeta nil (cmp-beta nil))
  843.  
  844. (defun cmp-and nil (cmp-beta '&and))
  845.  
  846. (defun cmp-beta (kind)
  847.   (prog (tlist vdope vname vpred vpos old)
  848.         (setq tlist nil)
  849.    la   (and (atom *cur-vars*) (go lb))
  850.         (setq vdope (car *cur-vars*))
  851.         (setq *cur-vars* (cdr *cur-vars*))
  852.         (setq vname (car vdope))
  853.         (setq vpred (cadr vdope))
  854.         (setq vpos (caddr vdope))
  855.         (setq old (assq vname *vars*))
  856.         (cond (old (setq tlist (add-test tlist vdope old)))
  857.               ((neq kind '¬) (promote-var vdope)))
  858.         (go la)
  859.    lb   (and kind (build-beta kind tlist))
  860.         (or (eq kind '¬) (fudge))
  861.         (setq *last-branch* *last-node*)))
  862.  
  863. (defun add-test (list new old)
  864.   (prog (ttype lloc rloc)
  865.     (setq *feature-count* (1+ *feature-count*))
  866.         (setq ttype (concat 't (cadr new) 'b))
  867.         (setq rloc (encode-singleton (caddr new)))
  868.         (setq lloc (encode-pair (cadr old) (caddr old)))
  869.         (return (cons ttype (cons lloc (cons rloc list))))))
  870.  
  871. ; the following two functions encode indices so that gelm can
  872. ; decode them as fast as possible
  873.  
  874. (defun encode-pair (a b) (+ (* 10000. (1- a)) (1- b)))
  875.  
  876. (defun encode-singleton (a) (1- a))
  877.  
  878. (defun promote-var (dope)
  879.   (prog (vname vpred vpos new)
  880.         (setq vname (car dope))
  881.         (setq vpred (cadr dope))
  882.         (setq vpos (caddr dope))
  883.         (or (eq 'eq vpred)
  884.             (%error '|illegal predicate for first occurrence|
  885.                    (list vname vpred)))
  886.         (setq new (list vname 0. vpos))
  887.         (setq *vars* (cons new *vars*))))
  888.  
  889. (defun fudge nil
  890.   (mapc (function fudge*) *vars*)
  891.   (mapc (function fudge*) *ce-vars*))
  892.  
  893. (defun fudge* (z)
  894.   (prog (a) (setq a (cdr z)) (rplaca a (1+ (car a)))))
  895.  
  896. (defun build-beta (type tests)
  897.   (prog (rpred lpred lnode lef)
  898.         (link-new-node (list '&mem nil nil (protomem)))
  899.         (setq rpred *last-node*)
  900.         (cond ((eq type '&and)
  901.                (setq lnode (list '&mem nil nil (protomem))))
  902.               (t (setq lnode (list '&two nil nil))))
  903.         (setq lpred (link-to-branch lnode))
  904.         (cond ((eq type '&and) (setq lef lpred))
  905.               (t (setq lef (protomem))))
  906.         (link-new-beta-node (list type nil lef rpred tests))))
  907.  
  908. (defun protomem nil (list nil))
  909.  
  910. (defun memory-part (mem-node) (car (cadddr mem-node)))
  911.  
  912. (defun encode-dope nil
  913.   (prog (r all z k)
  914.         (setq r nil)
  915.         (setq all *vars*)
  916.    la   (and (atom all) (return r))
  917.         (setq z (car all))
  918.         (setq all (cdr all))
  919.         (setq k (encode-pair (cadr z) (caddr z)))
  920.         (setq r (cons (car z) (cons k r)))
  921.         (go la)))
  922.  
  923. (defun encode-ce-dope nil
  924.   (prog (r all z k)
  925.         (setq r nil)
  926.         (setq all *ce-vars*)
  927.    la   (and (atom all) (return r))
  928.         (setq z (car all))
  929.         (setq all (cdr all))
  930.         (setq k (cadr z))
  931.         (setq r (cons (car z) (cons k r)))
  932.         (go la)))
  933.  
  934.  
  935.  
  936. ;;; Linking the nodes
  937.  
  938. (defun link-new-node (r)
  939.   (cond ((not (member (car r) '(&p &mem &two &and ¬)))
  940.      (setq *feature-count* (1+ *feature-count*))))
  941.   (setq *virtual-cnt* (1+ *virtual-cnt*))
  942.   (setq *last-node* (link-left *last-node* r)))
  943.  
  944. (defun link-to-branch (r)
  945.   (setq *virtual-cnt* (1+ *virtual-cnt*))
  946.   (setq *last-branch* (link-left *last-branch* r)))
  947.  
  948. (defun link-new-beta-node (r)
  949.   (setq *virtual-cnt* (1+ *virtual-cnt*))
  950.   (setq *last-node* (link-both *last-branch* *last-node* r))
  951.   (setq *last-branch* *last-node*))
  952.  
  953. (defun link-left (pred succ)
  954.   (prog (a r)
  955.         (setq a (left-outs pred))
  956.         (setq r (find-equiv-node succ a))
  957.         (and r (return r))
  958.         (setq *real-cnt* (1+ *real-cnt*))
  959.         (attach-left pred succ)
  960.         (return succ)))
  961.  
  962. (defun link-both (left right succ)
  963.   (prog (a r)
  964.         (setq a (intrq (left-outs left) (right-outs right)))
  965.         (setq r (find-equiv-beta-node succ a))
  966.         (and r (return r))
  967.         (setq *real-cnt* (1+ *real-cnt*))
  968.         (attach-left left succ)
  969.         (attach-right right succ)
  970.         (return succ)))
  971.  
  972. (defun attach-right (old new)
  973.   (rplaca (cddr old) (cons new (caddr old))))
  974.  
  975. (defun attach-left (old new)
  976.   (rplaca (cdr old) (cons new (cadr old))))
  977.  
  978. (defun right-outs (node) (caddr node))
  979.  
  980. (defun left-outs (node) (cadr node))
  981.  
  982. (defun find-equiv-node (node list)
  983.   (prog (a)
  984.         (setq a list)
  985.    l1   (cond ((atom a) (return nil))
  986.               ((equiv node (car a)) (return (car a))))
  987.         (setq a (cdr a))
  988.         (go l1)))
  989.  
  990. (defun find-equiv-beta-node (node list)
  991.   (prog (a)
  992.         (setq a list)
  993.    l1   (cond ((atom a) (return nil))
  994.               ((beta-equiv node (car a)) (return (car a))))
  995.         (setq a (cdr a))
  996.         (go l1)))
  997.  
  998. ; do not look at the predecessor fields of beta nodes; they have to be
  999. ; identical because of the way the candidate nodes were found
  1000.  
  1001. (defun equiv (a b)
  1002.   (and (eq (car a) (car b))
  1003.        (or (eq (car a) '&mem)
  1004.            (eq (car a) '&two)
  1005.            (equal (caddr a) (caddr b)))
  1006.        (equal (cdddr a) (cdddr b))))
  1007.  
  1008. (defun beta-equiv (a b)
  1009.   (and (eq (car a) (car b))
  1010.        (equal (cddddr a) (cddddr b))
  1011.        (or (eq (car a) '&and) (equal (caddr a) (caddr b)))))
  1012.  
  1013. ; the equivalence tests are set up to consider the contents of
  1014. ; node memories, so they are ready for the build action
  1015.  
  1016. ;;; Network interpreter
  1017.  
  1018. (defun match (flag wme)
  1019.   (sendto flag (list wme) 'left (list *first-node*)))
  1020.  
  1021. ; note that eval-nodelist is not set up to handle building
  1022. ; productions.  would have to add something like ops4's build-flag
  1023.  
  1024. (defun eval-nodelist (nl)
  1025.   (prog nil
  1026.    top  (and (not nl) (return nil))
  1027.         (setq *sendtocall* nil)
  1028.     (setq *last-node* (car nl))
  1029.         (apply (caar nl) (cdar nl))
  1030.         (setq nl (cdr nl))
  1031.         (go top)))
  1032.  
  1033. (defun sendto (flag data side nl)
  1034.   (prog nil
  1035.    top  (and (not nl) (return nil))
  1036.         (setq *side* side)
  1037.         (setq *flag-part* flag)
  1038.         (setq *data-part* data)
  1039.         (setq *sendtocall* t)
  1040.     (setq *last-node* (car nl))
  1041.         (apply (caar nl) (cdar nl))
  1042.         (setq nl (cdr nl))
  1043.         (go top)))
  1044.  
  1045. ; &bus sets up the registers for the one-input nodes.  note that this
  1046. (defun &bus (outs)
  1047.   (prog (dp)
  1048.         (setq *alpha-flag-part* *flag-part*)
  1049.         (setq *alpha-data-part* *data-part*)
  1050.         (setq dp (car *data-part*))
  1051.         (setq *c1* (car dp))
  1052.         (setq dp (cdr dp))
  1053.         (setq *c2* (car dp))
  1054.         (setq dp (cdr dp))
  1055.         (setq *c3* (car dp))
  1056.         (setq dp (cdr dp))
  1057.         (setq *c4* (car dp))
  1058.         (setq dp (cdr dp))
  1059.         (setq *c5* (car dp))
  1060.         (setq dp (cdr dp))
  1061.         (setq *c6* (car dp))
  1062.         (setq dp (cdr dp))
  1063.         (setq *c7* (car dp))
  1064.         (setq dp (cdr dp))
  1065.         (setq *c8* (car dp))
  1066.         (setq dp (cdr dp))
  1067.         (setq *c9* (car dp))
  1068.         (setq dp (cdr dp))
  1069.         (setq *c10* (car dp))
  1070.         (setq dp (cdr dp))
  1071.         (setq *c11* (car dp))
  1072.         (setq dp (cdr dp))
  1073.         (setq *c12* (car dp))
  1074.         (setq dp (cdr dp))
  1075.         (setq *c13* (car dp))
  1076.         (setq dp (cdr dp))
  1077.         (setq *c14* (car dp))
  1078.         (setq dp (cdr dp))
  1079.         (setq *c15* (car dp))
  1080.         (setq dp (cdr dp))
  1081.         (setq *c16* (car dp))
  1082.         (setq dp (cdr dp))
  1083.         (setq *c17* (car dp))
  1084.         (setq dp (cdr dp))
  1085.         (setq *c18* (car dp))
  1086.         (setq dp (cdr dp))
  1087.         (setq *c19* (car dp))
  1088.         (setq dp (cdr dp))
  1089.         (setq *c20* (car dp))
  1090.         (setq dp (cdr dp))
  1091.         (setq *c21* (car dp))
  1092.         (setq dp (cdr dp))
  1093.         (setq *c22* (car dp))
  1094.         (setq dp (cdr dp))
  1095.         (setq *c23* (car dp))
  1096.         (setq dp (cdr dp))
  1097.         (setq *c24* (car dp))
  1098.         (setq dp (cdr dp))
  1099.         (setq *c25* (car dp))
  1100.         (setq dp (cdr dp))
  1101.         (setq *c26* (car dp))
  1102.         (setq dp (cdr dp))
  1103.         (setq *c27* (car dp))
  1104.         (setq dp (cdr dp))
  1105.         (setq *c28* (car dp))
  1106.         (setq dp (cdr dp))
  1107.         (setq *c29* (car dp))
  1108.         (setq dp (cdr dp))
  1109.         (setq *c30* (car dp))
  1110.         (setq dp (cdr dp))
  1111.         (setq *c31* (car dp))
  1112.         (setq dp (cdr dp))
  1113.         (setq *c32* (car dp))
  1114.         (setq dp (cdr dp))
  1115.         (setq *c33* (car dp))
  1116.         (setq dp (cdr dp))
  1117.         (setq *c34* (car dp))
  1118.         (setq dp (cdr dp))
  1119.         (setq *c35* (car dp))
  1120.         (setq dp (cdr dp))
  1121.         (setq *c36* (car dp))
  1122.         (setq dp (cdr dp))
  1123.         (setq *c37* (car dp))
  1124.         (setq dp (cdr dp))
  1125.         (setq *c38* (car dp))
  1126.         (setq dp (cdr dp))
  1127.         (setq *c39* (car dp))
  1128.         (setq dp (cdr dp))
  1129.         (setq *c40* (car dp))
  1130.         (setq dp (cdr dp))
  1131.         (setq *c41* (car dp))
  1132.         (setq dp (cdr dp))
  1133.         (setq *c42* (car dp))
  1134.         (setq dp (cdr dp))
  1135.         (setq *c43* (car dp))
  1136.         (setq dp (cdr dp))
  1137.         (setq *c44* (car dp))
  1138.         (setq dp (cdr dp))
  1139.         (setq *c45* (car dp))
  1140.         (setq dp (cdr dp))
  1141.         (setq *c46* (car dp))
  1142.         (setq dp (cdr dp))
  1143.         (setq *c47* (car dp))
  1144.         (setq dp (cdr dp))
  1145.         (setq *c48* (car dp))
  1146.         (setq dp (cdr dp))
  1147.         (setq *c49* (car dp))
  1148.         (setq dp (cdr dp))
  1149.         (setq *c50* (car dp))
  1150.         (setq dp (cdr dp))
  1151.         (setq *c51* (car dp))
  1152.         (setq dp (cdr dp))
  1153.         (setq *c52* (car dp))
  1154.         (setq dp (cdr dp))
  1155.         (setq *c53* (car dp))
  1156.         (setq dp (cdr dp))
  1157.         (setq *c54* (car dp))
  1158.         (setq dp (cdr dp))
  1159.         (setq *c55* (car dp))
  1160.         (setq dp (cdr dp))
  1161.         (setq *c56* (car dp))
  1162.         (setq dp (cdr dp))
  1163.         (setq *c57* (car dp))
  1164.         (setq dp (cdr dp))
  1165.         (setq *c58* (car dp))
  1166.         (setq dp (cdr dp))
  1167.         (setq *c59* (car dp))
  1168.         (setq dp (cdr dp))
  1169.         (setq *c60* (car dp))
  1170.         (setq dp (cdr dp))
  1171.         (setq *c61* (car dp))
  1172.         (setq dp (cdr dp))
  1173.         (setq *c62* (car dp))
  1174.         (setq dp (cdr dp))
  1175.         (setq *c63* (car dp))
  1176.         (setq dp (cdr dp))
  1177.         (setq *c64* (car dp))
  1178.         (eval-nodelist outs)))
  1179.  
  1180. (defun &any (outs register const-list)
  1181.   (prog (z c)
  1182.         (setq z (fast-symeval register))
  1183.         (cond ((numberp z) (go number)))
  1184.    symbol (cond ((null const-list) (return nil))
  1185.                 ((eq (car const-list) z) (go ok))
  1186.                 (t (setq const-list (cdr const-list)) (go symbol)))
  1187.    number (cond ((null const-list) (return nil))
  1188.                 ((and (numberp (setq c (car const-list)))
  1189.                       (=alg c z))
  1190.                  (go ok))
  1191.                 (t (setq const-list (cdr const-list)) (go number)))
  1192.    ok   (eval-nodelist outs)))
  1193.  
  1194. (defun teqa (outs register constant)
  1195.   (and (eq (fast-symeval register) constant) (eval-nodelist outs)))
  1196.  
  1197. (defun tnea (outs register constant)
  1198.   (and (not (eq (fast-symeval register) constant)) (eval-nodelist outs)))
  1199.  
  1200. (defun txxa (outs register constant)
  1201.   (and (symbolp (fast-symeval register)) (eval-nodelist outs)))
  1202.  
  1203. (defun teqn (outs register constant)
  1204.   (prog (z)
  1205.         (setq z (fast-symeval register))
  1206.         (and (numberp z)
  1207.              (=alg z constant)
  1208.              (eval-nodelist outs))))
  1209.  
  1210. (defun tnen (outs register constant)
  1211.   (prog (z)
  1212.         (setq z (fast-symeval register))
  1213.         (and (or (not (numberp z))
  1214.                  (not (=alg z constant)))
  1215.              (eval-nodelist outs))))
  1216.  
  1217. (defun txxn (outs register constant)
  1218.   (prog (z)
  1219.         (setq z (fast-symeval register))
  1220.         (and (numberp z) (eval-nodelist outs))))
  1221.  
  1222. (defun tltn (outs register constant)
  1223.   (prog (z)
  1224.         (setq z (fast-symeval register))
  1225.         (and (numberp z)
  1226.              (greaterp constant z)
  1227.              (eval-nodelist outs))))
  1228.  
  1229. (defun tgtn (outs register constant)
  1230.   (prog (z)
  1231.         (setq z (fast-symeval register))
  1232.         (and (numberp z)
  1233.              (greaterp z constant)
  1234.              (eval-nodelist outs))))
  1235.  
  1236. (defun tgen (outs register constant)
  1237.   (prog (z)
  1238.         (setq z (fast-symeval register))
  1239.         (and (numberp z)
  1240.              (not (greaterp constant z))
  1241.              (eval-nodelist outs))))
  1242.  
  1243. (defun tlen (outs register constant)
  1244.   (prog (z)
  1245.         (setq z (fast-symeval register))
  1246.         (and (numberp z)
  1247.              (not (greaterp z constant))
  1248.              (eval-nodelist outs))))
  1249.  
  1250. (defun teqs (outs vara varb)
  1251.   (prog (a b)
  1252.         (setq a (fast-symeval vara))
  1253.         (setq b (fast-symeval varb))
  1254.         (cond ((eq a b) (eval-nodelist outs))
  1255.               ((and (numberp a)
  1256.                     (numberp b)
  1257.                     (=alg a b))
  1258.                (eval-nodelist outs)))))
  1259.  
  1260. (defun tnes (outs vara varb)
  1261.   (prog (a b)
  1262.         (setq a (fast-symeval vara))
  1263.         (setq b (fast-symeval varb))
  1264.         (cond ((eq a b) (return nil))
  1265.               ((and (numberp a)
  1266.                     (numberp b)
  1267.                     (=alg a b))
  1268.                (return nil))
  1269.               (t (eval-nodelist outs)))))
  1270.  
  1271. (defun txxs (outs vara varb)
  1272.   (prog (a b)
  1273.         (setq a (fast-symeval vara))
  1274.         (setq b (fast-symeval varb))
  1275.         (cond ((and (numberp a) (numberp b)) (eval-nodelist outs))
  1276.               ((and (not (numberp a)) (not (numberp b)))
  1277.                (eval-nodelist outs)))))
  1278.  
  1279. (defun tlts (outs vara varb)
  1280.   (prog (a b)
  1281.         (setq a (fast-symeval vara))
  1282.         (setq b (fast-symeval varb))
  1283.         (and (numberp a)
  1284.              (numberp b)
  1285.              (greaterp b a)
  1286.              (eval-nodelist outs))))
  1287.  
  1288. (defun tgts (outs vara varb)
  1289.   (prog (a b)
  1290.         (setq a (fast-symeval vara))
  1291.         (setq b (fast-symeval varb))
  1292.         (and (numberp a)
  1293.              (numberp b)
  1294.              (greaterp a b)
  1295.              (eval-nodelist outs))))
  1296.  
  1297. (defun tges (outs vara varb)
  1298.   (prog (a b)
  1299.         (setq a (fast-symeval vara))
  1300.         (setq b (fast-symeval varb))
  1301.         (and (numberp a)
  1302.              (numberp b)
  1303.              (not (greaterp b a))
  1304.              (eval-nodelist outs))))
  1305.  
  1306. (defun tles (outs vara varb)
  1307.   (prog (a b)
  1308.         (setq a (fast-symeval vara))
  1309.         (setq b (fast-symeval varb))
  1310.         (and (numberp a)
  1311.              (numberp b)
  1312.              (not (greaterp a b))
  1313.              (eval-nodelist outs))))
  1314.  
  1315. (defun &two (left-outs right-outs)
  1316.   (prog (fp dp)
  1317.         (cond (*sendtocall*
  1318.                (setq fp *flag-part*)
  1319.                (setq dp *data-part*))
  1320.               (t
  1321.                (setq fp *alpha-flag-part*)
  1322.                (setq dp *alpha-data-part*)))
  1323.         (sendto fp dp 'left left-outs)
  1324.         (sendto fp dp 'right right-outs)))
  1325.  
  1326. (defun &mem (left-outs right-outs memory-list)
  1327.   (prog (fp dp)
  1328.         (cond (*sendtocall*
  1329.                (setq fp *flag-part*)
  1330.                (setq dp *data-part*))
  1331.               (t
  1332.                (setq fp *alpha-flag-part*)
  1333.                (setq dp *alpha-data-part*)))
  1334.         (sendto fp dp 'left left-outs)
  1335.         (add-token memory-list fp dp nil)
  1336.         (sendto fp dp 'right right-outs)))
  1337.  
  1338. (defun &and (outs lpred rpred tests)
  1339.   (prog (mem)
  1340.         (cond ((eq *side* 'right) (setq mem (memory-part lpred)))
  1341.               (t (setq mem (memory-part rpred))))
  1342.         (cond ((not mem) (return nil))
  1343.               ((eq *side* 'right) (and-right outs mem tests))
  1344.               (t (and-left outs mem tests)))))
  1345.  
  1346. (defun and-left (outs mem tests)
  1347.   (prog (fp dp memdp tlist tst lind rind res)
  1348.         (setq fp *flag-part*)
  1349.         (setq dp *data-part*)
  1350.    fail (and (null mem) (return nil))
  1351.         (setq memdp (car mem))
  1352.         (setq mem (cdr mem))
  1353.         (setq tlist tests)
  1354.    tloop (and (null tlist) (go succ))
  1355.         (setq tst (car tlist))
  1356.         (setq tlist (cdr tlist))
  1357.         (setq lind (car tlist))
  1358.         (setq tlist (cdr tlist))
  1359.         (setq rind (car tlist))
  1360.         (setq tlist (cdr tlist))
  1361.         (comment the next line differs in and-left & -right)
  1362.         (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
  1363.         (cond (res (go tloop))
  1364.               (t (go fail)))
  1365.    succ (comment the next line differs in and-left & -right)
  1366.         (sendto fp (cons (car memdp) dp) 'left outs)
  1367.         (go fail)))
  1368.  
  1369. (defun and-right (outs mem tests)
  1370.   (prog (fp dp memdp tlist tst lind rind res)
  1371.         (setq fp *flag-part*)
  1372.         (setq dp *data-part*)
  1373.    fail (and (null mem) (return nil))
  1374.         (setq memdp (car mem))
  1375.         (setq mem (cdr mem))
  1376.         (setq tlist tests)
  1377.    tloop (and (null tlist) (go succ))
  1378.         (setq tst (car tlist))
  1379.         (setq tlist (cdr tlist))
  1380.         (setq lind (car tlist))
  1381.         (setq tlist (cdr tlist))
  1382.         (setq rind (car tlist))
  1383.         (setq tlist (cdr tlist))
  1384.         (comment the next line differs in and-left & -right)
  1385.         (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
  1386.         (cond (res (go tloop))
  1387.               (t (go fail)))
  1388.    succ (comment the next line differs in and-left & -right)
  1389.         (sendto fp (cons (car dp) memdp) 'right outs)
  1390.         (go fail)))
  1391.  
  1392.  
  1393. (defun teqb (new eqvar)
  1394.   (cond ((eq new eqvar) t)
  1395.         ((not (numberp new)) nil)
  1396.         ((not (numberp eqvar)) nil)
  1397.         ((=alg new eqvar) t)
  1398.         (t nil)))
  1399.  
  1400. (defun tneb (new eqvar)
  1401.   (cond ((eq new eqvar) nil)
  1402.         ((not (numberp new)) t)
  1403.         ((not (numberp eqvar)) t)
  1404.         ((=alg new eqvar) nil)
  1405.         (t t)))
  1406.  
  1407. (defun tltb (new eqvar)
  1408.   (cond ((not (numberp new)) nil)
  1409.         ((not (numberp eqvar)) nil)
  1410.         ((greaterp eqvar new) t)
  1411.         (t nil)))
  1412.  
  1413. (defun tgtb (new eqvar)
  1414.   (cond ((not (numberp new)) nil)
  1415.         ((not (numberp eqvar)) nil)
  1416.         ((greaterp new eqvar) t)
  1417.         (t nil)))
  1418.  
  1419. (defun tgeb (new eqvar)
  1420.   (cond ((not (numberp new)) nil)
  1421.         ((not (numberp eqvar)) nil)
  1422.         ((not (greaterp eqvar new)) t)
  1423.         (t nil)))
  1424.  
  1425. (defun tleb (new eqvar)
  1426.   (cond ((not (numberp new)) nil)
  1427.         ((not (numberp eqvar)) nil)
  1428.         ((not (greaterp new eqvar)) t)
  1429.         (t nil)))
  1430.  
  1431. (defun txxb (new eqvar)
  1432.   (cond ((numberp new)
  1433.          (cond ((numberp eqvar) t)
  1434.                (t nil)))
  1435.         (t
  1436.          (cond ((numberp eqvar) nil)
  1437.                (t t)))))
  1438.  
  1439.  
  1440. (defun &p (rating name var-dope ce-var-dope rhs)
  1441.   (prog (fp dp)
  1442.         (cond (*sendtocall*
  1443.                (setq fp *flag-part*)
  1444.                (setq dp *data-part*))
  1445.               (t
  1446.                (setq fp *alpha-flag-part*)
  1447.                (setq dp *alpha-data-part*)))
  1448.         (and (memq fp '(nil old)) (removecs name dp))
  1449.         (and fp (insertcs name dp rating))))
  1450.  
  1451. (defun &old (a b c d e) nil)
  1452.  
  1453. (defun ¬ (outs lmem rpred tests)
  1454.   (cond ((and (eq *side* 'right) (eq *flag-part* 'old)) nil)
  1455.         ((eq *side* 'right) (not-right outs (car lmem) tests))
  1456.         (t (not-left outs (memory-part rpred) tests lmem))))
  1457.  
  1458. (defun not-left (outs mem tests own-mem)
  1459.   (prog (fp dp memdp tlist tst lind rind res c)
  1460.         (setq fp *flag-part*)
  1461.         (setq dp *data-part*)
  1462.         (setq c 0.)
  1463.    fail (and (null mem) (go fin))
  1464.         (setq memdp (car mem))
  1465.         (setq mem (cdr mem))
  1466.         (setq tlist tests)
  1467.    tloop (and (null tlist) (setq c (1+ c)) (go fail))
  1468.         (setq tst (car tlist))
  1469.         (setq tlist (cdr tlist))
  1470.         (setq lind (car tlist))
  1471.         (setq tlist (cdr tlist))
  1472.         (setq rind (car tlist))
  1473.         (setq tlist (cdr tlist))
  1474.         (comment the next line differs in not-left & -right)
  1475.         (setq res (funcall tst (gelm memdp rind) (gelm dp lind)))
  1476.         (cond (res (go tloop))
  1477.               (t (go fail)))
  1478.    fin  (add-token own-mem fp dp c)
  1479.         (and (== c 0.) (sendto fp dp 'left outs))))
  1480.  
  1481. (defun not-right (outs mem tests)
  1482.   (prog (fp dp memdp tlist tst lind rind res newfp inc newc)
  1483.         (setq fp *flag-part*)
  1484.         (setq dp *data-part*)
  1485.         (cond ((not fp) (setq inc -1.) (setq newfp 'new))
  1486.               ((eq fp 'new) (setq inc 1.) (setq newfp nil))
  1487.               (t (return nil)))
  1488.    fail (and (null mem) (return nil))
  1489.         (setq memdp (car mem))
  1490.         (setq newc (cadr mem))
  1491.         (setq tlist tests)
  1492.    tloop (and (null tlist) (go succ))
  1493.         (setq tst (car tlist))
  1494.         (setq tlist (cdr tlist))
  1495.         (setq lind (car tlist))
  1496.         (setq tlist (cdr tlist))
  1497.         (setq rind (car tlist))
  1498.         (setq tlist (cdr tlist))
  1499.         (comment the next line differs in not-left & -right)
  1500.         (setq res (funcall tst (gelm dp rind) (gelm memdp lind)))
  1501.         (cond (res (go tloop))
  1502.               (t (setq mem (cddr mem)) (go fail)))
  1503.    succ (setq newc (+ inc newc))
  1504.         (rplaca (cdr mem) newc)
  1505.         (cond ((or (and (== inc -1.) (== newc 0.))
  1506.                    (and (== inc 1.) (== newc 1.)))
  1507.                (sendto newfp memdp 'right outs)))
  1508.         (setq mem (cddr mem))
  1509.         (go fail)))
  1510.  
  1511.  
  1512.  
  1513. ;;; Node memories
  1514.  
  1515.  
  1516. (defun add-token (memlis flag data-part num)
  1517.   (prog (was-present)
  1518.         (cond ((eq flag 'new)
  1519.                (setq was-present nil)
  1520.                (real-add-token memlis data-part num))
  1521.               ((not flag)
  1522.            (setq was-present (remove-old memlis data-part num)))
  1523.               ((eq flag 'old) (setq was-present t)))
  1524.         (return was-present)))
  1525.  
  1526. (defun real-add-token (lis data-part num)
  1527.   (setq *current-token* (1+ *current-token*))
  1528.   (cond (num (rplaca lis (cons num (car lis)))))
  1529.   (rplaca lis (cons data-part (car lis))))
  1530.  
  1531. (defun remove-old (lis data num)
  1532.   (cond (num (remove-old-num lis data))
  1533.         (t (remove-old-no-num lis data))))
  1534.  
  1535. (defun remove-old-num (lis data)
  1536.   (prog (m next last)
  1537.         (setq m (car lis))
  1538.         (cond ((atom m) (return nil))
  1539.               ((top-levels-eq data (car m))
  1540.                (setq *current-token* (1- *current-token*))
  1541.                (rplaca lis (cddr m))
  1542.                (return (car m))))
  1543.         (setq next m)
  1544.    loop (setq last next)
  1545.         (setq next (cddr next))
  1546.         (cond ((atom next) (return nil))
  1547.               ((top-levels-eq data (car next))
  1548.                (rplacd (cdr last) (cddr next))
  1549.                (setq *current-token* (1- *current-token*))
  1550.                (return (car next)))
  1551.               (t (go loop)))))
  1552.  
  1553. (defun remove-old-no-num (lis data)
  1554.   (prog (m next last)
  1555.         (setq m (car lis))
  1556.         (cond ((atom m) (return nil))
  1557.               ((top-levels-eq data (car m))
  1558.                (setq *current-token* (1- *current-token*))
  1559.                (rplaca lis (cdr m))
  1560.                (return (car m))))
  1561.         (setq next m)
  1562.    loop (setq last next)
  1563.         (setq next (cdr next))
  1564.         (cond ((atom next) (return nil))
  1565.               ((top-levels-eq data (car next))
  1566.                (rplacd last (cdr next))
  1567.                (setq *current-token* (1- *current-token*))
  1568.                (return (car next)))
  1569.               (t (go loop)))))
  1570.  
  1571.  
  1572.  
  1573. ;;; Conflict Resolution
  1574. ;
  1575. ;
  1576. ; each conflict set element is a list of the following form:
  1577. ; ((p-name . data-part) (sorted wm-recency) special-case-number)
  1578.  
  1579. (defun removecs (name data)
  1580.   (prog (cr-data inst cs)
  1581.         (setq cr-data (cons name data))
  1582.     (setq cs *conflict-set*)
  1583.   l:    (cond ((null cs)
  1584.                (record-refract name data)
  1585.                (return nil)))
  1586.     (setq inst (car cs))
  1587.     (setq cs (cdr cs))
  1588.     (and (not (top-levels-eq (car inst) cr-data)) (go l:))
  1589.         (setq *conflict-set* (delq inst *conflict-set*))))
  1590.  
  1591. (defun insertcs (name data rating)
  1592.   (prog (instan)
  1593.     (and (refracted name data) (return nil))
  1594.     (setq instan (list (cons name data) (order-tags data) rating))
  1595.     (and (atom *conflict-set*) (setq *conflict-set* nil))
  1596.     (return (setq *conflict-set* (cons instan *conflict-set*)))))
  1597.  
  1598. (defun order-tags (dat)
  1599.   (prog (tags)
  1600.         (setq tags nil)
  1601.    l1:  (and (atom dat) (go l2:))
  1602.         (setq tags (cons (creation-time (car dat)) tags))
  1603.         (setq dat (cdr dat))
  1604.         (go l1:)
  1605.    l2:  (cond ((eq *strategy* 'mea)
  1606.                (return (cons (car tags) (dsort (cdr tags)))))
  1607.               (t (return (dsort tags))))))
  1608.  
  1609. ; destructively sort x into descending order
  1610.  
  1611. (defun dsort (x)
  1612.   (prog (sorted cur next cval nval)
  1613.         (and (atom (cdr x)) (return x))
  1614.    loop (setq sorted t)
  1615.         (setq cur x)
  1616.         (setq next (cdr x))
  1617.    chek (setq cval (car cur))
  1618.         (setq nval (car next))
  1619.         (cond ((> nval cval)
  1620.                (setq sorted nil)
  1621.                (rplaca cur nval)
  1622.                (rplaca next cval)))
  1623.         (setq cur next)
  1624.         (setq next (cdr cur))
  1625.         (cond ((not (null next)) (go chek))
  1626.               (sorted (return x))
  1627.               (t (go loop)))))
  1628.  
  1629. (defun conflict-resolution nil
  1630.   (prog (best len)
  1631.         (setq len (length *conflict-set*))
  1632.         (cond ((> len *max-cs*) (setq *max-cs* len)))
  1633.         (setq *total-cs* (+ *total-cs* len))
  1634.         (cond (*conflict-set*
  1635.                (setq best (best-of *conflict-set*))
  1636.                (setq *conflict-set* (delq best *conflict-set*))
  1637.                (return (pname-instantiation best)))
  1638.               (t (return nil)))))
  1639.  
  1640. (defun best-of (set) (best-of* (car set) (cdr set)))
  1641.  
  1642. (defun best-of* (best rem)
  1643.   (cond ((not rem) best)
  1644.         ((conflict-set-compare best (car rem))
  1645.          (best-of* best (cdr rem)))
  1646.         (t (best-of* (car rem) (cdr rem)))))
  1647.  
  1648. (defun remove-from-conflict-set (name)
  1649.   (prog (cs entry)
  1650.    l1   (setq cs *conflict-set*)
  1651.    l2   (cond ((atom cs) (return nil)))
  1652.         (setq entry (car cs))
  1653.         (setq cs (cdr cs))
  1654.         (cond ((eq name (caar entry))
  1655.                (setq *conflict-set* (delq entry *conflict-set*))
  1656.                (go l1))
  1657.               (t (go l2)))))
  1658.  
  1659. (defun pname-instantiation (conflict-elem) (car conflict-elem))
  1660.  
  1661. (defun order-part (conflict-elem) (cdr conflict-elem))
  1662.  
  1663. (defun instantiation (conflict-elem)
  1664.   (cdr (pname-instantiation conflict-elem)))
  1665.  
  1666.  
  1667. (defun conflict-set-compare (x y)
  1668.   (prog (x-order y-order xl yl xv yv)
  1669.         (setq x-order (order-part x))
  1670.         (setq y-order (order-part y))
  1671.         (setq xl (car x-order))
  1672.         (setq yl (car y-order))
  1673.    data (cond ((and (null xl) (null yl)) (go ps))
  1674.               ((null yl) (return t))
  1675.               ((null xl) (return nil)))
  1676.         (setq xv (car xl))
  1677.         (setq yv (car yl))
  1678.         (cond ((> xv yv) (return t))
  1679.               ((> yv xv) (return nil)))
  1680.         (setq xl (cdr xl))
  1681.         (setq yl (cdr yl))
  1682.         (go data)
  1683.    ps   (setq xl (cdr x-order))
  1684.         (setq yl (cdr y-order))
  1685.    psl  (cond ((null xl) (return t)))
  1686.         (setq xv (car xl))
  1687.         (setq yv (car yl))
  1688.         (cond ((> xv yv) (return t))
  1689.               ((> yv xv) (return nil)))
  1690.         (setq xl (cdr xl))
  1691.         (setq yl (cdr yl))
  1692.         (go psl)))
  1693.  
  1694.  
  1695. (defun conflict-set nil
  1696.   (prog (cnts cs p z best)
  1697.         (setq cnts nil)
  1698.         (setq cs *conflict-set*)
  1699.    l1:  (and (atom cs) (go l2:))
  1700.         (setq p (caaar cs))
  1701.         (setq cs (cdr cs))
  1702.         (setq z (assq p cnts))
  1703.         (cond ((null z) (setq cnts (cons (cons p 1.) cnts)))
  1704.               (t (rplacd z (1+ (cdr z)))))
  1705.         (go l1:)
  1706.    l2:  (cond ((atom cnts)
  1707.                (setq best (best-of *conflict-set*))
  1708.                (terpri)
  1709.                (return (list (caar best) 'dominates))))
  1710.         (terpri)
  1711.         (princ (caar cnts))
  1712.         (cond ((> (cdar cnts) 1.)
  1713.                (princ '|    (|)
  1714.                (princ (cdar cnts))
  1715.                (princ '| occurrences)|)))
  1716.         (setq cnts (cdr cnts))
  1717.         (go l2:)))
  1718.     
  1719.  
  1720.  
  1721. ;;; WM maintaining functions
  1722. ;
  1723. ; The order of operations in the following two functions is critical.
  1724. ; add-to-wm order: (1) change wm (2) record change (3) match
  1725. ; remove-from-wm order: (1) record change (2) match (3) change wm
  1726. ; (back will not restore state properly unless wm changes are recorded
  1727. ; before the cs changes that they cause)  (match will give errors if
  1728. ; the thing matched is not in wm at the time)
  1729.  
  1730.  
  1731. (defun add-to-wm (wme override)
  1732.   (prog (fa z part timetag port)
  1733.     (setq *critical* t)
  1734.     (setq *current-wm* (1+ *current-wm*))
  1735.     (and (> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))
  1736.     (setq *action-count* (1+ *action-count*))
  1737.     (setq fa (wm-hash wme))
  1738.     (or (memq fa *wmpart-list*)
  1739.         (setq *wmpart-list* (cons fa *wmpart-list*)))
  1740.     (setq part (get fa 'wmpart*))
  1741.     (cond (override (setq timetag override))
  1742.           (t (setq timetag *action-count*)))
  1743.     (setq z (cons wme timetag))
  1744.     (putprop fa (cons z part) 'wmpart*)
  1745.     (record-change '=>wm *action-count* wme)
  1746.     (match 'new wme)
  1747.     (setq *critical* nil)
  1748.     (cond ((and *in-rhs* *wtrace*)
  1749.            (setq port (trace-file))
  1750.            (terpri port)
  1751.            (princ '|=>wm: | port)
  1752.            (ppelm wme port)))))
  1753.  
  1754. ; remove-from-wm uses eq, not equal to determine if wme is present
  1755.  
  1756. (defun remove-from-wm (wme)
  1757.   (prog (fa z part timetag port)
  1758.     (setq fa (wm-hash wme))
  1759.     (setq part (get fa 'wmpart*))
  1760.     (setq z (assq wme part))
  1761.     (or z (return nil))
  1762.     (setq timetag (cdr z))
  1763.     (cond ((and *wtrace* *in-rhs*)
  1764.            (setq port (trace-file))
  1765.            (terpri port)
  1766.            (princ '|<=wm: | port)
  1767.            (ppelm wme port)))
  1768.     (setq *action-count* (1+ *action-count*))
  1769.     (setq *critical* t)
  1770.     (setq *current-wm* (1- *current-wm*))
  1771.     (record-change '<=wm timetag wme)
  1772.     (match nil wme)
  1773.     (putprop fa (delq z part) 'wmpart*)
  1774.     (setq *critical* nil)))
  1775.  
  1776. ; mapwm maps down the elements of wm, applying fn to each element
  1777. ; each element is of form (datum . creation-time)
  1778.  
  1779. (defun mapwm (fn)
  1780.   (prog (wmpl part)
  1781.         (setq wmpl *wmpart-list*)
  1782.    lab1 (cond ((atom wmpl) (return nil)))
  1783.         (setq part (get (car wmpl) 'wmpart*))
  1784.         (setq wmpl (cdr wmpl))
  1785.         (mapc fn part)
  1786.         (go lab1)))
  1787.  
  1788. (defun wm fexpr (a)
  1789.   (mapc (function (lambda (z) (terpri) (ppelm z t)))
  1790.     (get-wm a))
  1791.   nil)
  1792.  
  1793. (defun get-wm (z)
  1794.   (setq *wm-filter* z)
  1795.   (setq *wm* nil)
  1796.   (mapwm (function get-wm2))
  1797.   (prog2 nil *wm* (setq *wm* nil)))
  1798.  
  1799. (defun get-wm2 (elem)
  1800.  (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*))
  1801.     (setq *wm* (cons (car elem) *wm*)))))))
  1802.  
  1803. (defun wm-hash (x)
  1804.   (cond ((not x) '<default>)
  1805.         ((not (car x)) (wm-hash (cdr x)))
  1806.         ((symbolp (car x)) (car x))
  1807.         (t (wm-hash (cdr x)))))
  1808.  
  1809. (defun creation-time (wme)
  1810.   (cdr (assq wme (get (wm-hash wme) 'wmpart*))))
  1811.  
  1812. (defun refresh nil
  1813.   (prog nil
  1814.     (setq *old-wm* nil)
  1815.     (mapwm (function refresh-collect))
  1816.     (mapc (function refresh-del) *old-wm*)
  1817.     (mapc (function refresh-add) *old-wm*)
  1818.     (setq *old-wm* nil)))
  1819.  
  1820. (defun refresh-collect (x) (setq *old-wm* (cons x *old-wm*)))
  1821.  
  1822. (defun refresh-del (x) (remove-from-wm (car x)))
  1823.  
  1824. (defun refresh-add (x) (add-to-wm (car x) (cdr x)))
  1825.  
  1826. (defun trace-file ()
  1827.   (prog (port)
  1828.         (setq port t)
  1829.     (cond (*trace-file*
  1830.            (setq port ($ofile *trace-file*))
  1831.            (cond ((null port)
  1832.                   (%warn '|trace: file has been closed| *trace-file*)
  1833.               (setq port t)))))
  1834.         (return port)))
  1835.  
  1836.  
  1837. ;;; Basic functions for RHS evaluation
  1838.  
  1839. (defun eval-rhs (pname data)
  1840.   (prog (node port)
  1841.     (cond (*ptrace*
  1842.            (setq port (trace-file))
  1843.            (terpri port)
  1844.            (princ *cycle-count* port)
  1845.            (princ '|. | port)
  1846.            (princ pname port)
  1847.            (time-tag-print data port)))
  1848.     (setq *data-matched* data)
  1849.     (setq *p-name* pname)
  1850.     (setq *last* nil)
  1851.     (setq node (get pname 'topnode))
  1852.     (init-var-mem (var-part node))
  1853.     (init-ce-var-mem (ce-var-part node))
  1854.     (begin-record pname data)
  1855.     (setq *in-rhs* t)
  1856.     (eval (rhs-part node))
  1857.     (setq *in-rhs* nil)
  1858.     (end-record)))
  1859.  
  1860. (defun time-tag-print (data port)
  1861.   (cond ((not (null data))
  1862.          (time-tag-print (cdr data) port)
  1863.          (princ '| | port)
  1864.          (princ (creation-time (car data)) port))))
  1865.  
  1866. (defun init-var-mem (vlist)
  1867.   (prog (v ind r)
  1868.         (setq *variable-memory* nil)
  1869.    top  (and (atom vlist) (return nil))
  1870.         (setq v (car vlist))
  1871.         (setq ind (cadr vlist))
  1872.         (setq vlist (cddr vlist))
  1873.         (setq r (gelm *data-matched* ind))
  1874.         (setq *variable-memory* (cons (cons v r) *variable-memory*))
  1875.         (go top)))
  1876.  
  1877. (defun init-ce-var-mem (vlist)
  1878.   (prog (v ind r)
  1879.         (setq *ce-variable-memory* nil)
  1880.    top  (and (atom vlist) (return nil))
  1881.         (setq v (car vlist))
  1882.         (setq ind (cadr vlist))
  1883.         (setq vlist (cddr vlist))
  1884.         (setq r (ce-gelm *data-matched* ind))
  1885.         (setq *ce-variable-memory*
  1886.               (cons (cons v r) *ce-variable-memory*))
  1887.         (go top)))
  1888.  
  1889. (defun make-ce-var-bind (var elem)
  1890.   (setq *ce-variable-memory*
  1891.         (cons (cons var elem) *ce-variable-memory*)))
  1892.  
  1893. (defun make-var-bind (var elem)
  1894.   (setq *variable-memory* (cons (cons var elem) *variable-memory*)))
  1895.  
  1896. (defun $varbind (x)
  1897.   (prog (r)
  1898.     (and (not *in-rhs*) (return x))
  1899.         (setq r (assq x *variable-memory*))
  1900.         (cond (r (return (cdr r)))
  1901.               (t (return x)))))
  1902.  
  1903. (defun get-ce-var-bind (x)
  1904.   (prog (r)
  1905.         (cond ((numberp x) (return (get-num-ce x))))
  1906.         (setq r (assq x *ce-variable-memory*))
  1907.         (cond (r (return (cdr r)))
  1908.               (t (return nil)))))
  1909.  
  1910. (defun get-num-ce (x)
  1911.   (prog (r l d)
  1912.         (setq r *data-matched*)
  1913.         (setq l (length r))
  1914.         (setq d (- l x))
  1915.         (and (> 0. d) (return nil))
  1916.    la   (cond ((null r) (return nil))
  1917.               ((> 1. d) (return (car r))))
  1918.         (setq d (1- d))
  1919.         (setq r (cdr r))
  1920.         (go la)))
  1921.  
  1922.  
  1923. (defun build-collect (z)
  1924.   (prog (r)
  1925.    la   (and (atom z) (return nil))
  1926.         (setq r (car z))
  1927.         (setq z (cdr z))
  1928.         (cond ((dtpr r)
  1929.                ($value '/()
  1930.                (build-collect r)
  1931.                ($value '/)))
  1932.               ((eq r '\\) ($change (car z)) (setq z (cdr z)))
  1933.               (t ($value r)))
  1934.         (go la)))
  1935.  
  1936. (defun unflat (x) (setq *rest* x) (unflat*))
  1937.  
  1938. (defun unflat* nil
  1939.   (prog (c)
  1940.         (cond ((atom *rest*) (return nil)))
  1941.         (setq c (car *rest*))
  1942.         (setq *rest* (cdr *rest*))
  1943.         (cond ((eq c '/() (return (cons (unflat*) (unflat*))))
  1944.               ((eq c '/)) (return nil))
  1945.               (t (return (cons c (unflat*)))))))
  1946.  
  1947.  
  1948. (defun $change (x)
  1949.   (prog nil
  1950.         (cond ((dtpr x) (eval-function x))
  1951.               (t ($value ($varbind x))))))
  1952.  
  1953. (defun eval-args (z)
  1954.   (prog (r)
  1955.         (rhs-tab 1.)
  1956.    la   (and (atom z) (return nil))
  1957.         (setq r (car z))
  1958.         (setq z (cdr z))
  1959.         (cond ((eq r '^)
  1960.                (rhs-tab (car z))
  1961.                (setq r (cadr z))
  1962.                (setq z (cddr z))))
  1963.         (cond ((eq r '//) ($value (car z)) (setq z (cdr z)))
  1964.               (t ($change r)))
  1965.         (go la)))
  1966.  
  1967.  
  1968. (defun eval-function (form)
  1969.   (cond ((not *in-rhs*)
  1970.      (%warn '|functions cannot be used at top level| (car form)))
  1971.     (t (eval form))))
  1972.  
  1973.  
  1974. ;;; Functions to manipulate the result array
  1975.  
  1976.  
  1977. (defun $reset nil
  1978.   (setq *max-index* 0.)
  1979.   (setq *next-index* 1.))
  1980.  
  1981. ; rhs-tab implements the tab ('^') function in the rhs.  it has
  1982. ; four responsibilities:
  1983. ;    - to move the array pointers
  1984. ;    - to watch for tabbing off the left end of the array
  1985. ;      (ie, to watch for pointers less than 1)
  1986. ;    - to watch for tabbing off the right end of the array
  1987. ;    - to write nil in all the slots that are skipped
  1988. ; the last is necessary if the result array is not to be cleared
  1989. ; after each use; if rhs-tab did not do this, $reset
  1990. ; would be much slower.
  1991.  
  1992. (defun rhs-tab (z) ($tab ($varbind z)))
  1993.  
  1994. (defun $tab (z)
  1995.   (prog (edge next)
  1996.         (setq next ($litbind z))
  1997.         (and (floatp next) (setq next (fix next)))
  1998.         (cond ((or (not (numberp next))
  1999.            (> next *size-result-array*)
  2000.            (> 1. next))
  2001.                (%warn '|illegal index after ^| next)
  2002.                (return *next-index*)))
  2003.         (setq edge (- next 1.))
  2004.         (cond ((> *max-index* edge) (go ok)))
  2005.    clear (cond ((== *max-index* edge) (go ok)))
  2006.         (putvector *result-array* edge nil)
  2007.         (setq edge (1- edge))
  2008.         (go clear)
  2009.    ok   (setq *next-index* next)
  2010.         (return next)))
  2011.  
  2012. (defun $value (v)
  2013.   (cond ((> *next-index* *size-result-array*)
  2014.          (%warn '|index too large| *next-index*))
  2015.         (t
  2016.          (and (> *next-index* *max-index*)
  2017.               (setq *max-index* *next-index*))
  2018.          (putvector *result-array* *next-index* v)
  2019.          (setq *next-index* (1+ *next-index*)))))
  2020.  
  2021. (defun use-result-array nil
  2022.   (prog (k r)
  2023.         (setq k *max-index*)
  2024.         (setq r nil)
  2025.    top  (and (== k 0.) (return r))
  2026.         (setq r (cons (getvector *result-array* k) r))
  2027.         (setq k (1- k))
  2028.         (go top)))
  2029.  
  2030. (defun $assert nil
  2031.   (setq *last* (use-result-array))
  2032.   (add-to-wm *last* nil))
  2033.  
  2034. (defun $parametercount nil *max-index*)
  2035.  
  2036. (defun $parameter (k)
  2037.   (cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.))
  2038.      (%warn '|illegal parameter number | k)
  2039.          nil)
  2040.         ((> k *max-index*) nil)
  2041.     (t (getvector *result-array* k))))
  2042.  
  2043.  
  2044. ;;; RHS actions
  2045.  
  2046. (defun make fexpr (z)
  2047.   (prog nil
  2048.         ($reset)
  2049.         (eval-args z)
  2050.         ($assert)))
  2051.  
  2052. (defun modify fexpr (z)
  2053.   (prog (old)
  2054.     (cond ((not *in-rhs*)
  2055.            (%warn '|cannot be called at top level| 'modify)
  2056.            (return nil)))
  2057.         (setq old (get-ce-var-bind (car z)))
  2058.         (cond ((null old)
  2059.                (%warn '|modify: first argument must be an element variable|
  2060.                         (car z))
  2061.                (return nil)))
  2062.         (remove-from-wm old)
  2063.         (setq z (cdr z))
  2064.         ($reset)
  2065.    copy (and (atom old) (go fin))
  2066.         ($change (car old))
  2067.         (setq old (cdr old))
  2068.         (go copy)
  2069.    fin  (eval-args z)
  2070.         ($assert)))
  2071.  
  2072. (defun bind fexpr (z)
  2073.   (prog (val)
  2074.     (cond ((not *in-rhs*)
  2075.            (%warn '|cannot be called at top level| 'bind)
  2076.            (return nil)))
  2077.     (cond ((< (length z) 1.)
  2078.            (%warn '|bind: wrong number of arguments to| z)
  2079.            (return nil))
  2080.           ((not (symbolp (car z)))
  2081.            (%warn '|bind: illegal argument| (car z))
  2082.            (return nil))
  2083.           ((= (length z) 1.) (setq val (gensym)))
  2084.           (t ($reset)
  2085.              (eval-args (cdr z))
  2086.              (setq val ($parameter 1.))))
  2087.     (make-var-bind (car z) val)))
  2088.  
  2089. (defun cbind fexpr (z)
  2090.   (cond ((not *in-rhs*)
  2091.      (%warn '|cannot be called at top level| 'cbind))
  2092.     ((not (= (length z) 1.))
  2093.      (%warn '|cbind: wrong number of arguments| z))
  2094.     ((not (symbolp (car z)))
  2095.      (%warn '|cbind: illegal argument| (car z)))
  2096.     ((null *last*)
  2097.      (%warn '|cbind: nothing added yet| (car z)))
  2098.     (t (make-ce-var-bind (car z) *last*))))
  2099.  
  2100. (defun remove fexpr (z)
  2101.   (prog (old)
  2102.     (and (not *in-rhs*)(return (top-level-remove z)))
  2103.    top  (and (atom z) (return nil))
  2104.         (setq old (get-ce-var-bind (car z)))
  2105.         (cond ((null old)
  2106.                (%warn '|remove: argument not an element variable| (car z))
  2107.                (return nil)))
  2108.         (remove-from-wm old)
  2109.         (setq z (cdr z))
  2110.         (go top)))
  2111.  
  2112. (defun call fexpr (z)
  2113.   (prog (f)
  2114.     (setq f (car z))
  2115.         ($reset)
  2116.         (eval-args (cdr z))
  2117.         (funcall f)))
  2118.  
  2119. (defun write fexpr (z)
  2120.   (prog (port max k x needspace)
  2121.     (cond ((not *in-rhs*)
  2122.            (%warn '|cannot be called at top level| 'write)
  2123.            (return nil)))
  2124.     ($reset)
  2125.     (eval-args z)
  2126.     (setq k 1.)
  2127.     (setq max ($parametercount))
  2128.     (cond ((< max 1.)
  2129.            (%warn '|write: nothing to print| z)
  2130.            (return nil)))
  2131.     (setq port (default-write-file))
  2132.     (setq x ($parameter 1.))
  2133.     (cond ((and (symbolp x) ($ofile x))
  2134.            (setq port ($ofile x))
  2135.            (setq k 2.)))
  2136.         (setq needspace t)
  2137.    la   (and (> k max) (return nil))
  2138.     (setq x ($parameter k))
  2139.     (cond ((eq x '|=== C R L F ===|)
  2140.            (setq needspace nil)
  2141.                (terpri port))
  2142.               ((eq x '|=== R J U S T ===|)
  2143.            (setq k (+ 2 k))
  2144.            (do-rjust ($parameter (1- k)) ($parameter k) port))
  2145.           ((eq x '|=== T A B T O ===|)
  2146.            (setq needspace nil)
  2147.            (setq k (1+ k))
  2148.            (do-tabto ($parameter k) port))
  2149.           (t
  2150.            (and needspace (princ '| | port))
  2151.            (setq needspace t)
  2152.            (princ x port)))
  2153.     (setq k (1+ k))
  2154.     (go la)))
  2155.     
  2156. (defun default-write-file ()
  2157.   (prog (port)
  2158.     (setq port t)
  2159.     (cond (*write-file*
  2160.            (setq port ($ofile *write-file*))
  2161.            (cond ((null port)
  2162.               (%warn '|write: file has been closed| *write-file*)
  2163.               (setq port t)))))
  2164.         (return port)))
  2165.  
  2166. (defun do-rjust (width value port)
  2167.   (prog (size)
  2168.     (cond ((eq value '|=== T A B T O ===|)
  2169.            (%warn '|rjust cannot precede this function| 'tabto)
  2170.                (return nil))
  2171.           ((eq value '|=== C R L F ===|)
  2172.            (%warn '|rjust cannot precede this function| 'crlf)
  2173.                (return nil))
  2174.           ((eq value '|=== R J U S T ===|)
  2175.            (%warn '|rjust cannot precede this function| 'rjust)
  2176.                (return nil)))
  2177.         (setq size (flatc value))
  2178.     (cond ((> size width)
  2179.            (princ '| | port)
  2180.            (princ value port)
  2181.            (return nil)))
  2182.         (do k (- width size) (1- k) (not (> k 0)) (princ '| | port))
  2183.     (princ value port)))
  2184.  
  2185. (defun do-tabto (col port)
  2186.   (prog (pos)
  2187.     (setq pos (1+ (nwritn port)))
  2188.     (cond ((> pos col)
  2189.            (terpri port)
  2190.            (setq pos 1)))
  2191.     (do k (- col pos) (1- k) (not (> k 0)) (princ '| | port))
  2192.     (return nil)))
  2193.  
  2194.  
  2195. (defun halt nil
  2196.   (cond ((not *in-rhs*)
  2197.      (%warn '|cannot be called at top level| 'halt))
  2198.     (t (setq *halt-flag* t))))
  2199.  
  2200. (defun build fexpr (z)
  2201.   (prog (r)
  2202.     (cond ((not *in-rhs*)
  2203.            (%warn '|cannot be called at top level| 'build)
  2204.            (return nil)))
  2205.         ($reset)
  2206.         (build-collect z)
  2207.         (setq r (unflat (use-result-array)))
  2208.         (and *build-trace* (funcall *build-trace* r))
  2209.         (compile-production (car r) (cdr r))))
  2210.  
  2211. (defun openfile fexpr (z)
  2212.   (prog (file mode id)
  2213.     ($reset)
  2214.     (eval-args z)
  2215.     (cond ((not (equal ($parametercount) 3.))
  2216.            (%warn '|openfile: wrong number of arguments| z)
  2217.            (return nil)))
  2218.     (setq id ($parameter 1))
  2219.     (setq file ($parameter 2))
  2220.     (setq mode ($parameter 3))
  2221.     (cond ((not (symbolp id))
  2222.            (%warn '|openfile: file id must be a symbolic atom| id)
  2223.            (return nil))
  2224.               ((null id)
  2225.                (%warn '|openfile: 'nil' is reserved for the terminal| nil)
  2226.                (return nil))
  2227.           ((or ($ifile id)($ofile id))
  2228.            (%warn '|openfile: name already in use| id)
  2229.            (return nil)))
  2230.     (cond ((eq mode 'in) (putprop id (infile file) 'inputfile))
  2231.           ((eq mode 'out) (putprop id (outfile file) 'outputfile))
  2232.           (t (%warn '|openfile: illegal mode| mode)
  2233.          (return nil)))
  2234.     (return nil)))
  2235.  
  2236. (defun $ifile (x)
  2237.   (cond ((symbolp x) (get x 'inputfile))
  2238.         (t nil)))
  2239.  
  2240. (defun $ofile (x)
  2241.   (cond ((symbolp x) (get x 'outputfile))
  2242.         (t nil)))
  2243.  
  2244.  
  2245. (defun closefile fexpr (z)
  2246.   ($reset)
  2247.   (eval-args z)
  2248.   (mapc (function closefile2) (use-result-array)))
  2249.  
  2250. (defun closefile2 (file)
  2251.   (prog (port)
  2252.     (cond ((not (symbolp file))
  2253.            (%warn '|closefile: illegal file identifier| file))
  2254.           ((setq port ($ifile file))
  2255.            (close port)
  2256.            (remprop file 'inputfile))
  2257.           ((setq port ($ofile file))
  2258.            (close port)
  2259.            (remprop file 'outputfile)))
  2260.     (return nil)))
  2261.  
  2262. (defun default fexpr (z)
  2263.   (prog (file use)
  2264.     ($reset)
  2265.     (eval-args z)
  2266.     (cond ((not (equal ($parametercount) 2.))
  2267.            (%warn '|default: wrong number of arguments| z)
  2268.            (return nil)))
  2269.     (setq file ($parameter 1))
  2270.     (setq use ($parameter 2))
  2271.     (cond ((not (symbolp file))
  2272.            (%warn '|default: illegal file identifier| file)
  2273.            (return nil))
  2274.           ((not (memq use '(write accept trace)))
  2275.            (%warn '|default: illegal use for a file| use)
  2276.            (return nil))
  2277.           ((and (memq use '(write trace))
  2278.             (not (null file))
  2279.             (not ($ofile file)))
  2280.            (%warn '|default: file has not been opened for output| file)
  2281.            (return nil))
  2282.           ((and (eq use 'accept)
  2283.             (not (null file))
  2284.             (not ($ifile file)))
  2285.            (%warn '|default: file has not been opened for input| file)
  2286.            (return nil))
  2287.           ((eq use 'write) (setq *write-file* file))
  2288.           ((eq use 'accept) (setq *accept-file* file))
  2289.           ((eq use 'trace) (setq *trace-file* file)))
  2290.     (return nil)))
  2291.  
  2292.  
  2293.  
  2294. ;;; RHS Functions
  2295.  
  2296. (defun accept fexpr (z)
  2297.   (prog (port arg peek)
  2298.     (cond ((> (length z) 1.)
  2299.            (%warn '|accept: wrong number of arguments| z)
  2300.            (return nil)))
  2301.     (setq port t)
  2302.     (cond (*accept-file*
  2303.            (setq port ($ifile *accept-file*))
  2304.            (cond ((null port)
  2305.               (%warn '|accept: file has been closed| *accept-file*)
  2306.               (return nil)))))
  2307.     (cond ((= (length z) 1)
  2308.            (setq arg ($varbind (car z)))
  2309.            (cond ((not (symbolp arg))
  2310.                   (%warn '|accept: illegal file name| arg)
  2311.               (return nil)))
  2312.            (setq port ($ifile arg))
  2313.            (cond ((null port)
  2314.               (%warn '|accept: file not open for input| arg)
  2315.               (return nil)))))
  2316.     (setq peek (check-for-eof port))
  2317.     (cond ((= peek -1.)
  2318.            ($value 'end-of-file)
  2319.            (return nil)))
  2320.     (flat-value (read port 'end-of-file))))
  2321.  
  2322. ; CHECK-FOR-EOF returns -1. if there is nothing interesting left in FILE
  2323. ; It returns some other fixnum otherwise.
  2324. ; It never returns -1. when file is the terminal
  2325.  
  2326. (defun check-for-eof (file)
  2327.   (cond ((eq file t) 0.)
  2328.     (t (tyipeek t file -1.)))))
  2329.  
  2330. (defun flat-value (x)
  2331.   (cond ((atom x) ($value x))
  2332.         (t (mapc (function flat-value) x))))
  2333.  
  2334. (defun span-chars (x prt)
  2335.   (do ch
  2336.       (tyipeek nil prt -1.)
  2337.       (tyipeek nil prt -1.)
  2338.       (not (member ch x))
  2339.       (readc prt)))
  2340.  
  2341. (defun acceptline fexpr (z)
  2342.   (prog (c def arg port)
  2343.     (setq port t)
  2344.     (setq def z)
  2345.     (cond (*accept-file*
  2346.            (setq port ($ifile *accept-file*))
  2347.            (cond ((null port)
  2348.               (%warn '|acceptline: file has been closed|
  2349.                      *accept-file*)
  2350.               (return nil)))))
  2351.     (cond ((> (length def) 0)
  2352.            (setq arg ($varbind (car def)))
  2353.            (cond ((and (symbolp arg) ($ifile arg))
  2354.                   (setq port ($ifile arg))
  2355.               (setq def (cdr def))))))
  2356.     (comment delete end of line if there from last time)
  2357.     (and (= (tyipeek nil port -1.) 13.) (setq c (tyi port -1.)))
  2358.     (and (= (tyipeek nil port -1.) 10.) (setq c (tyi port -1.)))
  2359.     (comment chop leading blanks etc and then look for end of line)
  2360.         (span-chars '(9. 32. 131.) port)
  2361.     (cond ((member (tyipeek nil port -1.) '(-1. 10. 13.))
  2362.            (mapc (function $change) def)
  2363.            (return nil)))
  2364.     (comment read a value from input line)
  2365.    l:    (flat-value (read port nil))
  2366.     (comment chop off ignore chars and look for end of line)
  2367.         (span-chars '(9. 32. 131.) port)
  2368.     (cond ((not (member (tyipeek nil port -1.) '(-1. 10. 13.)))
  2369.            (go l:)))))
  2370.  
  2371. (defun substr fexpr (l)
  2372.   (prog (k elm start end)
  2373.         (cond ((not (= (length l) 3.))
  2374.                (%warn '|substr: wrong number of arguments| l)
  2375.                (return nil)))
  2376.         (setq elm (get-ce-var-bind (car l)))
  2377.         (cond ((null elm)
  2378.                (%warn '|first argument to substr must be a ce var|
  2379.                         l)
  2380.                (return nil)))
  2381.         (setq start ($varbind (cadr l)))
  2382.     (setq start ($litbind start))
  2383.         (cond ((not (numberp start))
  2384.                (%warn '|second argument to substr must be a number|
  2385.                         l)
  2386.                (return nil)))
  2387.     (comment |if a variable is bound to INF, the following|
  2388.          |will get the binding and treat it as INF is|
  2389.          |always treated.  that may not be good|)
  2390.         (setq end ($varbind (caddr l)))
  2391.         (cond ((eq end 'inf) (setq end (length elm))))
  2392.     (setq end ($litbind end))
  2393.         (cond ((not (numberp end))
  2394.                (%warn '|third argument to substr must be a number|
  2395.                         l)
  2396.                (return nil)))
  2397.         (comment |this loop does not check for the end of elm|
  2398.                  |instead it relies on cdr of nil being nil|
  2399.                  |this may not work in all versions of lisp|)
  2400.         (setq k 1.)
  2401.    la   (cond ((> k end) (return nil))
  2402.               ((not (< k start)) ($value (car elm))))
  2403.         (setq elm (cdr elm))
  2404.         (setq k (1+ k))
  2405.         (go la)))
  2406.  
  2407.  
  2408. (defun compute fexpr (z) ($value (ari z)))
  2409.  
  2410. ; arith is the obsolete form of compute
  2411. (defun arith fexpr (z) ($value (ari z)))
  2412.  
  2413. (defun ari (x)
  2414.   (cond ((atom x)
  2415.          (%warn '|bad syntax in arithmetic expression | x)
  2416.      0.)
  2417.         ((atom (cdr x)) (ari-unit (car x)))
  2418.         ((eq (cadr x) '+)
  2419.          (plus (ari-unit (car x)) (ari (cddr x))))
  2420.         ((eq (cadr x) '-)
  2421.          (difference (ari-unit (car x)) (ari (cddr x))))
  2422.         ((eq (cadr x) '*)
  2423.          (times (ari-unit (car x)) (ari (cddr x))))
  2424.         ((eq (cadr x) '//)
  2425.          (quotient (ari-unit (car x)) (ari (cddr x))))
  2426.         ((eq (cadr x) '\\)
  2427.          (mod (fix (ari-unit (car x))) (fix (ari (cddr x)))))
  2428.         (t (%warn '|bad syntax in arithmetic expression | x) 0.)))
  2429.  
  2430. (defun ari-unit (a)
  2431.   (prog (r)
  2432.         (cond ((dtpr a) (setq r (ari a)))
  2433.               (t (setq r ($varbind a))))
  2434.         (cond ((not (numberp r))
  2435.                (%warn '|bad value in arithmetic expression| a)
  2436.                (return 0.))
  2437.               (t (return r)))))
  2438.  
  2439. (defun genatom nil ($value (gensym)))
  2440.  
  2441. (defun litval fexpr (z)
  2442.   (prog (r)
  2443.     (cond ((not (= (length z) 1.))
  2444.            (%warn '|litval: wrong number of arguments| z)
  2445.            ($value 0)
  2446.            (return nil))
  2447.           ((numberp (car z)) ($value (car z)) (return nil)))
  2448.     (setq r ($litbind ($varbind (car z))))
  2449.     (cond ((numberp r) ($value r) (return nil)))
  2450.     (%warn '|litval: argument has no literal binding| (car z))
  2451.     ($value 0)))
  2452.  
  2453.  
  2454. (defun rjust fexpr (z)
  2455.   (prog (val)
  2456.         (cond ((not (= (length z) 1.))
  2457.            (%warn '|rjust: wrong number of arguments| z)
  2458.                (return nil)))
  2459.         (setq val ($varbind (car z)))
  2460.     (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
  2461.            (%warn '|rjust: illegal value for field width| val)
  2462.            (return nil)))
  2463.         ($value '|=== R J U S T ===|)
  2464.     ($value val)))
  2465.  
  2466. (defun crlf fexpr (z)
  2467.         (cond  (z (%warn '|crlf: does not take arguments| z))
  2468.            (t ($value '|=== C R L F ===|))))
  2469.  
  2470. (defun tabto fexpr (z)
  2471.   (prog (val)
  2472.         (cond ((not (= (length z) 1.))
  2473.            (%warn '|tabto: wrong number of arguments| z)
  2474.            (return nil)))
  2475.         (setq val ($varbind (car z)))
  2476.     (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
  2477.            (%warn '|tabto: illegal column number| z)
  2478.            (return nil)))
  2479.         ($value '|=== T A B T O ===|)
  2480.     ($value val)))
  2481.  
  2482.  
  2483.  
  2484. ;;; Printing WM
  2485.  
  2486. (defun ppwm fexpr (avlist)
  2487.   (prog (next a)
  2488.         (setq *filters* nil)
  2489.         (setq next 1.)
  2490.    l:   (and (atom avlist) (go print))
  2491.         (setq a (car avlist))
  2492.         (setq avlist (cdr avlist))
  2493.         (cond ((eq a '^)
  2494.                (setq next (car avlist))
  2495.                (setq avlist (cdr avlist))
  2496.                (setq next ($litbind next))
  2497.                (and (floatp next) (setq next (fix next)))
  2498.                (cond ((or (not (numberp next))
  2499.                           (> next *size-result-array*)
  2500.                           (> 1. next))
  2501.                       (%warn '|illegal index after ^| next)
  2502.                       (return nil))))
  2503.               ((variablep a)
  2504.                (%warn '|ppwm does not take variables| a)
  2505.                (return nil))
  2506.               (t (setq *filters* (cons next (cons a *filters*)))
  2507.                  (setq next (1+ next))))
  2508.         (go l:)
  2509.    print (mapwm (function ppwm2))
  2510.         (terpri)
  2511.         (return nil)))
  2512.  
  2513. (defun ppwm2 (elm-tag)
  2514.   (cond ((filter (car elm-tag)) (terpri) (ppelm (car elm-tag) t))))
  2515.  
  2516. (defun filter (elm)
  2517.   (prog (fl indx val)
  2518.         (setq fl *filters*)
  2519.    top  (and (atom fl) (return t))
  2520.         (setq indx (car fl))
  2521.         (setq val (cadr fl))
  2522.         (setq fl (cddr fl))
  2523.         (and (ident (nth (1- indx) elm) val) (go top))
  2524.         (return nil)))
  2525.  
  2526. (defun ident (x y)
  2527.   (cond ((eq x y) t)
  2528.         ((not (numberp x)) nil)
  2529.         ((not (numberp y)) nil)
  2530.         ((=alg x y) t)
  2531.         (t nil)))
  2532.  
  2533. ; the new ppelm is designed especially to handle literalize format
  2534. ; however, it will do as well as the old ppelm on other formats
  2535.  
  2536. (defun ppelm (elm port)
  2537.   (prog (ppdat sep val att mode lastpos)
  2538.     (princ (creation-time elm) port)
  2539.     (princ '|:  | port)
  2540.         (setq mode 'vector)
  2541.     (setq ppdat (get (car elm) 'ppdat))
  2542.     (and ppdat (setq mode 'a-v))
  2543.     (setq sep '|(|)
  2544.         (setq lastpos 0)
  2545.     (do
  2546.      ((curpos 1 (1+ curpos)) (vlist elm (cdr vlist)))
  2547.      ((atom vlist) nil)
  2548.      (setq val (car vlist))
  2549.      (setq att (assoc curpos ppdat))
  2550.      (cond (att (setq att (cdr att)))
  2551.            (t (setq att curpos)))
  2552.          (and (symbolp att) (is-vector-attribute att) (setq mode 'vector))
  2553.      (cond ((or (not (null val)) (eq mode 'vector))
  2554.         (princ sep port)
  2555.         (ppval val att lastpos port)
  2556.         (setq sep '|    |)
  2557.         (setq lastpos curpos))))
  2558.     (princ '|)| port)))
  2559.  
  2560. (defun ppval (val att lastpos port)
  2561.   (cond ((not (equal att (1+ lastpos)))
  2562.          (princ '^ port)
  2563.          (princ att port)
  2564.          (princ '| | port)))
  2565.   (princ val port))
  2566.  
  2567.  
  2568.  
  2569. ;;; printing production memory
  2570.  
  2571. (defun pm fexpr (z) (mapc (function pprule) z) (terpri) nil)
  2572.  
  2573. (defun pprule (name)
  2574.   (prog (matrix next lab)
  2575.         (and (not (symbolp name)) (return nil))
  2576.         (setq matrix (get name 'production))
  2577.     (and (null matrix) (return nil))
  2578.     (terpri)
  2579.     (princ '|(p |)
  2580.     (princ name)
  2581.    top    (and (atom matrix) (go fin))
  2582.         (setq next (car matrix))
  2583.     (setq matrix (cdr matrix))
  2584.     (setq lab nil)
  2585.     (terpri)
  2586.     (cond ((eq next '-)
  2587.            (princ '|  - |)
  2588.            (setq next (car matrix))
  2589.            (setq matrix (cdr matrix)))
  2590.           ((eq next '-->)
  2591.            (princ '|  |))
  2592.           ((and (eq next '{) (atom (car matrix)))
  2593.            (princ '|   {|)
  2594.            (setq lab (car matrix))
  2595.            (setq next (cadr matrix))
  2596.            (setq matrix (cdddr matrix)))
  2597.           ((eq next '{)
  2598.            (princ '|   {|)
  2599.            (setq lab (cadr matrix))
  2600.            (setq next (car matrix))
  2601.            (setq matrix (cdddr matrix)))
  2602.           (t (princ '|    |)))
  2603.         (ppline next)
  2604.     (cond (lab (princ '| |) (princ lab) (princ '})))
  2605.     (go top)
  2606.     fin    (princ '|)|)))
  2607.  
  2608. (defun ppline (line)
  2609.   (prog ()
  2610.     (cond ((atom line) (princ line))
  2611.           (t
  2612.            (princ '|(|)
  2613.            (setq *ppline* line)
  2614.            (ppline2)
  2615.            (princ '|)|)))
  2616.         (return nil)))
  2617.  
  2618. (defun ppline2 ()
  2619.   (prog (needspace)
  2620.         (setq needspace nil)
  2621.    top  (and (atom *ppline*) (return nil))
  2622.         (and needspace (princ '| |))
  2623.         (cond ((eq (car *ppline*) '^) (ppattval))
  2624.           (t (pponlyval)))
  2625.         (setq needspace t)
  2626.         (go top)))
  2627.  
  2628. (defun ppattval ()
  2629.   (prog (att val)
  2630.         (setq att (cadr *ppline*))
  2631.     (setq *ppline* (cddr *ppline*))
  2632.     (setq val (getval))
  2633.     (cond ((> (+ (nwritn t) (flatc att) (flatc val)) 76.)
  2634.            (terpri)
  2635.            (princ '|        |)))
  2636.         (princ '^)
  2637.     (princ att)
  2638.     (mapc (function (lambda (z) (princ '| |) (princ z))) val)))
  2639.  
  2640. (defun pponlyval ()
  2641.   (prog (val needspace)
  2642.     (setq val (getval))
  2643.     (setq needspace nil)
  2644.     (cond ((> (+ (nwritn t) (flatc val)) 76.)
  2645.            (setq needspace nil)
  2646.            (terpri)
  2647.            (princ '|        |)))
  2648.     top    (and (atom val) (return nil))
  2649.         (and needspace (princ '| |))
  2650.     (setq needspace t)
  2651.     (princ (car val))
  2652.     (setq val (cdr val))
  2653.     (go top)))
  2654.  
  2655. (defun getval ()
  2656.   (prog (res v1)
  2657.         (setq v1 (car *ppline*))
  2658.     (setq *ppline* (cdr *ppline*))
  2659.     (cond ((memq v1 '(= <> < <= => > <=>))
  2660.            (setq res (cons v1 (getval))))
  2661.           ((eq v1 '{)
  2662.            (setq res (cons v1 (getupto '}))))
  2663.           ((eq v1 '<<)
  2664.            (setq res (cons v1 (getupto '>>))))
  2665.           ((eq v1 '//)
  2666.            (setq res (list v1 (car *ppline*)))
  2667.            (setq *ppline* (cdr *ppline*)))
  2668.           (t (setq res (list v1))))
  2669.         (return res)))
  2670.  
  2671. (defun getupto (end)
  2672.   (prog (v)
  2673.         (and (atom *ppline*) (return nil))
  2674.     (setq v (car *ppline*))
  2675.     (setq *ppline* (cdr *ppline*))
  2676.     (cond ((eq v end) (return (list v)))
  2677.           (t (return (cons v (getupto end)))))))
  2678.  
  2679.  
  2680.  
  2681.  
  2682.  
  2683.  
  2684. ;;; backing up
  2685.  
  2686.  
  2687.  
  2688. (defun record-index-plus (k)
  2689.   (setq *record-index* (+ k *record-index*))
  2690.   (cond ((< *record-index* 0.)
  2691.          (setq *record-index* *max-record-index*))
  2692.         ((> *record-index* *max-record-index*)
  2693.          (setq *record-index* 0.))))
  2694.  
  2695. ; the following routine initializes the record.  putting nil in the
  2696. ; first slot indicates that that the record does not go back further
  2697. ; than that.  (when the system backs up, it writes nil over the used
  2698. ; records so that it will recognize which records it has used.  thus
  2699. ; the system is set up anyway never to back over a nil.)
  2700.  
  2701. (defun initialize-record nil
  2702.   (setq *record-index* 0.)
  2703.   (setq *recording* nil)
  2704.   (setq *max-record-index* 31.)
  2705.   (putvector *record-array* 0. nil))
  2706.  
  2707. ; *max-record-index* holds the maximum legal index for record-array
  2708. ; so it and the following must be changed at the same time
  2709.  
  2710. (defun begin-record (p data)
  2711.   (setq *recording* t)
  2712.   (setq *record* (list '=>refract p data)))
  2713.  
  2714. (defun end-record nil
  2715.   (cond (*recording*
  2716.          (setq *record*
  2717.                (cons *cycle-count* (cons *p-name* *record*)))
  2718.          (record-index-plus 1.)
  2719.          (putvector *record-array* *record-index* *record*)
  2720.          (setq *record* nil)
  2721.          (setq *recording* nil))))
  2722.  
  2723. (defun record-change (direct time elm)
  2724.   (cond (*recording*
  2725.          (setq *record*
  2726.                (cons direct (cons time (cons elm *record*)))))))
  2727.  
  2728. ; to maintain refraction information, need keep only one piece of information:
  2729. ; need to record all unsuccessful attempts to delete things from the conflict
  2730. ; set.  unsuccessful deletes are caused by attempting to delete refracted
  2731. ; instantiations.  when backing up, have to avoid putting things back into the
  2732. ; conflict set if they were not deleted when running forward
  2733.  
  2734. (defun record-refract (rule data)
  2735.   (and *recording*
  2736.        (setq *record* (cons '<=refract (cons rule (cons data *record*)))))))
  2737.  
  2738. (defun refracted (rule data)
  2739.   (prog (z)
  2740.         (and (null *refracts*) (return nil))
  2741.     (setq z (cons rule data))
  2742.     (return (member z *refracts*))))
  2743.  
  2744. (defun back (k)
  2745.   (prog (r)
  2746.    l:   (and (< k 1.) (return nil))
  2747.         (setq r (getvector *record-array* *record-index*))
  2748.         (and (null r) (return '|nothing more stored|))
  2749.         (putvector *record-array* *record-index* nil)
  2750.         (record-index-plus -1.)
  2751.         (undo-record r)
  2752.         (setq k (1- k))
  2753.         (go l:)))
  2754.  
  2755. (defun undo-record (r)
  2756.   (prog (save act a b rate)
  2757.         (comment *recording* must be off during back up)
  2758.         (setq save *recording*)
  2759.         (setq *refracts* nil)
  2760.         (setq *recording* nil)
  2761.         (and *ptrace* (back-print (list 'undo: (car r) (cadr r))))
  2762.         (setq r (cddr r))
  2763.    top  (and (atom r) (go fin))
  2764.         (setq act (car r))
  2765.         (setq a (cadr r))
  2766.         (setq b (caddr r))
  2767.         (setq r (cdddr r))
  2768.         (and *wtrace* (back-print (list 'undo: act a)))
  2769.         (cond ((eq act '<=wm) (add-to-wm b a))
  2770.               ((eq act '=>wm) (remove-from-wm b))
  2771.               ((eq act '<=refract)
  2772.                (setq *refracts* (cons (cons a b) *refracts*)))
  2773.               ((and (eq act '=>refract) (still-present b))
  2774.            (setq *refracts* (delete (cons a b) *refracts*))
  2775.                (setq rate (rating-part (get a 'topnode)))
  2776.                (removecs a b)
  2777.                (insertcs a b rate))
  2778.               (t (%warn '|back: cannot undo action| (list act a))))
  2779.         (go top)
  2780.    fin  (setq *recording* save)
  2781.         (setq *refracts* nil)
  2782.         (return nil)))
  2783.  
  2784. ; still-present makes sure that the user has not deleted something
  2785. ; from wm which occurs in the instantiation about to be restored; it
  2786. ; makes the check by determining whether each wme still has a time tag.
  2787.  
  2788. (defun still-present (data)
  2789.   (prog nil
  2790.    l:   (cond ((atom data) (return t))
  2791.               ((creation-time (car data))
  2792.                (setq data (cdr data))
  2793.                (go l:))
  2794.               (t (return nil)))))
  2795.  
  2796.  
  2797. (defun back-print (x)
  2798.   (prog (port)
  2799.         (setq port (trace-file))
  2800.         (terpri port)
  2801.     (print x port)))
  2802.  
  2803.  
  2804.  
  2805.  
  2806. ;;; Functions to show how close rules are to firing
  2807.  
  2808. (defun matches fexpr (rule-list)
  2809.   (mapc (function matches2) rule-list)
  2810.   (terpri))
  2811.  
  2812. (defun matches2 (p)
  2813.   (cond ((atom p)
  2814.          (terpri)
  2815.          (terpri)
  2816.          (princ p)
  2817.          (matches3 (get p 'backpointers) 2. (ncons 1.)))))
  2818.  
  2819. (defun matches3 (nodes ce part)
  2820.   (cond ((not (null nodes))
  2821.          (terpri)
  2822.          (princ '| ** matches for |)
  2823.          (princ part)
  2824.          (princ '| ** |)
  2825.          (mapc (function write-elms) (find-left-mem (car nodes)))
  2826.          (terpri)
  2827.          (princ '| ** matches for |)
  2828.          (princ (ncons ce))
  2829.          (princ '| ** |)
  2830.          (mapc (function write-elms) (find-right-mem (car nodes)))
  2831.          (matches3 (cdr nodes) (1+ ce) (cons ce part)))))
  2832.  
  2833. (defun write-elms (wme-or-count)
  2834.   (cond ((dtpr wme-or-count)
  2835.      (terpri)
  2836.      (mapc (function write-elms2) wme-or-count))))
  2837.  
  2838. (defun write-elms2 (x)
  2839.   (princ '|  |)
  2840.   (princ (creation-time x)))
  2841.  
  2842. (defun find-left-mem (node)
  2843.   (cond ((eq (car node) '&and) (memory-part (caddr node)))
  2844.         (t (car (caddr node)))))
  2845.  
  2846. (defun find-right-mem (node) (memory-part (cadddr node)))
  2847.  
  2848.  
  2849. ;;; Check the RHSs of productions
  2850.  
  2851.  
  2852. (defun check-rhs (rhs) (mapc (function check-action) rhs))
  2853.  
  2854. (defun check-action (x)
  2855.   (prog (a)
  2856.     (cond ((atom x)
  2857.            (%warn '|atomic action| x)
  2858.        (return nil)))
  2859.     (setq a (setq *action-type* (car x)))
  2860.     (cond ((eq a 'bind) (check-bind x))
  2861.           ((eq a 'cbind) (check-cbind x))
  2862.           ((eq a 'make) (check-make x))
  2863.           ((eq a 'modify) (check-modify x))
  2864.           ((eq a 'remove) (check-remove x))
  2865.           ((eq a 'write) (check-write x))
  2866.           ((eq a 'call) (check-call x))
  2867.           ((eq a 'halt) (check-halt x))
  2868.           ((eq a 'openfile) (check-openfile x))
  2869.           ((eq a 'closefile) (check-closefile x))
  2870.           ((eq a 'default) (check-default x))
  2871.           ((eq a 'build) (check-build x))
  2872.           (t (%warn '|undefined rhs action| a)))))
  2873.  
  2874. (defun check-build (z)
  2875.   (and (null (cdr z)) (%warn '|needs arguments| z))
  2876.   (check-build-collect (cdr z)))
  2877.  
  2878. (defun check-build-collect (args)
  2879.   (prog (r)
  2880.     top    (and (null args) (return nil))
  2881.     (setq r (car args))
  2882.     (setq args (cdr args))
  2883.     (cond ((dtpr r) (check-build-collect r))
  2884.           ((eq r '\\)
  2885.            (and (null args) (%warn '|nothing to evaluate| r))
  2886.            (check-rhs-value (car args))
  2887.            (setq args (cdr args))))
  2888.     (go top)))
  2889.  
  2890. (defun check-remove (z)
  2891.   (and (null (cdr z)) (%warn '|needs arguments| z))
  2892.   (mapc (function check-rhs-ce-var) (cdr z)))
  2893.  
  2894. (defun check-make (z)
  2895.   (and (null (cdr z)) (%warn '|needs arguments| z))
  2896.   (check-change& (cdr z)))
  2897.  
  2898. (defun check-openfile (z)
  2899.   (and (null (cdr z)) (%warn '|needs arguments| z))
  2900.   (check-change& (cdr z)))
  2901.  
  2902. (defun check-closefile (z)
  2903.   (and (null (cdr z)) (%warn '|needs arguments| z))
  2904.   (check-change& (cdr z)))
  2905.  
  2906. (defun check-default (z)
  2907.   (and (null (cdr z)) (%warn '|needs arguments| z))
  2908.   (check-change& (cdr z)))
  2909.  
  2910. (defun check-modify (z)
  2911.   (and (null (cdr z)) (%warn '|needs arguments| z))
  2912.   (check-rhs-ce-var (cadr z))
  2913.   (and (null (cddr z)) (%warn '|no changes to make| z))
  2914.   (check-change& (cddr z)))
  2915.  
  2916. (defun check-write (z)
  2917.   (and (null (cdr z)) (%warn '|needs arguments| z))
  2918.   (check-change& (cdr z)))
  2919.  
  2920. (defun check-call (z)
  2921.   (prog (f)
  2922.     (and (null (cdr z)) (%warn '|needs arguments| z))
  2923.     (setq f (cadr z))
  2924.     (and (variablep f)
  2925.          (%warn '|function name must be a constant| z))
  2926.     (or (symbolp f)
  2927.         (%warn '|function name must be a symbolic atom| f))
  2928.     (or (externalp f)
  2929.         (%warn '|function name not declared external| f))
  2930.     (check-change& (cddr z))))
  2931.  
  2932. (defun check-halt (z)
  2933.   (or (null (cdr z)) (%warn '|does not take arguments| z)))
  2934.  
  2935. (defun check-cbind (z)
  2936.   (prog (v)
  2937.     (or (= (length z) 2.) (%warn '|takes only one argument| z))
  2938.     (setq v (cadr z))
  2939.     (or (variablep v) (%warn '|takes variable as argument| z))
  2940.     (note-ce-variable v)))
  2941.  
  2942. (defun check-bind (z)
  2943.   (prog (v)
  2944.     (or (> (length z) 1.) (%warn '|needs arguments| z))
  2945.     (setq v (cadr z))
  2946.     (or (variablep v) (%warn '|takes variable as argument| z))
  2947.     (note-variable v)
  2948.     (check-change& (cddr z))))
  2949.  
  2950.  
  2951. (defun check-change& (z)
  2952.   (prog (r tab-flag)
  2953.         (setq tab-flag nil)
  2954.    la   (and (atom z) (return nil))
  2955.         (setq r (car z))
  2956.         (setq z (cdr z))
  2957.         (cond ((eq r '^)
  2958.                (and tab-flag
  2959.                     (%warn '|no value before this tab| (car z)))
  2960.                (setq tab-flag t)
  2961.                (check-tab-index (car z))
  2962.                (setq z (cdr z)))
  2963.               ((eq r '//) (setq tab-flag nil) (setq z (cdr z)))
  2964.               (t (setq tab-flag nil) (check-rhs-value r)))
  2965.         (go la)))
  2966.  
  2967. (defun check-rhs-ce-var (v)
  2968.   (cond ((and (not (numberp v)) (not (ce-bound? v)))
  2969.          (%warn '|unbound element variable| v))
  2970.         ((and (numberp v) (or (< v 1.) (> v *ce-count*)))
  2971.          (%warn '|numeric element designator out of bounds| v))))
  2972.  
  2973. (defun check-rhs-value (x)
  2974.   (cond ((dtpr x) (check-rhs-function x))
  2975.         (t (check-rhs-atomic x))))
  2976.  
  2977. (defun check-rhs-atomic (x)
  2978.   (and (variablep x)
  2979.        (not (bound? x))
  2980.        (%warn '|unbound variable| x)))
  2981.  
  2982. (defun check-rhs-function (x)
  2983.   (prog (a)
  2984.     (setq a (car x))
  2985.     (cond ((eq a 'compute) (check-compute x))
  2986.           ((eq a 'arith) (check-compute x))
  2987.           ((eq a 'substr) (check-substr x))
  2988.           ((eq a 'accept) (check-accept x))
  2989.           ((eq a 'acceptline) (check-acceptline x))
  2990.           ((eq a 'crlf) (check-crlf x))
  2991.           ((eq a 'genatom) (check-genatom x))
  2992.       ((eq a 'litval) (check-litval x))
  2993.           ((eq a 'tabto) (check-tabto x))
  2994.       ((eq a 'rjust) (check-rjust x))
  2995.       ((not (externalp a))
  2996.        (%warn '"rhs function not declared external" a)))))
  2997.  
  2998. (defun check-litval (x)
  2999.   (or (= (length x) 2) (%warn '|wrong number of arguments| x))
  3000.   (check-rhs-atomic (cadr x)))
  3001.  
  3002. (defun check-accept (x)
  3003.   (cond ((= (length x) 1) nil)
  3004.         ((= (length x) 2) (check-rhs-atomic (cadr x)))
  3005.     (t (%warn '|too many arguments| x))))
  3006.  
  3007. (defun check-acceptline (x)
  3008.   (mapc (function check-rhs-atomic) (cdr x)))
  3009.  
  3010. (defun check-crlf (x)
  3011.   (check-0-args x))
  3012.  
  3013. (defun check-genatom (x) (check-0-args x))
  3014.  
  3015. (defun check-tabto (x)
  3016.   (or (= (length x) 2) (%warn '|wrong number of arguments| x))
  3017.   (check-print-control (cadr x)))
  3018.  
  3019. (defun check-rjust (x)
  3020.   (or (= (length x) 2) (%warn '|wrong number of arguments| x))
  3021.   (check-print-control (cadr x)))
  3022.  
  3023. (defun check-0-args (x)
  3024.   (or (= (length x) 1.) (%warn '|should not have arguments| x)))
  3025.  
  3026. (defun check-substr (x)
  3027.   (or (= (length x) 4.) (%warn '|wrong number of arguments| x))
  3028.   (check-rhs-ce-var (cadr x))
  3029.   (check-substr-index (caddr x))
  3030.   (check-last-substr-index (cadddr x)))
  3031.  
  3032. (defun check-compute (x) (check-arithmetic (cdr x)))
  3033.  
  3034. (defun check-arithmetic (l)
  3035.   (cond ((atom l)
  3036.          (%warn '|syntax error in arithmetic expression| l))
  3037.         ((atom (cdr l)) (check-term (car l)))
  3038.         ((not (memq (cadr l) '(+ - * // \\)))
  3039.          (%warn '|unknown operator| l))
  3040.         (t (check-term (car l)) (check-arithmetic (cddr l)))))
  3041.  
  3042. (defun check-term (x)
  3043.   (cond ((dtpr x) (check-arithmetic x))
  3044.         (t (check-rhs-atomic x))))
  3045.  
  3046. (defun check-last-substr-index (x)
  3047.   (or (eq x 'inf) (check-substr-index x)))
  3048.  
  3049. (defun check-substr-index (x)
  3050.   (prog (v)
  3051.     (cond ((bound? x) (return x)))
  3052.     (setq v ($litbind x))
  3053.     (cond ((not (numberp v))
  3054.            (%warn '|unbound symbol used as index in substr| x))
  3055.           ((or (< v 1.) (> v 127.))
  3056.            (%warn '|index out of bounds in tab| x)))))
  3057.  
  3058. (defun check-print-control (x)
  3059.   (prog ()
  3060.     (cond ((bound? x) (return x)))
  3061.     (cond ((or (not (numberp x)) (< x 1.) (> x 127.))
  3062.            (%warn '|illegal value for printer control| x)))))
  3063.  
  3064. (defun check-tab-index (x)
  3065.   (prog (v)
  3066.     (cond ((bound? x) (return x)))
  3067.     (setq v ($litbind x))
  3068.     (cond ((not (numberp v))
  3069.            (%warn '|unbound symbol occurs after ^| x))
  3070.           ((or (< v 1.) (> v 127.))
  3071.            (%warn '|index out of bounds after ^| x)))))
  3072.  
  3073. (defun note-variable (var)
  3074.   (setq *rhs-bound-vars* (cons var *rhs-bound-vars*)))
  3075.  
  3076. (defun bound? (var)
  3077.   (or (memq var *rhs-bound-vars*)
  3078.       (var-dope var)))
  3079.  
  3080. (defun note-ce-variable (ce-var)
  3081.   (setq *rhs-bound-ce-vars* (cons ce-var *rhs-bound-ce-vars*)))
  3082.  
  3083. (defun ce-bound? (ce-var)
  3084.   (or (memq ce-var *rhs-bound-ce-vars*)
  3085.       (ce-var-dope ce-var)))
  3086.  
  3087. ;;; Top level routines
  3088.  
  3089. (defun process-changes (adds dels)
  3090.   (prog (x)
  3091.    process-deletes (and (atom dels) (go process-adds))
  3092.         (setq x (car dels))
  3093.         (setq dels (cdr dels))
  3094.         (remove-from-wm x)
  3095.         (go process-deletes)
  3096.    process-adds (and (atom adds) (return nil))
  3097.         (setq x (car adds))
  3098.         (setq adds (cdr adds))
  3099.         (add-to-wm x nil)
  3100.         (go process-adds)))
  3101.  
  3102. (defun main nil
  3103.   (prog (instance r)
  3104.         (setq *halt-flag* nil)
  3105.         (setq *break-flag* nil)
  3106.         (setq instance nil)
  3107.    dil  (setq *phase* 'conflict-resolution)
  3108.         (cond (*halt-flag*
  3109.                (setq r '|end -- explicit halt|)
  3110.                (go finis))
  3111.           ((zerop *remaining-cycles*)
  3112.            (setq r '***break***)
  3113.            (setq *break-flag* t)
  3114.            (go finis))
  3115.               (*break-flag* (setq r '***break***) (go finis)))
  3116.     (setq *remaining-cycles* (1- *remaining-cycles*))
  3117.         (setq instance (conflict-resolution))
  3118.         (cond ((not instance)
  3119.                (setq r '|end -- no production true|)
  3120.                (go finis)))
  3121.         (setq *phase* (car instance))
  3122.         (accum-stats)
  3123.         (eval-rhs (car instance) (cdr instance))
  3124.         (check-limits)
  3125.     (and (broken (car instance)) (setq *break-flag* t))
  3126.         (go dil)
  3127.   finis (setq *p-name* nil)
  3128.         (return r)))
  3129.  
  3130. (defun do-continue (wmi)
  3131.     (cond (*critical*
  3132.            (terpri)
  3133.            (princ '|warning: network may be inconsistent|)))
  3134.     (process-changes wmi nil)
  3135.     (print-times (main)))
  3136.  
  3137. (defun accum-stats nil
  3138.   (setq *cycle-count* (1+ *cycle-count*))
  3139.   (setq *total-token* (+ *total-token* *current-token*))
  3140.   (cond ((> *current-token* *max-token*)
  3141.          (setq *max-token* *current-token*)))
  3142.   (setq *total-wm* (+ *total-wm* *current-wm*))
  3143.   (cond ((> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))))
  3144.  
  3145.  
  3146. (defun print-times (mess)
  3147.   (prog (cc ac)
  3148.         (cond (*break-flag* (terpri) (return mess)))
  3149.         (setq cc (plus (float *cycle-count*) 1.0e-20))
  3150.         (setq ac (plus (float *action-count*) 1.0e-20))
  3151.         (terpri)
  3152.         (princ mess)
  3153.         (pm-size)
  3154.         (printlinec (list *cycle-count*
  3155.                           'firings
  3156.                           (list *action-count* 'rhs 'actions)))
  3157.         (terpri)
  3158.         (printlinec (list (round (quotient (float *total-wm*) cc))
  3159.                           'mean 'working 'memory 'size
  3160.                           (list *max-wm* 'maximum)))
  3161.         (terpri)
  3162.         (printlinec (list (round (quotient (float *total-cs*) cc))
  3163.                           'mean 'conflict 'set 'size
  3164.                           (list *max-cs* 'maximum)))
  3165.         (terpri)
  3166.         (printlinec (list (round (quotient (float *total-token*) cc))
  3167.                           'mean 'token 'memory 'size
  3168.                           (list *max-token* 'maximum)))
  3169.         (terpri)))
  3170.  
  3171. (defun pm-size nil
  3172.   (terpri)
  3173.   (printlinec (list *pcount*
  3174.                     'productions
  3175.                     (list *real-cnt* '// *virtual-cnt* 'nodes)))
  3176.   (terpri))
  3177.  
  3178. (defun check-limits nil
  3179.   (cond ((> (length *conflict-set*) *limit-cs*)
  3180.          (terpri)
  3181.          (terpri)
  3182.          (printlinec (list '|conflict set size exceeded the limit of|
  3183.                            *limit-cs*
  3184.                            '|after|
  3185.                            *p-name*))
  3186.          (setq *halt-flag* t)))
  3187.   (cond ((> *current-token* *limit-token*)
  3188.          (terpri)
  3189.          (terpri)
  3190.          (printlinec (list '|token memory size exceeded the limit of|
  3191.                            *limit-token*
  3192.                            '|after|
  3193.                            *p-name*))
  3194.          (setq *halt-flag* t))))
  3195.  
  3196.  
  3197. (defun top-level-remove (z)
  3198.   (cond ((equal z '(*)) (process-changes nil (get-wm nil)))
  3199.         (t (process-changes nil (get-wm z)))))
  3200.  
  3201. (defun excise fexpr (z) (mapc (function excise-p) z))
  3202.  
  3203. (defun run fexpr (z)
  3204.   (cond ((atom z) (setq *remaining-cycles* 1000000.) (do-continue nil))
  3205.         ((and (atom (cdr z)) (numberp (car z)) (> (car z) 0.))
  3206.          (setq *remaining-cycles* (car z))
  3207.          (do-continue nil))
  3208.         (t 'what?)))
  3209.  
  3210. (defun strategy fexpr (z)
  3211.   (cond ((atom z) *strategy*)
  3212.         ((equal z '(lex)) (setq *strategy* 'lex))
  3213.         ((equal z '(mea)) (setq *strategy* 'mea))
  3214.         (t 'what?)))
  3215.  
  3216. (defun cs fexpr (z)
  3217.   (cond ((atom z) (conflict-set))
  3218.         (t 'what?)))
  3219.  
  3220. (defun watch fexpr (z)
  3221.   (cond ((equal z '(0.))
  3222.          (setq *wtrace* nil)
  3223.          (setq *ptrace* nil)
  3224.          0.)
  3225.         ((equal z '(1.)) (setq *wtrace* nil) (setq *ptrace* t) 1.)
  3226.         ((equal z '(2.)) (setq *wtrace* t) (setq *ptrace* t) 2.)
  3227.         ((equal z '(3.))
  3228.          (setq *wtrace* t)
  3229.          (setq *ptrace* t)
  3230.          '(2. -- conflict set trace not supported))
  3231.         ((and (atom z) (null *ptrace*)) 0.)
  3232.         ((and (atom z) (null *wtrace*)) 1.)
  3233.         ((atom z) 2.)
  3234.         (t 'what?)))
  3235.  
  3236. (defun external fexpr (z) (catch (external2 z) !error!))
  3237.  
  3238. (defun external2 (z) (mapc (function external3) z))
  3239.  
  3240. (defun external3 (x)
  3241.   (cond ((symbolp x) (putprop x t 'external-routine))
  3242.     (t (%error '|not a legal function name| x))))
  3243.  
  3244. (defun externalp (x)
  3245.   (cond ((symbolp x) (get x 'external-routine))
  3246.     (t (%warn '|not a legal function name| x) nil)))
  3247.  
  3248. (defun pbreak fexpr (z)
  3249.   (cond ((atom z) (terpri) *brkpts*)
  3250.     (t (mapc (function pbreak2) z) nil)))
  3251.  
  3252. (defun pbreak2 (rule)
  3253.   (cond ((not (symbolp rule)) (%warn '|illegal name| rule))
  3254.     ((not (get rule 'topnode)) (%warn '|not a production| rule))
  3255.     ((memq rule *brkpts*) (setq *brkpts* (rematm rule *brkpts*)))
  3256.     (t (setq *brkpts* (cons rule *brkpts*)))))
  3257.  
  3258. (defun rematm (atm list)
  3259.   (cond ((atom list) list)
  3260.     ((eq atm (car list)) (rematm atm (cdr list)))
  3261.     (t (cons (car list) (rematm atm (cdr list))))))
  3262.  
  3263. (defun broken (rule) (memq rule *brkpts*))
  3264.  
  3265.