CLisp 19：On-Lisp书中延续和多进程的代码

先把代码放出来，以后解释其中原理

 

(defpackage my-proc

  (:use common-lisp))

 

(in-package my-proc)

 

;; 延续的代码

 

(defvar *actual-cont* #'values)

 

(define-symbol-macro *cont*  *actual-cont*)

 

(defmacro =defun (name parms &rest body)

  (let ((f (intern (concatenate 'string

                        "=" (symbol-name name)))))

    `(progn

       (defmacro ,name ,parms

          `(,',f *cont* ,,@parms))

       (defun ,f (*cont* ,@parms)

          ,@body))))

 

(defmacro =lambda (parms &rest body)

  `#'(lambda (*cont* ,@parms) ,@body))

 

; (multiple-value-bind vars value-form &rest body)

(defmacro =bind (parms expr &rest body)

  `(let ((*cont* #'(lambda ,parms ,@body)))

        ,expr))

 

(defmacro =values (&rest retvals)

  `(funcall *cont* ,@retvals))

 

(defmacro =funcall (fn @rest args)

  `(funcall ,fn *cont* ,@args))

 

(defmacro =apply (fn @rest args)

  `(apply ,fn *cont* ,@args))

 

;;; 多进程的代码

 

(defstruct proc pri state wait)

 

;(proclaim '(special *procs* *proc*))

(defvar *procs* nil)

(defvar *proc*  nil)

 

(defvar *halt* (gensym))

 

(defvar *default-proc*

  (make-proc :state

     #'(lambda (x) (format t "~%>> ")

                   (princ (eval (read)))

                   (pick-process))))

 

(defmacro fork (expr pri)

  `(prog1 ',expr

     (push (make-proc

            :state #'(lambda (,(gensym))

                       ,expr

                       (pick-process))

            :pri ,pri)

           *procs*)))

 

(defmacro program (name args &rest body)

  `(=defun ,name ,args

      (setq *procs* nil)

      ,@body

      (catch *halt* (loop (pick-process)))))

 

(defun pick-process ()

  (multiple-value-bind (p val) (most-urgent-process)

    (setq *proc* p

          *procs* (delete p *procs*))

    (funcall (proc-state p) val)))

 

(defun most-urgent-process ()

  (let ((proc1 *default-proc*) (max -1) (val1 t))

    (dolist (p *procs*)

      (let ((pri (proc-pri p)))

        (if (> pri max)

            (let ((val (or (not (proc-wait p))

                           (funcall (proc-wait p)))))

               (when val

                 (setq proc1 p

                       max   pri

                       val1  val))))))

    (values proc1 val1)))

 

(defun arbitrator (test cont)

  (setf (proc-state *proc*) cont

        (proc-wait  *proc*) test)

  (push *proc* *procs*)

  (pick-process))

 

(defmacro wait (parm test &rest body)

 `(arbitrator #'(lambda () ,test)

              #'(lambda (,parm) ,@body)))

 

(defmacro yield (&rest body)

 `(arbitrator nil #'(lambda (,(gensym)) ,@body)))

 

(defun setpri (n)

  (setf (proc-pri *proc*) n))

 

(defun halt (&optional val)

  (throw *halt* val))

 

(defun kill (&optional obj &rest args)

  (if obj

      (setq *procs* (apply #'delete obj *procs* args))

      (pick-process)))

 

;;; 测试多进程的代码

 

(defvar *open-doors* nil)

 

(=defun pedestrian ()

  (wait d (car *open-doors*)

    (format t "Entering ~A~%" d)))

 

(program ped ()

  (fork (pedestrian) 1))

 

(defvar *bboard* nil)

 

(defun claim (&rest f)

  (push f *bboard*))

 

(defun unclaim (&rest f)

  (setq *bboard* (delete f *bboard* :test #'equal)))

 

(defun check (&rest f)

  (find f *bboard* :test #'equal))

 

(=defun visitor (door)

  (format t "Approach ~A. " door)

  (claim 'knock door)

  (wait d (check 'open door)

    (format t "Enter ~A. " door)

    (unclaim 'knock door)

    (claim 'inside door)))

 

(=defun host (door)

  (wait k (check 'knock door)

    (format t "Open ~A. " door)

    (claim 'open door)

    (wait g (check 'inside door)

       (format t "Close ~A.~%" door)

       (unclaim 'open door))))

 

(program ballet ()

  (fork (visitor 'door1) 1)

  (fork (host 'door1) 1)

  (fork (visitor 'door2) 1)

  (fork (host 'door2) 1))

 

;;; 测试时只要运行 ballet 即可

MY-PROC[5]> (ballet)

Approach DOOR2. Open DOOR2. Enter DOOR2. Close DOOR2.

Approach DOOR1. Open DOOR1. Enter DOOR1. Close DOOR1.