5 The Multitasking Facility
samefringe, which uses multitasking to determine whether two trees have the same fringe. The function creates processes that walk through two trees and compare them atom for atom.
;;; This function is the top level of a process that enumerates ;;; the fringe atoms of a tree made up of conses. It uses the ;;; value of RESULT-SYMBOL to communicate with other processes. ;;; Whenever it encounters an atom, it stores it in RESULT-SYMBOL. ;;; When the atom has been compared with a fringe atom of the ;;; second tree, RESULT-SYMBOL is set to NIL, and the process ;;; moves to the next node. When the atoms of both trees have ;;; been compared, RESULT-SYMBOL is set to the special value :END. ;;; ;;; Note: this code won't work if the tree contains NIL or :END ;;; as atoms.The appendix "A Multitasking Application" presents a more detailed example of multitasking, as well as a sample session.
(defun fringe-top-level (tree result-symbol) (fringe-top-level-1 tree result-symbol) (set result-symbol :end))
(defun fringe-top-level-1 (tree result-symbol) (cond ((atom tree) ; An atom is found. (set result-symbol tree) ; Report the found atom. (process-wait "Symbol Ready" ; Wait until symbol becomes nil #'(lambda () (null (symbol-value result-symbol)))) ) (t ; If it is a cons, continue. (fringe-top-level (car tree) result-symbol) (fringe-top-level (cdr tree) result-symbol))))
(defun samefringe (tree1 tree2) "Determine whether TREE1 and TREE2 have the same atoms in the same order" ;; sym1 and sym2 are used to communicate between processes. (let ((sym1 (gensym)) (sym2 (gensym))) (set sym1 nil) (set sym2 nil) (let ((proc1 (make-process :name "Tree 1" :stack-size 3000 :function 'fringe-top-level :args (list tree1 sym1))) (proc2 (make-process :name "Tree 2" :stack-size 3000 :function 'fringe-top-level :args (list tree2 sym2)))) (unwind-protect ; Make sure processes get killed. ;; Wait until both processes have found fringing symbols. ;; If they do not match, exit immediately. (loop (unless (eq (process-wait "Tree 1" #'(lambda () (symbol-value sym1))) (process-wait "Tree 2" #'(lambda () (symbol-value sym2)))) (return nil)) ;; If atoms still match at the end of the search, signal ;; that the end has been reached and that the fringes ;; match. (when (eq (symbol-value sym1) :end) (return t)) ;; Flush the communication cells to allow the processes ;; to run again. (set sym1 nil) (set sym2 nil)) ;; If the comparison is not over, kill the processes. (unless (eq (symbol-value sym1) :end) (kill-process proc1)) (unless (eq (symbol-value sym2) :end) (kill-process proc2))))))
Generated with Harlequin WebMaker