home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume12 / ops5 / part05 < prev    next >
Encoding:
Internet Message Format  |  1987-10-12  |  22.2 KB
  1. Subject:  v12i020:  OPS5 in Common Lisp, Part05/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 20
  8. Archive-name: ops5/part05
  9.  
  10. ;;; printing production memory
  11.  
  12. (defmacro pm (&rest z)  `(progn (mapc #'pprule ',z) (terpri) nil)) 
  13.  
  14. ;Major modification here, because Common Lisp doesn't have a standard method
  15. ;for determining the column position of the cursor.  So we have to keep count.
  16. ;So colprinc records the current column number and prints the symbol.
  17.  
  18. (proclaim '(special *current-col*))
  19. (setq *current-col* 0)
  20.  
  21. (defun nflatc(x)
  22.    (length (princ-to-string x)))
  23.  
  24. (defun colprinc(x)
  25.     (setq *current-col* (+ *current-col* (nflatc x)))
  26.     (princ x))
  27.  
  28. (defun pprule (name)
  29.   (prog (matrix next lab)
  30.         (terpri)
  31.         (setq *current-col* 0)
  32.         (and (not (symbolp name)) (return nil))
  33.         (setq matrix (get name 'production))
  34.     (and (null matrix) (return nil))
  35.     (terpri)
  36.     (colprinc '|(p |)
  37.     (colprinc name)
  38.    top    (and (atom matrix) (go fin))
  39.         (setq next (car matrix))
  40.     (setq matrix (cdr matrix))
  41.     (setq lab nil)
  42.     (terpri)
  43.     (cond ((eq next '-)
  44.            (colprinc '|  - |)
  45.            (setq next (car matrix))
  46.            (setq matrix (cdr matrix)))
  47.           ((eq next '-->)
  48.            (colprinc '|  |))
  49.           ((and (eq next '{) (atom (car matrix)))
  50.            (colprinc '|   {|)
  51.            (setq lab (car matrix))
  52.            (setq next (cadr matrix))
  53.            (setq matrix (cdddr matrix)))
  54.           ((eq next '{)
  55.            (colprinc '|   {|)
  56.            (setq lab (cadr matrix))
  57.            (setq next (car matrix))
  58.            (setq matrix (cdddr matrix)))
  59.           (t (colprinc '|    |)))
  60.         (ppline next)
  61.     (cond (lab (colprinc '| |) (colprinc lab) (colprinc '})))
  62.     (go top)
  63.     fin    (colprinc '|)|)))
  64.  
  65. (defun ppline (line)
  66.   (prog ()
  67.     (cond ((atom line) (colprinc line))
  68.               ((equalp (symbol-name (car line)) "DISPLACED") ;don't print expanded macros
  69.                (ppline (cadr line)))
  70.           (t
  71.            (colprinc '|(|)
  72.            (setq *ppline* line)
  73.            (ppline2)
  74.            (colprinc '|)|)))
  75.         (return nil)))
  76.  
  77. (defun ppline2 ()
  78.   (prog (needspace)
  79.         (setq needspace nil)
  80.    top  (and (atom *ppline*) (return nil))
  81.         (and needspace (colprinc '| |))
  82.         (cond ((eq (car *ppline*) #\^) (ppattval))
  83.           (t (pponlyval)))
  84.         (setq needspace t)
  85.         (go top)))
  86.  
  87. ;NWRITN, sort of. 
  88. (defun nwritn(&optional port)
  89.    (- 76 *current-col*))
  90.  
  91. (defun ppattval ()
  92.   (prog (att val)
  93.         (setq att (cadr *ppline*))
  94.     (setq *ppline* (cddr *ppline*))
  95.     (setq val (getval))
  96.     (cond ((> (+ (nwritn) (nflatc att) (nflatc val)) 76.)
  97.            (terpri)
  98.            (colprinc '|        |)))
  99.         (colprinc '^)
  100.     (colprinc att)
  101.     (mapc (function (lambda (z) (colprinc '| |) (colprinc z))) val)))
  102.  
  103. (defun pponlyval ()
  104.   (prog (val needspace)
  105.     (setq val (getval))
  106.     (setq needspace nil)
  107.     (cond ((> (+ (nwritn) (nflatc val)) 76.)
  108.            (setq needspace nil)
  109.            (terpri)
  110.            (colprinc '|        |)))
  111.     top    (and (atom val) (return nil))
  112.         (and needspace (colprinc '| |))
  113.     (setq needspace t)
  114.     (colprinc (car val))
  115.     (setq val (cdr val))
  116.     (go top)))
  117.  
  118. (defun getval ()
  119.   (prog (res v1)
  120.         (setq v1 (car *ppline*))
  121.     (setq *ppline* (cdr *ppline*))
  122.     (cond ((member v1 '(= <> < <= => > <=>) :test #'eq)
  123.            (setq res (cons v1 (getval))))
  124.           ((eq v1 '{)
  125.            (setq res (cons v1 (getupto '}))))
  126.           ((eq v1 '<<)
  127.            (setq res (cons v1 (getupto '>>))))
  128.           ((eq v1 '//)
  129.            (setq res (list v1 (car *ppline*)))
  130.            (setq *ppline* (cdr *ppline*)))
  131.           (t (setq res (list v1))))
  132.         (return res)))
  133.  
  134. (defun getupto (end)
  135.   (prog (v)
  136.         (and (atom *ppline*) (return nil))
  137.     (setq v (car *ppline*))
  138.     (setq *ppline* (cdr *ppline*))
  139.     (cond ((eq v end) (return (list v)))
  140.           (t (return (cons v (getupto end))))))) 
  141.  
  142.  
  143.  
  144.  
  145.  
  146.  
  147. ;;; backing up
  148.  
  149.  
  150.  
  151. (defun record-index-plus (k)
  152.   (setq *record-index* (+ k *record-index*))
  153.   (cond ((< *record-index* 0.)
  154.          (setq *record-index* *max-record-index*))
  155.         ((> *record-index* *max-record-index*)
  156.          (setq *record-index* 0.)))) 
  157.  
  158. ; the following routine initializes the record.  putting nil in the
  159. ; first slot indicates that that the record does not go back further
  160. ; than that.  (when the system backs up, it writes nil over the used
  161. ; records so that it will recognize which records it has used.  thus
  162. ; the system is set up anyway never to back over a nil.)
  163.  
  164. (defun initialize-record nil
  165.   (setq *record-index* 0.)
  166.   (setq *recording* nil)
  167.   (setq *max-record-index* 31.)
  168.   (putvector *record-array* 0. nil)) 
  169.  
  170. ; *max-record-index* holds the maximum legal index for record-array
  171. ; so it and the following must be changed at the same time
  172.  
  173. (defun begin-record (p data)
  174.   (setq *recording* t)
  175.   (setq *record* (list '=>refract p data))) 
  176.  
  177. (defun end-record nil
  178.   (cond (*recording*
  179.          (setq *record*
  180.                (cons *cycle-count* (cons *p-name* *record*)))
  181.          (record-index-plus 1.)
  182.          (putvector *record-array* *record-index* *record*)
  183.          (setq *record* nil)
  184.          (setq *recording* nil)))) 
  185.  
  186. (defun record-change (direct time elm)
  187.   (cond (*recording*
  188.          (setq *record*
  189.                (cons direct (cons time (cons elm *record*))))))) 
  190.  
  191. ; to maintain refraction information, need keep only one piece of information:
  192. ; need to record all unsuccessful attempts to delete things from the conflict
  193. ; set.  unsuccessful deletes are caused by attempting to delete refracted
  194. ; instantiations.  when backing up, have to avoid putting things back into the
  195. ; conflict set if they were not deleted when running forward
  196.  
  197. (defun record-refract (rule data)
  198.   (and *recording*
  199.        (setq *record* (cons '<=refract (cons rule (cons data *record*))))))
  200.  
  201. (defun refracted (rule data)
  202.   (prog (z)
  203.         (and (null *refracts*) (return nil))
  204.     (setq z (cons rule data))
  205.     (return (member z *refracts*))))
  206.  
  207. (defun back (k)
  208.   (prog (r)
  209.    l   (and (< k 1.) (return nil))
  210.         (setq r (getvector *record-array* *record-index*))
  211.         (and (null r) (return '|nothing more stored|))
  212.         (putvector *record-array* *record-index* nil)
  213.         (record-index-plus -1.)
  214.         (undo-record r)
  215.         (setq k (1- k))
  216.         (go l))) 
  217.  
  218. (defun undo-record (r)
  219.   (prog (save act a b rate)
  220.         ;*recording* must be off during back up
  221.         (setq save *recording*)
  222.         (setq *refracts* nil)
  223.         (setq *recording* nil)
  224.         (and *ptrace* (back-print (list 'undo (car r) (cadr r))))
  225.         (setq r (cddr r))
  226.    top  (and (atom r) (go fin))
  227.         (setq act (car r))
  228.         (setq a (cadr r))
  229.         (setq b (caddr r))
  230.         (setq r (cdddr r))
  231.         (and *wtrace* (back-print (list 'undo act a)))
  232.         (cond ((eq act '<=wm) (add-to-wm b a))
  233.               ((eq act '=>wm) (remove-from-wm b))
  234.               ((eq act '<=refract)
  235.                (setq *refracts* (cons (cons a b) *refracts*)))
  236.               ((and (eq act '=>refract) (still-present b))
  237.            (setq *refracts* (delete (cons a b) *refracts*))
  238.                (setq rate (rating-part (get a 'topnode)))
  239.                (removecs a b)
  240.                (insertcs a b rate))
  241.               (t (%warn '|back: cannot undo action| (list act a))))
  242.         (go top)
  243.    fin  (setq *recording* save)
  244.         (setq *refracts* nil)
  245.         (return nil))) 
  246.  
  247. ; still-present makes sure that the user has not deleted something
  248. ; from wm which occurs in the instantiation about to be restored; it
  249. ; makes the check by determining whether each wme still has a time tag.
  250.  
  251. (defun still-present (data)
  252.   (prog nil
  253.    l   (cond ((atom data) (return t))
  254.               ((creation-time (car data))
  255.                (setq data (cdr data))
  256.                (go l))
  257.               (t (return nil))))) 
  258.  
  259.  
  260. (defun back-print (x) 
  261.   (prog (port)
  262.         (setq port (trace-file))
  263.         (terpri port)
  264.     (print x port)))
  265.  
  266.  
  267.  
  268.  
  269. ;;; Functions to show how close rules are to firing
  270.  
  271. (defmacro matches (&rest rule-list)
  272.   `(progn 
  273.     (mapc (function matches2) ',rule-list)
  274.     (terpri)) )
  275.  
  276. (defun matches2 (p)
  277.   (cond ((atom p)
  278.          (terpri)
  279.          (terpri)
  280.          (princ p)
  281.          (matches3 (get p 'backpointers) 2. (cons 1. nil))))) 
  282.  
  283. (defun matches3 (nodes ce part)
  284.   (cond ((not (null nodes))
  285.          (terpri)
  286.          (princ '| ** matches for |)
  287.          (princ part)
  288.          (princ '| ** |)
  289.          (mapc (function write-elms) (find-left-mem (car nodes)))
  290.          (terpri)
  291.          (princ '| ** matches for |)
  292.          (princ (cons ce nil))
  293.          (princ '| ** |)
  294.          (mapc (function write-elms) (find-right-mem (car nodes)))
  295.          (matches3 (cdr nodes) (1+ ce) (cons ce part))))) 
  296.  
  297. (defun write-elms (wme-or-count)
  298.   (cond ((listp wme-or-count)
  299.      (terpri)
  300.      (mapc (function write-elms2) wme-or-count)))) 
  301.  
  302. (defun write-elms2 (x)
  303.   (princ '|  |)
  304.   (princ (creation-time x)))
  305.  
  306. (defun find-left-mem (node)
  307.   (cond ((eq (car node) '&and) (memory-part (caddr node)))
  308.         (t (car (caddr node))))) 
  309.  
  310. (defun find-right-mem (node) (memory-part (cadddr node))) 
  311.  
  312.  
  313. ;;; Check the RHSs of productions 
  314.  
  315.  
  316. (defun check-rhs (rhs) (mapc (function check-action) rhs))
  317.  
  318. (defun check-action (x)
  319.   (prog (a)
  320.     (cond ((atom x)
  321.            (%warn '|atomic action| x)
  322.        (return nil)))
  323.     (setq a  (car x))
  324.     (cond ((eq a 'bind) (check-bind x))
  325.           ((eq a 'cbind) (check-cbind x))
  326.           ((eq a 'make) (check-make x))
  327.           ((eq a 'modify) (check-modify x))
  328.           ((eq a 'oremove) (check-remove x))
  329.           ((eq a 'owrite) (check-write x))
  330.           ((eq a 'ocall) (check-call x))
  331.           ((eq a 'halt) (check-halt x))
  332.           ((eq a 'openfile) (check-openfile x))
  333.           ((eq a 'closefile) (check-closefile x))
  334.           ((eq a 'default) (check-default x))
  335.           ((eq a 'build) (check-build x))
  336.           ;;the following section is responsible for replacing standard ops RHS actions
  337.           ;;with actions which don't conflict with existing CL functions.  The RPLACA function
  338.           ;;is used so that the change will be reflected in the production body.
  339.           ((eq a 'remove) (rplaca x 'oremove) 
  340.                           (check-remove x))
  341.           ((eq a 'write)   (rplaca x 'owrite)
  342.                           (check-write x)) 
  343.           ((eq a 'call)   (rplaca x 'ocall)
  344.                           (check-call x))
  345.           (t (%warn '|undefined rhs action| a))))) 
  346.  
  347. (defun check-build (z)
  348.   (and (null (cdr z)) (%warn '|needs arguments| z))
  349.   (check-build-collect (cdr z)))
  350.  
  351. (defun check-build-collect (args)
  352.   (prog (r)
  353.     top    (and (null args) (return nil))
  354.     (setq r (car args))
  355.     (setq args (cdr args))
  356.     (cond ((listp r) (check-build-collect r))
  357.           ((eq r '\\)
  358.            (and (null args) (%warn '|nothing to evaluate| r))
  359.            (check-rhs-value (car args))
  360.            (setq args (cdr args))))
  361.     (go top)))
  362.  
  363. (defun check-remove (z) 
  364.   (and (null (cdr z)) (%warn '|needs arguments| z))
  365.   (mapc (function check-rhs-ce-var) (cdr z))) 
  366.  
  367. (defun check-make (z)
  368.   (and (null (cdr z)) (%warn '|needs arguments| z))
  369.   (check-change& (cdr z))) 
  370.  
  371. (defun check-openfile (z)
  372.   (and (null (cdr z)) (%warn '|needs arguments| z))
  373.   (check-change& (cdr z))) 
  374.  
  375. (defun check-closefile (z)
  376.   (and (null (cdr z)) (%warn '|needs arguments| z))
  377.   (check-change& (cdr z))) 
  378.  
  379. (defun check-default (z)
  380.   (and (null (cdr z)) (%warn '|needs arguments| z))
  381.   (check-change& (cdr z))) 
  382.  
  383. (defun check-modify (z)
  384.   (and (null (cdr z)) (%warn '|needs arguments| z))
  385.   (check-rhs-ce-var (cadr z))
  386.   (and (null (cddr z)) (%warn '|no changes to make| z))
  387.   (check-change& (cddr z))) 
  388.  
  389. (defun check-write (z)
  390.   (and (null (cdr z)) (%warn '|needs arguments| z))
  391.   (check-change& (cdr z))) 
  392.  
  393. (defun check-call (z)
  394.   (prog (f)
  395.     (and (null (cdr z)) (%warn '|needs arguments| z))
  396.     (setq f (cadr z))
  397.     (and (variablep f)
  398.          (%warn '|function name must be a constant| z))
  399.     (or (symbolp f)
  400.         (%warn '|function name must be a symbolic atom| f))
  401.     (or (externalp f)
  402.         (%warn '|function name not declared external| f))
  403.     (check-change& (cddr z)))) 
  404.  
  405. (defun check-halt (z)
  406.   (or (null (cdr z)) (%warn '|does not take arguments| z))) 
  407.  
  408. (defun check-cbind (z)
  409.   (prog (v)
  410.     (or (= (length z) 2.) (%warn '|takes only one argument| z))
  411.     (setq v (cadr z))
  412.     (or (variablep v) (%warn '|takes variable as argument| z))
  413.     (note-ce-variable v))) 
  414.  
  415. (defun check-bind (z)
  416.   (prog (v)
  417.     (or (> (length z) 1.) (%warn '|needs arguments| z))
  418.     (setq v (cadr z))
  419.     (or (variablep v) (%warn '|takes variable as argument| z))
  420.     (note-variable v)
  421.     (check-change& (cddr z)))) 
  422.  
  423.  
  424. (defun check-change& (z)
  425.   (prog (r tab-flag)
  426.         (setq tab-flag nil)
  427.    la   (and (atom z) (return nil))
  428.         (setq r (car z))
  429.         (setq z (cdr z))
  430.         (cond ((eq r #\^)
  431.                (and tab-flag
  432.                     (%warn '|no value before this tab| (car z)))
  433.                (setq tab-flag t)
  434.                (check-tab-index (car z))
  435.                (setq z (cdr z)))
  436.               ((eq r '//) (setq tab-flag nil) (setq z (cdr z)))
  437.               (t (setq tab-flag nil) (check-rhs-value r)))
  438.         (go la))) 
  439.  
  440. (defun check-rhs-ce-var (v)
  441.   (cond ((and (not (numberp v)) (not (ce-bound? v)))
  442.          (%warn '|unbound element variable| v))
  443.         ((and (numberp v) (or (< v 1.) (> v *ce-count*)))
  444.          (%warn '|numeric element designator out of bounds| v)))) 
  445.  
  446. (defun check-rhs-value (x)
  447.   (cond ((and x (listp x)) (check-rhs-function x))
  448.         (t (check-rhs-atomic x)))) 
  449.  
  450. (defun check-rhs-atomic (x)
  451.   (and (variablep x) 
  452.        (not (bound? x)) 
  453.        (%warn '|unbound variable| x)))
  454.  
  455. (defun check-rhs-function (x)
  456.   (prog (a)
  457.     (setq a (car x))
  458.     (cond ((eq a 'compute) (check-compute x))
  459.           ((eq a 'arith) (check-compute x))
  460.           ((eq a 'substr) (check-substr x))
  461.           ((eq a 'accept) (check-accept x))
  462.           ((eq a 'acceptline) (check-acceptline x))
  463.           ((eq a 'crlf) (check-crlf x))
  464.           ((eq a 'genatom) (check-genatom x))
  465.       ((eq a 'litval) (check-litval x))
  466.           ((eq a 'tabto) (check-tabto x))
  467.       ((eq a 'rjust) (check-rjust x))
  468.       ((not (externalp a))
  469.        (%warn '"rhs function not declared external" a)))))
  470.  
  471. (defun check-litval (x) 
  472.   (or (= (length x) 2) (%warn '|wrong number of arguments| x))
  473.   (check-rhs-atomic (cadr x)))
  474.  
  475. (defun check-accept (x)
  476.   (cond ((= (length x) 1) nil)
  477.         ((= (length x) 2) (check-rhs-atomic (cadr x)))
  478.     (t (%warn '|too many arguments| x))))
  479.  
  480. (defun check-acceptline (x)
  481.   (mapc (function check-rhs-atomic) (cdr x)))
  482.  
  483. (defun check-crlf (x) 
  484.   (check-0-args x)) 
  485.  
  486. (defun check-genatom (x) (check-0-args x)) 
  487.  
  488. (defun check-tabto (x)
  489.   (or (= (length x) 2) (%warn '|wrong number of arguments| x))
  490.   (check-print-control (cadr x)))
  491.  
  492. (defun check-rjust (x)
  493.   (or (= (length x) 2) (%warn '|wrong number of arguments| x))
  494.   (check-print-control (cadr x)))
  495.  
  496. (defun check-0-args (x)
  497.   (or (= (length x) 1.) (%warn '|should not have arguments| x))) 
  498.  
  499. (defun check-substr (x)
  500.   (or (= (length x) 4.) (%warn '|wrong number of arguments| x))
  501.   (check-rhs-ce-var (cadr x))
  502.   (check-substr-index (caddr x))
  503.   (check-last-substr-index (cadddr x))) 
  504.  
  505. (defun check-compute (x) (check-arithmetic (cdr x))) 
  506.  
  507. (defun check-arithmetic (l)
  508.   (cond ((atom l)
  509.          (%warn '|syntax error in arithmetic expression| l))
  510.         ((atom (cdr l)) (check-term (car l)))
  511.         ((not (member (cadr l) '(+ - * // \\) :test #'eq))
  512.          (%warn '|unknown operator| l))
  513.         (t (check-term (car l)) (check-arithmetic (cddr l))))) 
  514.  
  515. (defun check-term (x)
  516.   (cond ((listp x) (check-arithmetic x))
  517.         (t (check-rhs-atomic x)))) 
  518.  
  519. (defun check-last-substr-index (x)
  520.   (or (eq x 'inf) (check-substr-index x))) 
  521.  
  522. (defun check-substr-index (x)
  523.   (prog (v)
  524.     (cond ((bound? x) (return x)))
  525.     (setq v ($litbind x))
  526.     (cond ((not (numberp v))
  527.            (%warn '|unbound symbol used as index in substr| x))
  528.           ((or (< v 1.) (> v 127.))
  529.            (%warn '|index out of bounds in tab| x))))) 
  530.  
  531. (defun check-print-control (x)
  532.   (prog ()
  533.     (cond ((bound? x) (return x)))
  534.     (cond ((or (not (numberp x)) (< x 1.) (> x 127.))
  535.            (%warn '|illegal value for printer control| x))))) 
  536.  
  537. (defun check-tab-index (x)
  538.   (prog (v)
  539.     (cond ((bound? x) (return x)))
  540.     (setq v ($litbind x))
  541.     (cond ((not (numberp v))
  542.            (%warn '|unbound symbol occurs after ^| x))
  543.           ((or (< v 1.) (> v 127.))
  544.            (%warn '|index out of bounds after ^| x))))) 
  545.  
  546. (defun note-variable (var)
  547.   (setq *rhs-bound-vars* (cons var *rhs-bound-vars*)))
  548.  
  549. (defun bound? (var)
  550.   (or (member var *rhs-bound-vars* :test #'eq)
  551.       (var-dope var)))
  552.  
  553. (defun note-ce-variable (ce-var)
  554.   (setq *rhs-bound-ce-vars* (cons ce-var *rhs-bound-ce-vars*)))
  555.  
  556. (defun ce-bound? (ce-var)
  557.   (or (member ce-var *rhs-bound-ce-vars* :test #'eq)
  558.       (ce-var-dope ce-var)))
  559.  
  560. ;;; Top level routines
  561.  
  562. (defun process-changes (adds dels)
  563.   (prog (x)
  564.    process-deletes (and (atom dels) (go process-adds))
  565.         (setq x (car dels))
  566.         (setq dels (cdr dels))
  567.         (remove-from-wm x)
  568.         (go process-deletes)
  569.    process-adds (and (atom adds) (return nil))
  570.         (setq x (car adds))
  571.         (setq adds (cdr adds))
  572.         (add-to-wm x nil)
  573.         (go process-adds))) 
  574.  
  575. (defun main nil
  576.   (prog (instance r)
  577.         (setq *halt-flag* nil)
  578.         (setq *break-flag* nil)
  579.         (setq instance nil)
  580.    dil  (setq *phase* 'conflict-resolution)
  581.         (cond (*halt-flag*
  582.                (setq r '|end -- explicit halt|)
  583.                (go finis))
  584.           ((zerop *remaining-cycles*)
  585.            (setq r '***break***)
  586.            (setq *break-flag* t)
  587.            (go finis))
  588.               (*break-flag* (setq r '***break***) (go finis)))
  589.     (setq *remaining-cycles* (1- *remaining-cycles*))
  590.         (setq instance (conflict-resolution))
  591.         (cond ((not instance)
  592.                (setq r '|end -- no production true|)
  593.                (go finis)))
  594.         (setq *phase* (car instance))
  595.         (accum-stats)
  596.         (eval-rhs (car instance) (cdr instance))
  597.         (check-limits)
  598.     (and (broken (car instance)) (setq *break-flag* t))
  599.         (go dil)
  600.   finis (setq *p-name* nil)
  601.         (return r))) 
  602.  
  603. (defun do-continue (wmi)
  604.     (cond (*critical*
  605.            (terpri)
  606.            (princ '|warning: network may be inconsistent|)))
  607.     (process-changes wmi nil)
  608.     (print-times (main))) 
  609.  
  610. (defun accum-stats nil
  611.   (setq *cycle-count* (1+ *cycle-count*))
  612.   (setq *total-token* (+ *total-token* *current-token*))
  613.   (cond ((> *current-token* *max-token*)
  614.          (setq *max-token* *current-token*)))
  615.   (setq *total-wm* (+ *total-wm* *current-wm*))
  616.   (cond ((> *current-wm* *max-wm*) (setq *max-wm* *current-wm*)))) 
  617.  
  618.  
  619. (defun print-times (mess)
  620.   (prog (cc ac)
  621.         (cond (*break-flag* (terpri) (return mess)))
  622.         (setq cc (+ (float *cycle-count*) 1.0e-20))
  623.         (setq ac (+ (float *action-count*) 1.0e-20))
  624.         (terpri)
  625.         (princ mess)
  626.         (pm-size)
  627.         (printlinec (list *cycle-count*
  628.                           'firings
  629.                           (list *action-count* 'rhs 'actions)))
  630.         (terpri)
  631.         (printlinec (list (round (/ (float *total-wm*) cc))
  632.                           'mean 'working 'memory 'size
  633.                           (list *max-wm* 'maximum)))
  634.         (terpri)
  635.         (printlinec (list (round (/ (float *total-cs*) cc))
  636.                           'mean 'conflict 'set 'size
  637.                           (list *max-cs* 'maximum)))
  638.         (terpri)
  639.         (printlinec (list (round (/ (float *total-token*) cc))
  640.                           'mean 'token 'memory 'size
  641.                           (list *max-token* 'maximum)))
  642.         (terpri))) 
  643.  
  644. (defun pm-size nil
  645.   (terpri)
  646.   (printlinec (list *pcount*
  647.                     'productions
  648.                     (list *real-cnt* '// *virtual-cnt* 'nodes)))
  649.   (terpri)) 
  650.  
  651. (defun check-limits nil
  652.   (cond ((> (length *conflict-set*) *limit-cs*)
  653.          (terpri)
  654.          (terpri)
  655.          (printlinec (list '|conflict set size exceeded the limit of|
  656.                            *limit-cs*
  657.                            '|after|
  658.                            *p-name*))
  659.          (setq *halt-flag* t)))
  660.   (cond ((> *current-token* *limit-token*)
  661.          (terpri)
  662.          (terpri)
  663.          (printlinec (list '|token memory size exceeded the limit of|
  664.                            *limit-token*
  665.                            '|after|
  666.                            *p-name*))
  667.          (setq *halt-flag* t)))) 
  668.  
  669.  
  670. (defun top-level-remove (z)
  671.   (cond ((equal z '(*)) (process-changes nil (get-wm nil)))
  672.         (t (process-changes nil (get-wm z))))) 
  673.  
  674. (defmacro excise (&rest z) `(mapc (function excise-p) ',z))
  675.  
  676. (defmacro run (&rest z)
  677.   `(cond ((null ',z) (setq *remaining-cycles* 1000000.) (do-continue nil))
  678.         ((and (atom (cdr ',z)) (numberp (car ',z)) (> (car ',z) 0.))
  679.          (setq *remaining-cycles* (car ',z))
  680.          (do-continue nil))
  681.         (t 'what\?))) 
  682.  
  683. (defmacro strategy (&rest z)
  684.   `(cond ((atom ',z) *strategy*)
  685.         ((equal ',z '(lex)) (setq *strategy* 'lex))
  686.         ((equal ',z '(mea)) (setq *strategy* 'mea))
  687.         (t 'what\?))) 
  688.  
  689. (defmacro cs (&optional z)
  690.   `(cond ((null ',z) (conflict-set))
  691.         (t 'what?))) 
  692.  
  693. (defmacro watch (&rest z)
  694.   `(cond ((equal ',z '(0.))
  695.          (setq *wtrace* nil)
  696.          (setq *ptrace* nil)
  697.          0.)
  698.         ((equal ',z '(1.)) (setq *wtrace* nil) (setq *ptrace* t) 1.)
  699.         ((equal ',z '(2.)) (setq *wtrace* t) (setq *ptrace* t) 2.)
  700.         ((equal ',z '(3.))
  701.          (setq *wtrace* t)
  702.          (setq *ptrace* t)
  703.          '(2. -- conflict set trace not supported))
  704.         ((and (atom ',z) (null *ptrace*)) 0.)
  705.         ((and (atom ',z) (null *wtrace*)) 1.)
  706.         ((atom ',z) 2.)
  707.         (t 'what\?))) 
  708.  
  709. (defmacro external  (&rest z) `(catch (external2 ',z) '!error!))
  710.  
  711. (defun external2 (z) (mapc (function external3) z))
  712.  
  713. (defun external3 (x) 
  714.   (cond ((symbolp x) (putprop x t 'external-routine)
  715.              (setq *externals* (enter x *externals*)))
  716.     (t (%error '|not a legal function name| x))))
  717.  
  718. (defun externalp (x)
  719.   (cond ((symbolp x) (get x 'external-routine))
  720.     (t (%warn '|not a legal function name| x) nil)))
  721.  
  722. (defmacro pbreak (&rest z)
  723.   `(cond ((atom ',z) (terpri) *brkpts*)
  724.     (t (mapc (function pbreak2) ',z) nil)))
  725.  
  726. (defun pbreak2 (rule)
  727.   (cond ((not (symbolp rule)) (%warn '|illegal name| rule))
  728.     ((not (get rule 'topnode)) (%warn '|not a production| rule))
  729.     ((member rule *brkpts* :test #'eq) (setq *brkpts* (rematm rule *brkpts*)))
  730.     (t (setq *brkpts* (cons rule *brkpts*)))))
  731.  
  732. (defun rematm (atm list)
  733.   (cond ((atom list) list)
  734.     ((eq atm (car list)) (rematm atm (cdr list)))
  735.     (t (cons (car list) (rematm atm (cdr list))))))
  736.  
  737. (defun broken (rule) (member rule *brkpts* :test #'eq))
  738.  
  739.