home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / o / ops5.zip / OPS-RHS.LIS < prev    next >
Lisp/Scheme  |  1992-03-06  |  17KB  |  647 lines
  1. ;
  2. ;************************************************************************
  3. ;
  4. ;    VPS2 -- Interpreter for OPS5
  5. ;
  6. ;
  7. ;
  8. ; This Common Lisp version of OPS5 is in the public domain.  It is based
  9. ; in part on based on a Franz Lisp implementation done by Charles L. Forgy
  10. ; at Carnegie-Mellon University, which was placed in the public domain by
  11. ; the author in accordance with CMU policies.  This version has been
  12. ; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
  13. ; and Dan Kuokka.
  14. ;
  15. ; This code is made available is, and without warranty of any kind by the
  16. ; authors or by Carnegie-Mellon University.
  17. ;
  18.  
  19. ;;;; This file contains all the functions necessary for RHS actions
  20. ;;;; including $actions.
  21.  
  22. (in-package "OPS")
  23. (shadow '(remove write))
  24. (export '(remove write make modify crlf))
  25.  
  26.  
  27. (proclaim '(special *ptrace* *cycle-count* *halt-flag* *wtrace*))
  28.  
  29.  
  30. ;;; External global variables
  31.  
  32. (defvar *size-result-array*)
  33. (defvar *in-rhs*)
  34. (defvar *current-wm*)
  35. (defvar *max-wm*)
  36. (defvar *action-count*)
  37. (defvar *critical*)
  38.  
  39.  
  40. ;;; Internal global variables
  41.  
  42. (defvar *wmpart-list*)
  43. (defvar *wm-filter*)
  44. (defvar *wm*)
  45. (defvar *old-wm*)
  46. (defvar *result-array*)
  47. (defvar *variable-memory*)
  48. (defvar *last*)
  49. (defvar *max-index*)
  50. (defvar *next-index*)
  51. (defvar *data-matched*)
  52. (defvar *ce-variable-memory*)
  53. (defvar *rest*)
  54. (defvar *build-trace*)
  55.  
  56.  
  57. ;;;; Functions for RHS evaluation
  58.  
  59. (defun rhs-init ()
  60.   ; if the size of result-array changes, change the line in i-g-v which
  61.   ; sets the value of *size-result-array*
  62.   (setq *size-result-array* 255.)                             ;255 /256 set by gdw
  63.   (setq *result-array* (make-array 256 :initial-element nil))  ;jgk
  64.   (setq *in-rhs* nil)
  65.   (setq *build-trace* nil)
  66.   (setq *max-wm* (setq *current-wm* 0.))
  67.   (setq *action-count* 0.)
  68.   (setq *critical* nil)
  69.   (setq *wmpart-list* nil))
  70.  
  71.  
  72. (defun eval-rhs (pname data)
  73.   (prog (node port)
  74.     (cond (*ptrace*
  75.        (setq port (trace-file))
  76.        (terpri port)
  77.        (princ *cycle-count* port)
  78.        (princ '|. | port)
  79.        (princ pname port)
  80.        (time-tag-print data port)))
  81.     (setq *data-matched* data)
  82.     (setq *p-name* pname)
  83.     (setq *last* nil)
  84.     (setq node (get pname 'topnode))
  85.     (init-var-mem (var-part node))
  86.     (init-ce-var-mem (ce-var-part node))
  87.     (begin-record pname data)
  88.     (setq *in-rhs* t)
  89.     (eval (rhs-part node))
  90.     (setq *in-rhs* nil)
  91.     (end-record))) 
  92.  
  93.  
  94. (defun eval-args (z)
  95.   (prog (r)
  96.     (rhs-tab 1.)
  97.     la   (and (atom z) (return nil))
  98.     (setq r (car z))
  99.     (setq z (cdr z))
  100.     (cond ((EQ R '^)
  101.        (RHS-tab (car z))
  102.        (setq r (cadr z))
  103.        (setq z (cddr z))))
  104.     (cond ((eq r '//) ($value (car z)) (setq z (cdr z)))
  105.       (t ($change r)))
  106.     (go la))) 
  107.  
  108.  
  109.  
  110. ;;;; RHS actions
  111. ;;;; Some of these can be called at the top level.
  112.  
  113. (defmacro make (&body z)
  114.   `(ops-make ',z))
  115.  
  116. (defmacro remove (&body z)
  117.   `(ops-remove ',z))
  118.  
  119. (defmacro modify (&body z)
  120.   `(ops-modify ',z))
  121.  
  122. (defmacro openfile (&body z)
  123.   `(ops-openfile ',z))
  124.  
  125. (defmacro closefile (&body z)
  126.   `(ops-closefile ',z))
  127.  
  128. (defmacro default (&body z)
  129.   `(ops-default ',z))
  130.  
  131. (defmacro write (&body z)
  132.   `(ops-write ',z))
  133.  
  134. (defmacro crlf (&body z)
  135.   `(ops-crlf ',z))
  136.  
  137. (defmacro tabto (&body z)
  138.   `(ops-tabto ',z))
  139.  
  140. (defmacro rjust (&body z)
  141.   `(ops-rjust ',z))
  142.  
  143. (defmacro call (&body z)
  144.   `(ops-call ',z))
  145.  
  146. (defmacro bind (&body z)
  147.   `(ops-bind ',z))
  148.  
  149. (defmacro cbind (&body z)
  150.   `(ops-cbind ',z))
  151.  
  152. (defmacro build (&body z)
  153.   `(ops-build ',z))
  154.  
  155. (defmacro substr (&body l)
  156.   `(ops-substr ',l))
  157.  
  158. (defmacro compute (&body z)
  159.   `(ops-compute ',z))
  160.  
  161. (defmacro litval (&body z)
  162.   `(ops-litval ',z))
  163.  
  164. (defmacro accept (&body z)
  165.   `(ops-accept ',z))
  166.  
  167. (defmacro acceptline (&body z)
  168.   `(ops-acceptline ',z))
  169.  
  170. (defmacro arith (&body z)
  171.   `(ops-arith ',z))
  172.  
  173.  
  174. (defun ops-make (z)
  175.   (prog nil
  176.     ($reset)
  177.     (eval-args z)
  178.     ($assert))) 
  179.  
  180. (defun ops-remove (z)
  181.   (prog (old)
  182.     (and (not *in-rhs*)(return (top-level-remove z)))
  183.     top  (and (atom z) (return nil))
  184.     (setq old (get-ce-var-bind (car z)))
  185.     (cond ((null old)
  186.        (%warn '|remove: argument not an element variable| (car z))
  187.        (return nil)))
  188.     (remove-from-wm old)
  189.     (setq z (cdr z))
  190.     (go top))) 
  191.  
  192. (defun ops-modify (z)
  193.   (prog (old)
  194.     (cond ((not *in-rhs*)
  195.        (%warn '|cannot be called at top level| 'modify)
  196.        (return nil)))
  197.     (setq old (get-ce-var-bind (car z)))
  198.     (cond ((null old)
  199.        (%warn '|modify: first argument must be an element variable|
  200.           (car z))
  201.        (return nil)))
  202.     (remove-from-wm old)
  203.     (setq z (cdr z))
  204.     ($reset)
  205.     copy (and (atom old) (go fin))
  206.     ($change (car old))
  207.     (setq old (cdr old))
  208.     (go copy)
  209.     fin  (eval-args z)
  210.     ($assert))) 
  211.  
  212. (defun ops-bind (z)
  213.   (prog (val)
  214.     (cond ((not *in-rhs*)
  215.        (%warn '|cannot be called at top level| 'bind)
  216.        (return nil)))
  217.     (cond ((< (length z) 1.)
  218.        (%warn '|bind: wrong number of arguments to| z)
  219.        (return nil))
  220.       ((not (symbolp (car z)))
  221.        (%warn '|bind: illegal argument| (car z))
  222.        (return nil))
  223.       ((= (length z) 1.) (setq val (gensym)))
  224.       (t ($reset)
  225.          (eval-args (cdr z))
  226.          (setq val ($parameter 1.))))
  227.     (make-var-bind (car z) val))) 
  228.  
  229. (defun ops-cbind (z)
  230.   (cond ((not *in-rhs*)
  231.      (%warn '|cannot be called at top level| 'cbind))
  232.     ((not (= (length z) 1.))
  233.      (%warn '|cbind: wrong number of arguments| z))
  234.     ((not (symbolp (car z)))
  235.      (%warn '|cbind: illegal argument| (car z)))
  236.     ((null *last*)
  237.      (%warn '|cbind: nothing added yet| (car z)))
  238.     (t (make-ce-var-bind (car z) *last*)))) 
  239.  
  240.  
  241. (defun ops-call (z)
  242.   (prog (f)
  243.     (setq f (car z))
  244.     ($reset)
  245.     (eval-args (cdr z))
  246.     (funcall f))) 
  247.  
  248.  
  249. (defun halt nil 
  250.   (cond ((not *in-rhs*)
  251.      (%warn '|cannot be called at top level| 'halt))
  252.     (t (setq *halt-flag* t)))) 
  253.  
  254. (defun ops-build (z)
  255.   (prog (r)
  256.     (cond ((not *in-rhs*)
  257.        (%warn '|cannot be called at top level| 'build)
  258.        (return nil)))
  259.     ($reset)
  260.     (build-collect z)
  261.     (setq r (unflat (use-result-array)))
  262.     (and *build-trace* (funcall *build-trace* r))
  263.     (compile-production (car r) (cdr r)))) 
  264.  
  265. (defun ops-compute (z) ($value (ari z))) 
  266.  
  267. ; arith is the obsolete form of compute
  268. (defun ops-arith (z) ($value (ari z))) 
  269.  
  270. (defun ari (x)
  271.   (cond ((atom x)
  272.      (%warn '|bad syntax in arithmetic expression | x)
  273.      0.)
  274.     ((atom (cdr x)) (ari-unit (car x)))
  275.     ((eq (cadr x) '+)
  276.      (+ (ari-unit (car x)) (ari (cddr x))))
  277.     ;"plus" changed to "+" by gdw
  278.     ((eq (cadr x) '-)
  279.      (- (ari-unit (car x)) (ari (cddr x))))
  280.     ((eq (cadr x) '*)
  281.      (* (ari-unit (car x)) (ari (cddr x))))
  282.     ((eq (cadr x) '//)
  283.      (floor (ari-unit (car x)) (ari (cddr x))))   ;@@@ quotient? /
  284.     ;@@@ kluge only works for integers
  285.     ;@@@ changed to floor by jcp (from round)
  286.     ((eq (cadr x) '\\)
  287.      (mod (fix (ari-unit (car x))) (fix (ari (cddr x)))))
  288.     (t (%warn '|bad syntax in arithmetic expression | x) 0.))) 
  289.  
  290. (defun ari-unit (a)
  291.   (prog (r)
  292.     (cond ((consp  a) (setq r (ari a)))    ;dtpr\consp gdw
  293.       (t (setq r ($varbind a))))
  294.     (cond ((not (numberp r))
  295.        (%warn '|bad value in arithmetic expression| a)
  296.        (return 0.))
  297.       (t (return r))))) 
  298.  
  299. (defun ops-substr (l)
  300.   (prog (k elm start end)
  301.     (cond ((not (= (length l) 3.))
  302.        (%warn '|substr: wrong number of arguments| l)
  303.        (return nil)))
  304.     (setq elm (get-ce-var-bind (car l)))
  305.     (cond ((null elm)
  306.        (%warn '|first argument to substr must be a ce var|
  307.           l)
  308.        (return nil)))
  309.     (setq start ($varbind (cadr l)))
  310.     (setq start ($litbind start))
  311.     (cond ((not (numberp start))
  312.        (%warn '|second argument to substr must be a number|
  313.           l)
  314.        (return nil)))
  315. ;###    (comment |if a variable is bound to INF, the following|
  316. ;     |will get the binding and treat it as INF is|
  317. ;     |always treated.  that may not be good|)
  318.     (setq end ($varbind (caddr l)))
  319.     (cond ((eq end 'inf) (setq end (length elm))))
  320.     (setq end ($litbind end))
  321.     (cond ((not (numberp end))
  322.        (%warn '|third argument to substr must be a number|
  323.           l)
  324.        (return nil)))
  325. ;###    (comment |this loop does not check for the end of elm|
  326. ;         |instead it relies on cdr of nil being nil|
  327. ;         |this may not work in all versions of lisp|)
  328.     (setq k 1.)
  329.     la   (cond ((> k end) (return nil))
  330.            ((not (< k start)) ($value (car elm))))
  331.     (setq elm (cdr elm))
  332.     (setq k (1+ k))
  333.     (go la))) 
  334.  
  335. (defun genatom nil ($value (gensym))) 
  336.  
  337. (defun ops-litval (z)
  338.   (prog (r)
  339.     (cond ((not (= (length z) 1.))
  340.        (%warn '|litval: wrong number of arguments| z)
  341.        ($value 0) 
  342.        (return nil))
  343.       ((numberp (car z)) ($value (car z)) (return nil)))
  344.     (setq r ($litbind ($varbind (car z))))
  345.     (cond ((numberp r) ($value r) (return nil)))
  346.     (%warn '|litval: argument has no literal binding| (car z))
  347.     ($value 0)))
  348.  
  349.  
  350.  
  351. ; rhs-tab implements the tab ('^') function in the rhs.  it has
  352. ; four responsibilities:
  353. ;    - to move the array pointers
  354. ;    - to watch for tabbing off the left end of the array
  355. ;      (ie, to watch for pointers less than 1)
  356. ;    - to watch for tabbing off the right end of the array
  357. ;    - to write nil in all the slots that are skipped
  358. ; the last is necessary if the result array is not to be cleared
  359. ; after each use; if rhs-tab did not do this, $reset
  360. ; would be much slower.
  361.  
  362. (defun rhs-tab (z) ($tab ($varbind z)))
  363.  
  364.  
  365. (defun time-tag-print (data port)
  366.   (cond ((not (null data))
  367.      (time-tag-print (cdr data) port)
  368.      (princ '| | port)
  369.      (princ (creation-time (car data)) port))))
  370.  
  371. (defun init-var-mem (vlist)
  372.   (prog (v ind r)
  373.     (setq *variable-memory* nil)
  374.     top  (and (atom vlist) (return nil))
  375.     (setq v (car vlist))
  376.     (setq ind (cadr vlist))
  377.     (setq vlist (cddr vlist))
  378.     (setq r (gelm *data-matched* ind))
  379.     (setq *variable-memory* (cons (cons v r) *variable-memory*))
  380.     (go top))) 
  381.  
  382. (defun init-ce-var-mem (vlist)
  383.   (prog (v ind r)
  384.     (setq *ce-variable-memory* nil)
  385.     top  (and (atom vlist) (return nil))
  386.     (setq v (car vlist))
  387.     (setq ind (cadr vlist))
  388.     (setq vlist (cddr vlist))
  389.     (setq r (ce-gelm *data-matched* ind))
  390.     (setq *ce-variable-memory*
  391.       (cons (cons v r) *ce-variable-memory*))
  392.     (go top))) 
  393.  
  394. (defun make-ce-var-bind (var elem)
  395.   (setq *ce-variable-memory*
  396.     (cons (cons var elem) *ce-variable-memory*))) 
  397.  
  398. (defun make-var-bind (var elem)
  399.   (setq *variable-memory* (cons (cons var elem) *variable-memory*))) 
  400.  
  401. (defun get-ce-var-bind (x)
  402.   (prog (r)
  403.     (cond ((numberp x) (return (get-num-ce x))))
  404.     (setq r (assq x *ce-variable-memory*))
  405.     (cond (r (return (cdr r)))
  406.       (t (return nil))))) 
  407.  
  408. (defun get-num-ce (x)
  409.   (prog (r l d)
  410.     (setq r *data-matched*)
  411.     (setq l (length r))
  412.     (setq d (- l x))
  413.     (and (> 0. d) (return nil))
  414.     la   (cond ((null r) (return nil))
  415.            ((> 1. d) (return (car r))))
  416.     (setq d (1- d))
  417.     (setq r (cdr r))
  418.     (go la))) 
  419.  
  420.  
  421. (defun build-collect (z)
  422.   (prog (r)
  423.     la   (and (atom z) (return nil))
  424.     (setq r (car z))
  425.     (setq z (cdr z))
  426.     (cond ((consp  r)    ;dtpr\consp gdw
  427.        ($value '\()
  428.            (build-collect r)
  429.            ($value '\)))
  430.       ((eq r '\\) ($change (car z)) (setq z (cdr z)))
  431.       (t ($value r)))
  432.     (go la))) 
  433.  
  434. (defun unflat (x) (setq *rest* x) (unflat*)) 
  435.  
  436. (defun unflat* nil
  437.   (prog (c)
  438.     (cond ((atom *rest*) (return nil)))
  439.     (setq c (car *rest*))
  440.     (setq *rest* (cdr *rest*))
  441.     (cond ((eq c '\() (return (cons (unflat*) (unflat*))))
  442.        ((eq c '\)) (return nil))
  443.       (t (return (cons c (unflat*))))))) 
  444.  
  445.  
  446.  
  447. ;;;; $Functions.
  448. ;;;; These functions provide an interface to the result array.
  449. ;;;; The result array is used to organize attribute values into their
  450. ;;;; correct slot.
  451.  
  452. (defun $litbind (x)
  453.   (prog (r)
  454.     (cond ((and (symbolp x) (setq r (literal-binding-of x)))
  455.        (return r))
  456.       (t (return x))))) 
  457.  
  458. (defun $varbind (x)
  459.   (prog (r)
  460.     (and (not *in-rhs*) (return x))
  461.     (setq r (assq x *variable-memory*))
  462.     (cond (r (return (cdr r)))
  463.       (t (return x))))) 
  464.  
  465. (defun $change (x)
  466.   (prog nil
  467.     (cond ((consp  x) (eval-function x))    ;dtpr\consp gdw
  468.       (t ($value ($varbind x)))))) 
  469.  
  470. (defun $reset nil
  471.   (setq *max-index* 0.)
  472.   (setq *next-index* 1.)) 
  473.  
  474. (defun $tab (z)
  475.   (prog (edge next)
  476.     (setq next ($litbind z))
  477.     (and (floatp next) (setq next (fix next)))
  478.     (cond ((or (not (numberp next)) 
  479.            (> next *size-result-array*)
  480.            (> 1. next))                ; ( '| |)
  481.        (%warn '|illegal index after ^| next)
  482.        (return *next-index*)))
  483.     (setq edge (- next 1.))
  484.     (cond ((> *max-index* edge) (go ok)))
  485.     clear (cond ((== *max-index* edge) (go ok)))
  486.     (putvector *result-array* edge nil)
  487.     (setq edge (1- edge))
  488.     (go clear)
  489.     ok   (setq *next-index* next)
  490.     (return next))) 
  491.  
  492. (defun $value (v)
  493.   (cond ((> *next-index* *size-result-array*)
  494.      (%warn '|index too large| *next-index*))
  495.     (t
  496.      (and (> *next-index* *max-index*)
  497.           (setq *max-index* *next-index*))
  498.      (putvector *result-array* *next-index* v)
  499.      (setq *next-index* (1+ *next-index*))))) 
  500.  
  501. (defun $assert nil
  502.   (setq *last* (use-result-array))
  503.   (add-to-wm *last* nil))
  504.  
  505. (defun $parametercount nil *max-index*)
  506.  
  507. (defun $parameter (k)
  508.   (cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.))
  509.      (%warn '|illegal parameter number | k)
  510.      nil)
  511.     ((> k *max-index*) nil)
  512.     (t (getvector *result-array* k))))
  513.  
  514. (defun $ifile (x) 
  515.   (cond ((symbolp x) (get x 'inputfile))
  516.     (t nil)))
  517.  
  518. (defun $ofile (x) 
  519.   (cond ((symbolp x) (get x 'outputfile))
  520.     (t nil)))
  521.  
  522.  
  523. ;;; Use-result-array returns the contents of the result array as a list.
  524.  
  525. (defun use-result-array nil
  526.   (prog (k r)
  527.     (setq k *max-index*)
  528.     (setq r nil)
  529.     top  (and (== k 0.) (return r))
  530.     (setq r (cons (getvector *result-array* k) r))
  531.     (setq k (1- k))
  532.     (go top))) 
  533.  
  534.  
  535. (defun eval-function (form)
  536.   (cond ((not *in-rhs*)
  537.      (%warn '|functions cannot be used at top level| (car form)))
  538.     (t (eval form))))
  539.  
  540.  
  541.  
  542. ;;;; WM maintaining functions
  543.  
  544. ;;; The order of operations in the following two functions is critical.
  545. ;;; add-to-wm order: (1) change wm (2) record change (3) match 
  546. ;;; remove-from-wm order: (1) record change (2) match (3) change wm
  547. ;;; (back will not restore state properly unless wm changes are recorded
  548. ;;; before the cs changes that they cause)  (match will give errors if 
  549. ;;; the thing matched is not in wm at the time)
  550.  
  551. (defun add-to-wm (wme override)
  552.   (prog (fa z part timetag port)
  553.     (setq *critical* t)
  554.     (setq *current-wm* (1+ *current-wm*))
  555.     (and (> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))
  556.     (setq *action-count* (1+ *action-count*))
  557.     (setq fa (wm-hash wme))
  558.     (or (member fa *wmpart-list*)
  559.     (setq *wmpart-list* (cons fa *wmpart-list*)))
  560.     (setq part (get fa 'wmpart*))
  561.     (cond (override (setq timetag override))
  562.       (t (setq timetag *action-count*)))
  563.     (setq z (cons wme timetag))
  564.     (putprop fa (cons z part) 'wmpart*)
  565.     (record-change '=>wm *action-count* wme)
  566.     (match 'new wme)
  567.     (setq *critical* nil)
  568.     (cond ((and *in-rhs* *wtrace*)
  569.        (setq port (trace-file))
  570.        (terpri port)
  571.        (princ '|=>wm: | port)
  572.        (ppelm wme port))))) 
  573.  
  574. ;;; remove-from-wm uses eq, not equal to determine if wme is present
  575.  
  576. (defun remove-from-wm (wme)
  577.   (prog (fa z part timetag port)
  578.     (setq fa (wm-hash wme))
  579.     (setq part (get fa 'wmpart*))
  580.     (setq z (assq wme part))
  581.     (or z (return nil))
  582.     (setq timetag (cdr z))
  583.     (cond ((and *wtrace* *in-rhs*)
  584.        (setq port (trace-file))
  585.        (terpri port)
  586.        (princ '|<=wm: | port)
  587.        (ppelm wme port)))
  588.     (setq *action-count* (1+ *action-count*))
  589.     (setq *critical* t)
  590.     (setq *current-wm* (1- *current-wm*))
  591.     (record-change '<=wm timetag wme)
  592.     (match nil wme)
  593.     (putprop fa (delq z part) 'wmpart*)
  594.     (setq *critical* nil))) 
  595.  
  596. ;;; mapwm maps down the elements of wm, applying fn to each element
  597. ;;; each element is of form (datum . creation-time)
  598.  
  599. (defun mapwm (fn)
  600.   (prog (wmpl part)
  601.     (setq wmpl *wmpart-list*)
  602.     lab1 (cond ((atom wmpl) (return nil)))
  603.     (setq part (get (car wmpl) 'wmpart*))
  604.     (setq wmpl (cdr wmpl))
  605.     (mapc fn part)
  606.     (go lab1))) 
  607.  
  608. (defun ops-wm (a) 
  609.   (mapc (function (lambda (z) (terpri) (ppelm z *standard-output*))) 
  610.     (get-wm a))
  611.   nil) 
  612.  
  613. (defun creation-time (wme)
  614.   (cdr (assq wme (get (wm-hash wme) 'wmpart*)))) 
  615.  
  616.  
  617. (defun get-wm (z)
  618.   (setq *wm-filter* z)
  619.   (setq *wm* nil)
  620.   (mapwm (function get-wm2))
  621.   (prog2 nil *wm* (setq *wm* nil))) 
  622.  
  623. (defun get-wm2 (elem) 
  624.   ; (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*) :test #'equal)))
  625.   (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*)) ;test #'equal)
  626.     (setq *wm* (cons (car elem) *wm*)))))
  627.  
  628. (defun wm-hash (x)
  629.   (cond ((not x) '<default>)
  630.     ((not (car x)) (wm-hash (cdr x)))
  631.     ((symbolp (car x)) (car x))
  632.     (t (wm-hash (cdr x))))) 
  633.  
  634. (defun refresh nil
  635.   (prog nil
  636.     (setq *old-wm* nil)
  637.     (mapwm (function refresh-collect))
  638.     (mapc (function refresh-del) *old-wm*)
  639.     (mapc (function refresh-add) *old-wm*)
  640.     (setq *old-wm* nil))) 
  641.  
  642. (defun refresh-collect (x) (setq *old-wm* (cons x *old-wm*))) 
  643.  
  644. (defun refresh-del (x) (remove-from-wm (car x))) 
  645.  
  646. (defun refresh-add (x) (add-to-wm (car x) (cdr x))) 
  647.