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.