newLISP で On Lisp する．．．第２１章（その２の続き）

（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp と onnewlisp.lsp に定義してあります。）

　今回は、第２１章 マルチプロセス の動作例、黒板を使った同期 からです。

(define *bboard* '())
(defun claim   () (push (args) *bboard*))
(defun unclaim () (replace (args) *bboard*))
(defun check   () (find (args) *bboard*))
(=defun visitor (door)
  (print (format "Approach %s. " (string (term door))))
  (claim 'knock door)
  (wait d (check 'open door)
    (print (format "Enter %s. " (string (term door))))
    (unclaim 'knock door)
    (claim 'inside door)))
(=defun host (door)
  (wait k (check 'knock door)
    (print (format "Open %s. " (string (term door))))
    (claim 'open door)
    (wait g (check 'inside door)
      (print (format "Close %s.\n" (string (term door))))
      (unclaim 'open door))))
(program ballet ()
  (forkx (visitor 'door1) 1)
  (forkx (host 'door1) 1)
  (forkx (visitor 'door2) 1)
  (forkx (host 'door2) 1))

　newLISP組込format を使うとこんな感じのコードになります。
　ballet を実行すると、

> (ballet)
Approach door2. Open door2. Enter door2. Close door2.
Approach door1. Open door1. Enter door1. Close door1.

>>*bboard*
((MAIN:inside MAIN:door1) (MAIN:inside MAIN:door2))
>>(halt)
nil
> 

　といった感じ。所望の動作をしているようです。
　次に関数setpri を使った、優先順位の変更の効果。

(=defun capture (city)
  (take city)
  (setpri 1)
  (yield
    (fortify city)))
(=defun plunder (city)
  (loot city)
  (ransom city))
(defun take    (c) (print "Liberating " c ".\n"))
(defun fortify (c) (print "Rebuilding " c ".\n"))
(defun loot    (c) (print "Nationalizing " c ".\n"))
(defun ransom  (c) (print "Refinancing " c ".\n"))
(program barbarians ()
  (forkx (capture 'rome) 100)
  (forkx (plunder 'rome) 98))

　これを、動作させると、

> (barbarians)
Liberating rome.
Nationalizing rome.
Refinancing rome.
Rebuilding rome.

>>(halt)
nil
> 

　となります。
　最後に、関数kill でプロセスを終了させて見ましょう。
　すでに、program で ped プロセスを生成してある状態で、

> (setq *open-doors* '())
()
> (ped)

>>*procs*
(gensym12)
>>(kill gensym12)

>>*procs*
()
>>(halt)
nil
> 

　といった感じです。
　これで、windows版newLISP でもマルチ・プロセスが使える？（笑）

　さて、第２１章 マルチプロセス のまとめです。

• newLISP でも、“On Lisp” 本書で定義されたようなマルチプロセスを記述できます。

　本来マルチプロセス対応の newLISP が、windows版でも動作するようになってほしいものです（笑）。
　以上、如何でしょうか？

newLISP で On Lisp する．．．第２１章（その１）

（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp と onnewlisp.lsp に定義してあります。）

　第２１章 マルチプロセス に入ります。

　実は、newLISP は、マルチプロセス対応なのですが、Linux/Unix バージョンのみの機能です。残念ながら、私が使っている windows バージョンでは、使えません（泣）。それだけに、実装し甲斐がある？（笑）

　最初の プロセスの抽象化 にある、マルチプロセス対応の基本要素は、そのまま適用されます。それらは、実装で見てもらった方が早いでしょう。

　実装 では、まず、プロセスの構造体とその生成 を定義します。とはいっても、newLISP には、構造体がありません。以前定義した構造体マクロを使います。第２０章で定義した継続渡しマクロと共に onnewlisp.lsp に追加しました。

(defstruct proc pri state wait)

(define *procs* '())
(define *proc* '())

(define *halt* (gensym))

(define *default-proc*
  (make-proc (state (fn (x)
                        (print "\n>>")
                        (print (eval-string (read-line) 'MAIN))
                        (pick-process)))))

(define-macro (forkx)
; (forkx expr pri)
  (letex (_expr (args 0)
          _pri (args 1)
          _gvar (gensym))
    (push (make-proc
            (state (fn (_gvar)
                       _expr
                       (pick-process)))
            (pri _pri))
          *procs*)
    '_expr))

(define-macro (program)
; (program name args &body body)
  (letex (_name (args 0)
          _args (args 1)
          _body (cons 'begin (2 (args))))
  (=defun _name _args
           (setq *procs* nil)
           _body
      (catch (while true (pick-process)) '*halt*) *halt*)))

　早速、継続渡しマクロが使われます。“On Lisp” 本書と、ほぼ同様な実装です。letex が多用されているとか、nil が 空リストになるとか、defvar は define になるとかありますけど（笑）。
　構造体の表記は、、“newLISP で構造体を使う” を参照して下さい。コロン（：）を使わず、括弧で括るだけですけど（笑）。
　また、マクロ名fork は forkx と改名してあります。 windowsバージョンでは使えませんが、newLISP組込だからです。
　そして、プロセスのスケジューリング の実装は、こうなります。（defun、remove、multiple-value-bind、values、 reference-inversion:setf は newlisp-utility.lsp に定義してあります）

(define setfr reference-inversion:setf) 

(defun pick-process ()
  ;(println "pick process")
  (multiple-value-bind (p val) (most-urgent-process)
    (setq *proc* p
          *procs* (remove p *procs*))
    ((proc-state p) val)))

(defun most-urgent-process ()
  (let ((proc1 *default-proc*) (max1 -1) (val1 t))
    (dolist (p *procs*)
      (let ((pri (proc-pri p)))
        (if (> pri max1)
            (let ((val (or (not (proc-wait p))
                           ((proc-wait p)))))
               (when val
                 (setq proc1 p
                       max1  pri
                       val1  val))))))
    (values proc1 val1)))

(defun arbitrator (test cont)
  (setfr (proc-state *proc*) cont
         (proc-wait *proc*) test)
  (push *proc* *procs*)
  (pick-process))

(define-macro (wait)
; (wait parm test &body body)
  (letex (_parm (args 0)
          _test (args 1)
          _body (cons 'begin (2 (args))))
    (arbitrator (fn () _test)
                (fn (_parm) _body))))

(define-macro (yield)
; (yield &body body)
  (letex (_body (cons 'begin (args))
          _gsym (gensym))
    (arbitrator nil (fn (_gsym) _body))))

(defun setpri (n) (setfr (proc-pri *proc*) n))

(defun halt (val) (throw val))  ; 2008/02/19 corrected

(defun kill (obj)
  (if obj
      (setq *procs* (remove obj *procs*)))
  (pick-process))

　setf の代わりに、reference-inversion:setf を setfr として使っています。構造体定義に context バージョンを使ったのは、これが使えるから。おかげで、こちらも、本書とほぼ同様な定義で済みました。
　さて、気になる動作は、どうなるでしょうか？
　実装だけで長くなってしまったので、動作例は次回に（笑）。

　以上、如何でしょうか？