home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume12 / ops5 / part02 < prev    next >
Encoding:
Internet Message Format  |  1987-10-12  |  27.7 KB
  1. Subject:  v12i017:  OPS5 in Common Lisp, Part02/05
  2. Newsgroups: comp.sources.unix
  3. Sender: sources
  4. Approved: rs@uunet.UU.NET
  5.  
  6. Submitted-by: eric@dlcdev.UUCP (eric van tassell)
  7. Posting-number: Volume 12, Issue 17
  8. Archive-name: ops5/part02
  9.  
  10.  
  11. ; File OPS5.common.1.lsp: part 1 of OPS5 in Common Lisp
  12. ; ----------
  13.  
  14.  
  15. ;    VPS2 -- Interpreter for OPS5
  16. ;
  17. ;    Copyright (C) 1979, 1980, 1981
  18. ;    Charles L. Forgy,  Pittsburgh, Pennsylvania
  19.  
  20.  
  21.  
  22. ; Users of this interpreter are requested to contact
  23.  
  24. ;
  25. ;    Charles Forgy
  26. ;    Computer Science Department
  27. ;    Carnegie-Mellon University
  28. ;    Pittsburgh, PA  15213
  29. ; or
  30. ;    Forgy@CMUA
  31. ; 
  32. ; so that they can be added to the mailing list for OPS5.  The mailing list
  33. ; is needed when new versions of the interpreter or manual are released.
  34.  
  35.  
  36.  
  37. ;;; Definitions
  38.  
  39. ;#+ vax (defun putprop(name val att)
  40. ;   (setf (get name att) val))
  41.  
  42.  
  43.  
  44. (proclaim '(special *matrix* *feature-count* *pcount* *vars* *cur-vars*
  45.           *curcond* *subnum* *last-node* *last-branch* *first-node*
  46.           *sendtocall* *flag-part* *alpha-flag-part* *data-part*
  47.           *alpha-data-part* *ce-vars* *virtual-cnt* *real-cnt*
  48.           *current-token* *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9*
  49.           *c10* *c11* *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19*
  50.           *c20* *c21* *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29*
  51.           *c30* *c31* *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39*
  52.           *c40* *c41* *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49*
  53.           *c50* *c51* *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59*
  54.           *c60* *c61* *c62* *c63* *c64* *record-array* *result-array* 
  55.           *max-cs* *total-cs* *limit-cs* *cr-temp* *side*
  56.           *conflict-set* *halt-flag* *phase* *critical*
  57.           *cycle-count* *total-token* *max-token* *refracts* 
  58.           *limit-token* *total-wm* *current-wm* *max-wm*
  59.           *action-count* *wmpart-list* *wm* *data-matched* *p-name*
  60.           *variable-memory* *ce-variable-memory* 
  61.           *max-index* ; number of right-most field in wm element 
  62.           *next-index* *size-result-array* *rest* *build-trace* *last*
  63.           *ptrace* *wtrace* *in-rhs* *recording* *accept-file* *trace-file* 
  64.           *mtrace* *madeby* ; used to trace and record makers of elements
  65.           *write-file* *record-index* *max-record-index* *old-wm*
  66.           *record* *filters* *break-flag* *strategy* *remaining-cycles*
  67.       *wm-filter* *rhs-bound-vars* *rhs-bound-ce-vars* *ppline* 
  68.       *ce-count* *brkpts* *class-list* *buckets* *action-type*
  69.           *literals*   ;stores literal definitions
  70.           *pnames*     ;stores production names
  71.       *externals*  ;tracks external declarations 
  72.           *vector-attributes*  ;list of vector-attributes
  73.       ))
  74.  
  75. ;(declare (localf ce-gelm gelm peek-sublex sublex
  76. ;          eval-nodelist sendto and-left and-right not-left not-right
  77. ;          top-levels-eq add-token real-add-token remove-old
  78. ;          remove-old-num remove-old-no-num removecs insertcs dsort
  79. ;          best-of best-of* conflict-set-compare =alg ))
  80.  
  81.  
  82. ;;; Functions that were revised so that they would compile efficiently
  83.  
  84.  
  85. ;* The function == is machine dependent\!
  86. ;* This function compares small integers for equality.  It uses EQ
  87. ;* so that it will be fast, and it will consequently not work on all
  88. ;* Lisps.  It works in Franz Lisp for integers in [-128, 127]
  89.  
  90.  
  91. ;(defun == (&rest z) (= (cadr z) (caddr z)))
  92. (defun == (x y) (= x y))
  93.  
  94. ; =ALG returns T if A and B are algebraicly equal.
  95.  
  96. (defun =alg (a b) (= a b))
  97.  
  98. (defmacro fast-symeval (&rest z)
  99.      `(cond ((eq ,(car z) '*c1*) *c1*)
  100.         ((eq ,(car z) '*c2*) *c2*)
  101.         ((eq ,(car z) '*c3*) *c3*)
  102.         ((eq ,(car z) '*c4*) *c4*)
  103.         ((eq ,(car z) '*c5*) *c5*)
  104.         ((eq ,(car z) '*c6*) *c6*)
  105.         ((eq ,(car z) '*c7*) *c7*)
  106.         (t (eval ,(car z)))  ))
  107.  
  108. ; getvector and putvector are fast routines for using one-dimensional
  109. ; arrays.  these routines do no checking; they assume
  110. ;    1. the array is a vector with 0 being the index of the first
  111. ;       element
  112. ;    2. the vector holds arbitrary list values
  113. ;defun versions are useful for tracing
  114.  
  115. ; Example call: (putvector array index value)
  116.  
  117. (defmacro putvector (array_ref ind var)
  118.       `(setf (aref ,array_ref ,ind) ,var))
  119.  
  120. ;(defun putvector (array_ref ind var)
  121. ;      (setf (aref array_ref ind) var))
  122.  
  123. ; Example call: (getvector name index)
  124.  
  125. ;(defmacro getvector(&rest z)
  126. ;     (list 'cxr (caddr z) (cadr z)))
  127.  
  128. (defmacro getvector(array_ref ind)
  129.       `(aref ,array_ref ,ind))
  130.  
  131. ;(defun getvector (array_ref ind)
  132.  ;       (aref array_ref ind))
  133.  
  134. (defun ce-gelm (x k)
  135.   (prog nil
  136.    loop (and (== k 1.) (return (car x)))
  137.         (setq k (1- k))
  138.         (setq x (cdr x))
  139.         (go loop))) 
  140.  
  141. ; The loops in gelm were unwound so that fewer calls on DIFFERENCE
  142. ; would be needed
  143.  
  144. (defun gelm (x k)
  145.   (prog (ce sub)
  146.         (setq ce  (floor (/ k 10000)))
  147.         (setq sub (- k (* ce 10000)))
  148.  celoop (and (== ce 0) (go ph2))
  149.         (setq x (cdr x))
  150.         (and (== ce 1) (go ph2))
  151.         (setq x (cdr x))
  152.         (and (== ce 2) (go ph2))
  153.         (setq x (cdr x))
  154.         (and (== ce 3) (go ph2))
  155.         (setq x (cdr x))
  156.         (and (== ce 4) (go ph2))
  157.         (setq ce (- ce 4))
  158.         (go celoop)
  159.    ph2  (setq x (car x))
  160.    subloop (and (== sub 0) (go finis))
  161.         (setq x (cdr x))
  162.         (and (== sub 1) (go finis))
  163.         (setq x (cdr x))
  164.         (and (== sub 2) (go finis))
  165.         (setq x (cdr x))
  166.         (and (== sub 3) (go finis))
  167.         (setq x (cdr x))
  168.         (and (== sub 4) (go finis))
  169.         (setq x (cdr x))
  170.         (and (== sub 5) (go finis))
  171.         (setq x (cdr x))
  172.         (and (== sub 6) (go finis))
  173.         (setq x (cdr x))
  174.         (and (== sub 7) (go finis))
  175.         (setq x (cdr x))
  176.         (and (== sub 8) (go finis))
  177.         (setq sub (- sub 8))
  178.         (go subloop)
  179.    finis (return (car x)))) 
  180.  
  181.  
  182. ;;; Utility functions
  183.  
  184.  
  185.  
  186. (defun printline (x) (mapc (function printline*) x)) 
  187.  
  188. (defun printline* (y) (princ '| |) (print y)) 
  189.  
  190. (defun printlinec (x) (mapc (function printlinec*) x)) 
  191.  
  192. (defun printlinec* (y) (princ '| |) (princ y)) 
  193.  
  194. ; intersect two lists using eq for the equality test
  195.  
  196. (defun interq (x y)
  197.   (intersection x y :test #'eq))
  198.  
  199. (defun enter (x ll)
  200.    (and (not (member x ll :test #'equal))
  201.        (push x ll)))
  202.  
  203.  
  204. ;Hack read-macro tables to accept single characters -- right out of CL book.
  205. (defun single-macro-character (stream char)
  206.    (declare (ignore stream))
  207.    (character char))
  208.  
  209. (defun i-g-v nil
  210.  (prog (x)
  211.         (set-macro-character #\{ #'single-macro-character )
  212.         (set-macro-character #\} #'single-macro-character )
  213.         (set-macro-character #\^ #'single-macro-character )
  214. ;    (setsyntax '\{ 66.) ;These are already normal characters in CL
  215. ;    (setsyntax '\} 66.)
  216. ;    (setsyntax '^ 66.)
  217.     (setq *buckets* 64.)        ; OPS5 allows 64 named slots
  218.     (setq *accept-file* nil)
  219.     (setq *write-file* nil)
  220.     (setq *trace-file* nil)
  221.         (and (boundp '*class-list*)
  222.           (mapc #'(lambda(class) (putprop class nil 'att-list)) *class-list*))
  223.     (setq *class-list* nil)
  224.     (setq *brkpts* nil)
  225.     (setq *strategy* 'lex)
  226.       (setq *in-rhs* nil)
  227.       (setq *ptrace* t)
  228.       (setq *wtrace* nil)
  229.     (setq *mtrace* t)            ; turn on made-by tracing
  230.     (setq *madeby* nil)          ; record makers of wm elements
  231.       (setq *recording* nil)
  232.         (setq *refracts* nil)
  233.     (setq *real-cnt* (setq *virtual-cnt* 0.))
  234.     (setq *max-cs* (setq *total-cs* 0.))
  235.       (setq *limit-token* 1000000.)
  236.     (setq *limit-cs* 1000000.)
  237.     (setq *critical* nil)
  238.     (setq *build-trace* nil)
  239.     (setq *wmpart-list* nil)
  240.         (setq *pnames* nil)
  241.         (setq *literals* nil) ; records literal definitions
  242.     (setq *externals* nil) ; records external definitions
  243.     (setq *vector-attributes* nil) ;records vector attributes
  244.     (setq *size-result-array* 127.)
  245.     (setq *result-array* (make-array 128))
  246.     (setq *record-array* (make-array 128))
  247.     (setq x 0)
  248.         (setq *pnames* nil)     ; list of production names
  249.   loop    (putvector *result-array* x nil)
  250.     (setq x (1+ x))
  251.     (and (not (> x *size-result-array*)) (go loop))
  252.     (make-bottom-node)
  253.     (setq *pcount* 0.)
  254.     (initialize-record)
  255.     (setq *cycle-count* (setq *action-count* 0.))
  256.     (setq *total-token*
  257.            (setq *max-token* (setq *current-token* 0.)))
  258.     (setq *total-cs* (setq *max-cs* 0.))
  259.     (setq *total-wm* (setq *max-wm* (setq *current-wm* 0.)))
  260.     (setq *conflict-set* nil)
  261.     (setq *wmpart-list* nil)
  262.     (setq *p-name* nil)
  263.     (setq *remaining-cycles* 1000000)
  264. ))
  265.  
  266. ; if the size of result-array changes, change the line in i-g-v which
  267. ; sets the value of *size-result-array*
  268.  
  269. (defun %warn (what where)
  270.   (prog nil
  271.     (terpri)
  272.     (princ '?)
  273.     (and *p-name* (princ *p-name*))
  274.     (princ '|..|)
  275.     (princ where)
  276.     (princ '|..|)
  277.     (princ what)
  278.     (return where))) 
  279.  
  280. (defun %error (what where)
  281.     (%warn what where)
  282.     (throw '!error! nil)) 
  283.  
  284.  
  285. (defun top-levels-eq (la lb)
  286.   (prog nil
  287.    lx   (cond ((eq la lb) (return t))
  288.               ((null la) (return nil))
  289.               ((null lb) (return nil))
  290.               ((not (eq (car la) (car lb))) (return nil)))
  291.         (setq la (cdr la))
  292.         (setq lb (cdr lb))
  293.         (go lx))) 
  294.  
  295.  
  296. ;;; LITERAL and LITERALIZE
  297.  
  298. (defmacro literal (&rest z)
  299.   `(prog (atm val old args)
  300.         (setq args ',z)
  301.    top  (and (atom args) (return 'bound))
  302.         (or (eq (cadr args) '=) (return (%warn '|wrong format| args)))
  303.         (setq atm (car args))
  304.         (setq val (caddr args))
  305.         (setq args (cdddr args))
  306.         (cond ((not (numberp val))
  307.                (%warn '|can bind only to numbers| val))
  308.               ((or (not (symbolp atm)) (variablep atm))
  309.                 (%warn '|can bind only constant atoms| atm))
  310.               ((and (setq old (literal-binding-of atm)) (not (equal old val)))
  311.                (%warn '|attempt to rebind attribute| atm))
  312.               (t (putprop atm val 'ops-bind )))
  313.         (go top))) 
  314.  
  315. (defmacro literalize (&rest l)
  316.   `(prog (class-name atts)
  317.     (setq class-name (car ',l))
  318.     (cond ((have-compiled-production)
  319.            (%warn '|literalize called after p| class-name)
  320.            (return nil))
  321.           ((get class-name 'att-list)
  322.            (%warn '|attempt to redefine class| class-name)
  323.        (return nil)))
  324.     (setq *class-list* (cons class-name *class-list*))
  325.     (setq atts (remove-duplicates (cdr ',l)))
  326.     (test-attribute-names atts)
  327.     (mark-conflicts atts atts)
  328.     (putprop class-name  atts 'att-list))) 
  329.  
  330. (defmacro vector-attribute  (&rest l)
  331.   `(cond ((have-compiled-production)
  332.          (%warn '|vector-attribute called after p| ',l))
  333.         (t 
  334.          (test-attribute-names ',l)
  335.      (mapc (function vector-attribute2) ',l)))) 
  336.  
  337. (defun vector-attribute2 (att) (putprop att t 'vector-attribute)
  338.                    (setq  *vector-attributes* 
  339.                    (enter att *vector-attributes*)))
  340.  
  341. (defun is-vector-attribute (att) (get att 'vector-attribute))
  342.  
  343. (defun test-attribute-names (l)
  344.   (mapc (function test-attribute-names2) l)) 
  345.  
  346. (defun test-attribute-names2 (atm)
  347.   (cond ((or (not (symbolp atm)) (variablep atm))
  348.          (%warn '|can bind only constant atoms| atm)))) 
  349.  
  350. (defun finish-literalize nil
  351.   (cond ((not (null *class-list*))
  352.          (mapc (function note-user-assigns) *class-list*)
  353.          (mapc (function assign-scalars) *class-list*)
  354.          (mapc (function assign-vectors) *class-list*)
  355.          (mapc (function put-ppdat) *class-list*)
  356.          (mapc (function erase-literal-info) *class-list*)
  357.          (setq *class-list* nil)
  358.          (setq *buckets* nil)))) 
  359.  
  360. (defun have-compiled-production nil (not (zerop *pcount*))) 
  361.  
  362. (defun put-ppdat (class)
  363.   (prog (al att ppdat)
  364.         (setq ppdat nil)
  365.         (setq al (get class 'att-list))
  366.    top  (cond ((not (atom al))
  367.                (setq att (car al))
  368.                (setq al (cdr al))
  369.                (setq ppdat
  370.                      (cons (cons (literal-binding-of att) att)
  371.                            ppdat))
  372.                (go top)))
  373.         (putprop class ppdat 'ppdat))) 
  374.  
  375. ; note-user-assigns and note-user-vector-assigns are needed only when
  376. ; literal and literalize are both used in a program.  They make sure that
  377. ; the assignments that are made explicitly with literal do not cause problems
  378. ; for the literalized classes.
  379.  
  380. (defun note-user-assigns (class)
  381.   (mapc (function note-user-assigns2) (get class 'att-list)))
  382.  
  383. (defun note-user-assigns2 (att)
  384.   (prog (num conf buck clash)
  385.         (setq num (literal-binding-of att))
  386.     (and (null num) (return nil))
  387.     (setq conf (get att 'conflicts))
  388.     (setq buck (store-binding att num))
  389.     (setq clash (find-common-atom buck conf))
  390.     (and clash
  391.          (%warn '|attributes in a class assigned the same number|
  392.                 (cons att clash)))
  393.         (return nil)))
  394.  
  395. (defun note-user-vector-assigns (att given needed)
  396.   (and (> needed given)
  397.        (%warn '|vector attribute assigned too small a value in literal| att)))
  398.  
  399. (defun assign-scalars (class)
  400.   (mapc (function assign-scalars2) (get class 'att-list))) 
  401.  
  402. (defun assign-scalars2 (att)
  403.   (prog (tlist num bucket conf)
  404.         (and (literal-binding-of att) (return nil))
  405.         (and (is-vector-attribute att) (return nil))
  406.         (setq tlist (buckets))
  407.         (setq conf (get att 'conflicts))
  408.    top  (cond ((atom tlist)
  409.                (%warn '|could not generate a binding| att)
  410.                (store-binding att -1.)
  411.                (return nil)))
  412.         (setq num (caar tlist))
  413.         (setq bucket (cdar tlist))
  414.         (setq tlist (cdr tlist))
  415.         (cond ((disjoint bucket conf) (store-binding att num))
  416.         (t (go top))))) 
  417.  
  418. (defun assign-vectors (class)
  419.   (mapc (function assign-vectors2) (get class 'att-list))) 
  420.  
  421. (defun assign-vectors2 (att)
  422.   (prog (big conf new old need)
  423.         (and (not (is-vector-attribute att)) (return nil))
  424.         (setq big 1.)
  425.         (setq conf (get att 'conflicts))
  426.    top  (cond ((not (atom conf))
  427.                (setq new (car conf))
  428.                (setq conf (cdr conf))
  429.                (cond ((is-vector-attribute new)
  430.                       (%warn '|class has two vector attributes|
  431.                       (list att new)))
  432.                      (t (setq big (max (literal-binding-of new) big))))
  433.                (go top)))
  434.         (setq need (1+ big))
  435.     (setq old (literal-binding-of att))
  436.     (cond (old (note-user-vector-assigns att old need))
  437.           (t (store-binding att need)))
  438.         (return nil)))
  439.  
  440. (defun disjoint (la lb) (not (find-common-atom la lb))) 
  441.  
  442. (defun find-common-atom (la lb)
  443.   (prog nil
  444.    top  (cond ((null la) (return nil))
  445.               ((member (car la) lb :test #'eq) (return (car la)))
  446.               (t (setq la (cdr la)) (go top))))) 
  447.  
  448. (defun mark-conflicts (rem all)
  449.   (cond ((not (null rem))
  450.          (mark-conflicts2 (car rem) all)
  451.          (mark-conflicts (cdr rem) all)))) 
  452.  
  453. (defun mark-conflicts2 (atm lst)
  454.   (prog (l)
  455.         (setq l lst)
  456.    top  (and (atom l) (return nil))
  457.         (conflict atm (car l))
  458.         (setq l (cdr l))
  459.         (go top))) 
  460.  
  461. (defun conflict (a b)
  462.   (prog (old)
  463.     (setq old (get a 'conflicts))
  464.     (and (not (eq a b))
  465.          (not (member b old :test #'eq))
  466.          (putprop a (cons b old) 'conflicts )))) 
  467.  
  468. ;(defun remove-duplicates (lst)
  469. ;  (cond ((atom lst) nil)
  470. ;        ((member (car lst) (cdr lst) :test #'eq) (remove-duplicates (cdr lst)))
  471. ;        (t (cons (car lst) (remove-duplicates (cdr lst)))))) 
  472.  
  473. (defun literal-binding-of (name) (get name 'ops-bind)) 
  474.  
  475. (defun store-binding (name lit)
  476.   (putprop name lit 'ops-bind)
  477.   (add-bucket name lit)) 
  478.  
  479. (defun add-bucket (name num)
  480.   (prog (buc)
  481.     (setq buc (assoc num (buckets)))
  482.     (and (not (member name buc :test #'eq))
  483.          (rplacd buc (cons name (cdr buc))))
  484.     (return buc))) 
  485.  
  486. (defun buckets nil
  487.   (and (atom *buckets*) (setq *buckets* (make-nums *buckets*)))
  488.   *buckets*) 
  489.  
  490. (defun make-nums (k)
  491.   (prog (nums)
  492.         (setq nums nil)
  493.    l    (and (< k 2.) (return nums))
  494.         (setq nums (cons (cons k nil) nums))
  495.         (setq k (1- k))
  496.         (go l))) 
  497.  
  498. ;(defun erase-literal-info (class)
  499. ;  (mapc (function erase-literal-info2) (get class 'att-list))
  500. ;  (remprop class 'att-list)) 
  501.  
  502. ; modified to record literal info in the variable *literals*
  503. (defun erase-literal-info (class)
  504.       (setq *literals*
  505.             (cons (cons class (get class 'att-list)) *literals*))
  506.       (mapc (function erase-literal-info2) (get class 'att-list))
  507.       (remprop class 'att-list))
  508.  
  509.  
  510. (defun erase-literal-info2 (att) (remprop att 'conflicts)) 
  511.  
  512.  
  513. ;;; LHS Compiler
  514.  
  515. (defmacro p (&rest z) 
  516.  `(progn 
  517.    (finish-literalize)
  518.    (princ '*) 
  519.   ;(drain);drain probably drains a line feed
  520.    (compile-production (car ',z) (cdr ',z)))) 
  521.  
  522. (defun compile-production (name matrix)
  523.   (prog (erm)
  524.         (setq *p-name* name)
  525.         (setq erm (catch '!error! (cmp-p name matrix) ))
  526.     ; following line is modified to save production name on *pnames*
  527.         (and (null erm) (setq *pnames* (enter name *pnames*)))
  528.     (setq *p-name* nil)
  529.     (return erm)))
  530.  
  531. (defun peek-lex nil (car *matrix*)) 
  532.  
  533. (defun lex nil
  534.   (prog2 nil (car *matrix*) (setq *matrix* (cdr *matrix*)))) 
  535.  
  536. (defun end-of-p nil (atom *matrix*)) 
  537.  
  538. (defun rest-of-p nil *matrix*) 
  539.  
  540. (defun prepare-lex (prod) (setq *matrix* prod)) 
  541.  
  542.  
  543. (defun peek-sublex nil (car *curcond*)) 
  544.  
  545. (defun sublex nil
  546.   (prog2 nil (car *curcond*) (setq *curcond* (cdr *curcond*)))) 
  547.  
  548. (defun end-of-ce nil (atom *curcond*)) 
  549.  
  550. (defun rest-of-ce nil *curcond*) 
  551.  
  552. (defun prepare-sublex (ce) (setq *curcond* ce)) 
  553.  
  554. (defun make-bottom-node nil (setq *first-node* (list '&bus nil))) 
  555.  
  556. (defun cmp-p (name matrix)
  557.   (prog (m bakptrs)
  558.         (cond ((or (null name) (listp name))
  559.                (%error '|illegal production name| name))
  560.               ((equal (get name 'production) matrix)
  561.            (return nil)))
  562.         (prepare-lex matrix)
  563.         (excise-p name)
  564.         (setq bakptrs nil)
  565.         (setq *pcount* (1+ *pcount*))
  566.         (setq *feature-count* 0.)
  567.     (setq *ce-count* 0)
  568.         (setq *vars* nil)
  569.         (setq *ce-vars* nil)
  570.     (setq *rhs-bound-vars* nil)
  571.     (setq *rhs-bound-ce-vars* nil)
  572.         (setq *last-branch* nil)
  573.         (setq m (rest-of-p))
  574.    l1   (and (end-of-p) (%error '|no '-->' in production| m))
  575.         (cmp-prin)
  576.         (setq bakptrs (cons *last-branch* bakptrs))
  577.         (or (eq '--> (peek-lex)) (go l1))
  578.         (lex)
  579.     (check-rhs (rest-of-p))
  580.         (link-new-node (list '&p
  581.                              *feature-count*
  582.                              name
  583.                              (encode-dope)
  584.                              (encode-ce-dope)
  585.                              (cons 'progn (rest-of-p))))
  586.         (putprop name (cdr (nreverse bakptrs)) 'backpointers )
  587.     (putprop name matrix 'production)
  588.         (putprop name *last-node* 'topnode))) 
  589.  
  590. (defun rating-part (pnode) (cadr pnode)) 
  591.  
  592. (defun var-part (pnode) (car (cdddr pnode))) 
  593.  
  594. (defun ce-var-part (pnode) (cadr (cdddr pnode))) 
  595.  
  596. (defun rhs-part (pnode) (caddr (cdddr pnode))) 
  597.  
  598. (defun excise-p (name)
  599.   (cond ((and (symbolp name) (get name 'topnode))
  600.      (printline (list name 'is 'excised))
  601.          (setq *pcount* (1- *pcount*))
  602.          (remove-from-conflict-set name)
  603.          (kill-node (get name 'topnode))
  604.          (setq *pnames* (delete name *pnames* :test #'eq))
  605.      (remprop name 'production)
  606.      (remprop name 'backpointers)
  607.          (remprop name 'topnode)))) 
  608.  
  609. (defun kill-node (node)
  610.   (prog nil
  611.    top  (and (atom node) (return nil))
  612.         (rplaca node '&old)
  613.         (setq node (cdr node))
  614.         (go top))) 
  615.  
  616. (defun cmp-prin nil
  617.   (prog nil
  618.         (setq *last-node* *first-node*)
  619.         (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta))
  620.               ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
  621.               (t (cmp-posce) (cmp-and))))) 
  622.  
  623. (defun cmp-negce nil (lex) (cmp-ce)) 
  624.  
  625. (defun cmp-posce nil
  626.   (setq *ce-count* (1+ *ce-count*))
  627.   (cond ((eq (peek-lex) #\{) (cmp-ce+cevar))
  628.         (t (cmp-ce)))) 
  629.  
  630. (defun cmp-ce+cevar nil
  631.   (prog (z)
  632.         (lex)
  633.         (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
  634.               (t (cmp-ce) (cmp-cevar)))
  635.         (setq z (lex))
  636.         (or (eq z #\}) (%error '|missing '}'| z)))) 
  637.  
  638. (defun new-subnum (k)
  639.   (or (numberp k) (%error '|tab must be a number| k))
  640.   (setq *subnum* (round k))) 
  641.  
  642. (defun incr-subnum nil (setq *subnum* (1+ *subnum*))) 
  643.  
  644. (defun cmp-ce nil
  645.   (prog (z)
  646.         (new-subnum 0.)
  647.         (setq *cur-vars* nil)
  648.         (setq z (lex))
  649.         (and (atom z)
  650.              (%error '|atomic conditions are not allowed| z))
  651.         (prepare-sublex z)
  652.    la   (and (end-of-ce) (return nil))
  653.         (incr-subnum)
  654.         (cmp-element)
  655.         (go la))) 
  656.  
  657. (defun cmp-element nil
  658.         (and (eq (peek-sublex) #\^) (cmp-tab))
  659.         (cond ((eq (peek-sublex) '#\{) (cmp-product))
  660.               (t (cmp-atomic-or-any))))
  661.  
  662. (defun cmp-atomic-or-any nil
  663.         (cond ((eq (peek-sublex) '<<) (cmp-any))
  664.               (t (cmp-atomic))))
  665.  
  666. (defun cmp-any nil
  667.   (prog (a z)
  668.         (sublex)
  669.         (setq z nil)
  670.    la   (cond ((end-of-ce) (%error '|missing '>>'| a)))
  671.         (setq a (sublex))
  672.         (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
  673.         (link-new-node (list '&any nil (current-field) z)))) 
  674.  
  675.  
  676. (defun cmp-tab nil
  677.   (prog (r)
  678.         (sublex)
  679.         (setq r (sublex))
  680.         (setq r ($litbind r))
  681.         (new-subnum r))) 
  682.  
  683. (defun $litbind (x)
  684.   (prog (r)
  685.         (cond ((and (symbolp x) (setq r (literal-binding-of x)))
  686.                (return r))
  687.               (t (return x))))) 
  688.  
  689. (defun get-bind (x)
  690.   (prog (r)
  691.         (cond ((and (symbolp x) (setq r (literal-binding-of x)))
  692.                (return r))
  693.               (t (return nil))))) 
  694.  
  695. (defun cmp-atomic nil
  696.   (prog (test x)
  697.         (setq x (peek-sublex))
  698.         (cond ((eq x '=) (setq test 'eq) (sublex))
  699.               ((eq x '<>) (setq test 'ne) (sublex))
  700.               ((eq x '<) (setq test 'lt) (sublex))
  701.               ((eq x '<=) (setq test 'le) (sublex))
  702.               ((eq x '>) (setq test 'gt) (sublex))
  703.               ((eq x '>=) (setq test 'ge) (sublex))
  704.               ((eq x '<=>) (setq test 'xx) (sublex))
  705.               (t (setq test 'eq)))
  706.         (cmp-symbol test))) 
  707.  
  708. (defun cmp-product nil
  709.   (prog (save)
  710.         (setq save (rest-of-ce))
  711.         (sublex)
  712.    la   (cond ((end-of-ce)
  713.                (cond ((member #\} save) 
  714.               (%error '|wrong contex for '}'| save))
  715.              (t (%error '|missing '}'| save))))
  716.               ((eq (peek-sublex) #\}) (sublex) (return nil)))
  717.         (cmp-atomic-or-any)
  718.         (go la))) 
  719.  
  720. (defun variablep (x) (and (symbolp x) (char-equal (char (symbol-name x) 0) #\<))) 
  721.  
  722. (defun cmp-symbol (test)
  723.   (prog (flag)
  724.         (setq flag t)
  725.         (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil)))
  726.         (cond ((and flag (variablep (peek-sublex)))
  727.                (cmp-var test))
  728.               ((numberp (peek-sublex)) (cmp-number test))
  729.               ((symbolp (peek-sublex)) (cmp-constant test))
  730.               (t (%error '|unrecognized symbol| (sublex)))))) 
  731.  
  732. (defun concat3(x y z)
  733.    (intern (format nil "~s~s~s" x y z)))
  734.  
  735. (defun cmp-constant (test)
  736.   (or (member test '(eq ne xx) )
  737.       (%error '|non-numeric constant after numeric predicate| (sublex)))
  738.   (link-new-node (list (concat3 't test 'a)
  739.                        nil
  740.                        (current-field)
  741.                        (sublex)))) 
  742.  
  743.  
  744. (defun cmp-number (test)
  745.   (link-new-node (list (concat3 't test 'n)
  746.                        nil
  747.                        (current-field)
  748.                        (sublex)))) 
  749.  
  750. (defun current-field nil (field-name *subnum*)) 
  751.  
  752. (defun field-name (num)
  753.   (cond ((= num 1.) '*c1*)
  754.         ((= num 2.) '*c2*)
  755.         ((= num 3.) '*c3*)
  756.         ((= num 4.) '*c4*)
  757.         ((= num 5.) '*c5*)
  758.         ((= num 6.) '*c6*)
  759.         ((= num 7.) '*c7*)
  760.         ((= num 8.) '*c8*)
  761.         ((= num 9.) '*c9*)
  762.         ((= num 10.) '*c10*)
  763.         ((= num 11.) '*c11*)
  764.         ((= num 12.) '*c12*)
  765.         ((= num 13.) '*c13*)
  766.         ((= num 14.) '*c14*)
  767.         ((= num 15.) '*c15*)
  768.         ((= num 16.) '*c16*)
  769.         ((= num 17.) '*c17*)
  770.         ((= num 18.) '*c18*)
  771.         ((= num 19.) '*c19*)
  772.         ((= num 20.) '*c20*)
  773.         ((= num 21.) '*c21*)
  774.         ((= num 22.) '*c22*)
  775.         ((= num 23.) '*c23*)
  776.         ((= num 24.) '*c24*)
  777.         ((= num 25.) '*c25*)
  778.         ((= num 26.) '*c26*)
  779.         ((= num 27.) '*c27*)
  780.         ((= num 28.) '*c28*)
  781.         ((= num 29.) '*c29*)
  782.         ((= num 30.) '*c30*)
  783.         ((= num 31.) '*c31*)
  784.         ((= num 32.) '*c32*)
  785.         ((= num 33.) '*c33*)
  786.         ((= num 34.) '*c34*)
  787.         ((= num 35.) '*c35*)
  788.         ((= num 36.) '*c36*)
  789.         ((= num 37.) '*c37*)
  790.         ((= num 38.) '*c38*)
  791.         ((= num 39.) '*c39*)
  792.         ((= num 40.) '*c40*)
  793.         ((= num 41.) '*c41*)
  794.         ((= num 42.) '*c42*)
  795.         ((= num 43.) '*c43*)
  796.         ((= num 44.) '*c44*)
  797.         ((= num 45.) '*c45*)
  798.         ((= num 46.) '*c46*)
  799.         ((= num 47.) '*c47*)
  800.         ((= num 48.) '*c48*)
  801.         ((= num 49.) '*c49*)
  802.         ((= num 50.) '*c50*)
  803.         ((= num 51.) '*c51*)
  804.         ((= num 52.) '*c52*)
  805.         ((= num 53.) '*c53*)
  806.         ((= num 54.) '*c54*)
  807.         ((= num 55.) '*c55*)
  808.         ((= num 56.) '*c56*)
  809.         ((= num 57.) '*c57*)
  810.         ((= num 58.) '*c58*)
  811.         ((= num 59.) '*c59*)
  812.         ((= num 60.) '*c60*)
  813.         ((= num 61.) '*c61*)
  814.         ((= num 62.) '*c62*)
  815.         ((= num 63.) '*c63*)
  816.         ((= num 64.) '*c64*)
  817.         (t (%error '|condition is too long| (rest-of-ce))))) 
  818.  
  819.  
  820. ;;; Compiling variables
  821. ;
  822. ;
  823. ;
  824. ; *cur-vars* are the variables in the condition element currently 
  825. ; being compiled.  *vars* are the variables in the earlier condition
  826. ; elements.  *ce-vars* are the condition element variables.  note
  827. ; that the interpreter will not confuse condition element and regular
  828. ; variables even if they have the same name.
  829. ;
  830. ; *cur-vars* is a list of triples: (name predicate subelement-number)
  831. ; eg:        ( (<x> eq 3)
  832. ;          (<y> ne 1)
  833. ;          . . . )
  834. ;
  835. ; *vars* is a list of triples: (name ce-number subelement-number)
  836. ; eg:        ( (<x> 3 3)
  837. ;          (<y> 1 1)
  838. ;          . . . )
  839. ;
  840. ; *ce-vars* is a list of pairs: (name ce-number)
  841. ; eg:        ( (ce1 1)
  842. ;          (<c3> 3)
  843. ;          . . . )
  844.  
  845. (defun var-dope (var) (assoc var *vars* :test #'eq))
  846.  
  847. (defun ce-var-dope (var) (assoc var *ce-vars* :test #'eq))
  848.  
  849. (defun cmp-var (test)
  850.   (prog (old name)
  851.         (setq name (sublex))
  852.         (setq old (assoc name *cur-vars* :test #'eq))
  853.         (cond ((and old (eq (cadr old) 'eq))
  854.                (cmp-old-eq-var test old))
  855.               ((and old (eq test 'eq)) (cmp-new-eq-var name old))
  856.               (t (cmp-new-var name test))))) 
  857.  
  858. (defun cmp-new-var (name test)
  859.   (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*))) 
  860.  
  861. (defun cmp-old-eq-var (test old)
  862.   (link-new-node (list (concat3 't test 's)
  863.                        nil
  864.                        (current-field)
  865.                        (field-name (caddr old))))) 
  866.  
  867. (defun cmp-new-eq-var (name old)
  868.   (prog (pred next)
  869.         (setq *cur-vars* (delete old *cur-vars* :test #'eq))
  870.         (setq next (assoc name *cur-vars* :test #'eq))
  871.         (cond (next (cmp-new-eq-var name next))
  872.               (t (cmp-new-var name 'eq)))
  873.         (setq pred (cadr old))
  874.         (link-new-node (list (concat3 't pred 's)
  875.                              nil
  876.                              (field-name (caddr old))
  877.                              (current-field))))) 
  878.  
  879. (defun cmp-cevar nil
  880.   (prog (name old)
  881.         (setq name (lex))
  882.         (setq old (assoc name *ce-vars* :test #'eq))
  883.         (and old
  884.              (%error '|condition element variable used twice| name))
  885.         (setq *ce-vars* (cons (list name 0.) *ce-vars*)))) 
  886.  
  887. (defun cmp-not nil (cmp-beta '¬)) 
  888.  
  889. (defun cmp-nobeta nil (cmp-beta nil)) 
  890.  
  891. (defun cmp-and nil (cmp-beta '&and)) 
  892.  
  893. (defun cmp-beta (kind)
  894.   (prog (tlist vdope vname vpred vpos old)
  895.         (setq tlist nil)
  896.    la   (and (atom *cur-vars*) (go lb))
  897.         (setq vdope (car *cur-vars*))
  898.         (setq *cur-vars* (cdr *cur-vars*))
  899.         (setq vname (car vdope))
  900.         (setq vpred (cadr vdope))
  901.         (setq vpos (caddr vdope))
  902.         (setq old (assoc vname *vars* :test #'eq))
  903.         (cond (old (setq tlist (add-test tlist vdope old)))
  904.               ((not (eq kind '¬)) (promote-var vdope)))
  905.         (go la)
  906.    lb   (and kind (build-beta kind tlist))
  907.         (or (eq kind '¬) (fudge))
  908.         (setq *last-branch* *last-node*))) 
  909.  
  910. (defun add-test (list new old)
  911.   (prog (ttype lloc rloc)
  912.     (setq *feature-count* (1+ *feature-count*))
  913.         (setq ttype (concat3 't (cadr new) 'b))
  914.         (setq rloc (encode-singleton (caddr new)))
  915.         (setq lloc (encode-pair (cadr old) (caddr old)))
  916.         (return (cons ttype (cons lloc (cons rloc list)))))) 
  917.  
  918.