replace old actor packages with new actor-ng

core/actor-legacy.lisp

@@ -0,0 +1,111 @@
+;;;; cl-scopes/core/actor - basic actor definitions
+
+(defpackage :scopes/core/actor
+  (:use :common-lisp)
+  (:local-nicknames (:async :scopes/util/async)
+                    (:util :scopes/util))
+  (:export #:bg-actor #:fg-actor #:make-actor #:start #:stop
+           #:become #:create #:send
+           #:message #:content #:customer
+           #:*logger* #:*root*
+           #:echo #:inc #:lgi
+           #:calculator #:plus #:minus #:show #:send-value))
+
+(in-package :scopes/core/actor)
+
+;;;; basic message and actor implementations
+
+(defclass message ()
+  ((content :reader content :initarg :content :initform nil)
+   (customer :reader customer :initarg :customer :initform nil)))
+
+(defun message (content &optional customer)
+  (make-instance 'message :content content :customer customer))
+
+(defclass actor ()
+  ((behavior :accessor behavior :initarg :behavior :initform #'no-op)))
+
+(defclass bg-actor (actor)
+  ((task :accessor task :initform nil)))
+
+(defmethod initialize-instance :after ((ac bg-actor) &key &allow-other-keys)
+  (setf (task ac) (make-task ac)))
+
+(defclass fg-actor (bg-actor) ())
+
+(defmethod initialize-instance :after ((ac fg-actor) &key &allow-other-keys)
+  (setf (task ac) (make-task ac 'async:fg-task)))
+
+(defgeneric start (ac)
+  (:method ((ac actor)))
+  (:method ((ac bg-actor))
+    (async:start (task ac))))
+
+(defgeneric stop (ac)
+  (:method ((ac actor)))
+  (:method ((ac bg-actor)) 
+    (async:stop (task ac))))
+
+(defun make-actor (bhv &optional (cls 'bg-actor) &rest args &key &allow-other-keys)
+  (apply #'make-instance cls :behavior bhv args))
+
+(defun make-task (ac &optional (cls 'async:task))
+  (async:make-task :cls cls
+                   :handle-message 
+                      #'(lambda (ax msg) (funcall (behavior ac) ac msg))))
+
+;;;; the core (classical, i.e. Hewitt) actor API
+
+(defun become (ac bhv)
+  (setf (behavior ac) bhv))
+
+(defun create (bhv &optional (cls 'actor) &rest args &key &allow-other-keys)
+  (let ((ac (apply #'make-actor bhv cls args)))
+    (start ac)
+    ac))
+
+(defgeneric send (addr content &key &allow-other-keys)
+  (:method ((addr t) (content t) &key customer &allow-other-keys)
+    (let ((ac addr) (msg (message content customer))) 
+      (send ac msg)))
+  (:method ((ac actor) (msg message) &key &allow-other-keys) 
+    (funcall (behavior ac) ac msg))
+  (:method ((ac bg-actor) (msg message) &key &allow-other-keys)
+    (async:send (task ac) msg)))
+
+;;;; predefined behaviors
+
+(defun no-op (ac msg))
+
+(defun lgi (ac msg)
+  (util:lgi (content msg)))
+
+(defun echo (ac msg)
+  (send (customer msg) msg))
+
+;;;; predefined global actors
+
+(defvar *logger* (create #'lgi))
+ 
+(defclass root (actor) ())
+
+(defun root-bhv (ac msg)
+  (send *logger* msg))
+
+(defvar *root* (create #'root-bhv 'root))
+
+ ;;;; example behavior: calculator
+
+(defun calculator (&optional (val 0))
+  #'(lambda (ac msg)
+      (destructuring-bind (fn &optional param) (content msg)
+        (funcall fn ac msg val param))))
+
+(defun plus (ac msg val param)
+  (become ac (calculator (+ val param)))) 
+(defun minus (ac msg val param)
+  (become ac (calculator (- val param)))) 
+(defun show (ac msg val param)
+  (send (or (customer msg) *logger*) val))
+(defun send-value (ac msg val param)
+  (send (customer msg) val))

core/actor-ng.lisp

@@ -1,100 +0,0 @@
-;;;; cl-scopes/core/actor - basic actor definitions
-
-(defpackage :scopes/core/actor-ng
-  (:use :common-lisp)
-  (:local-nicknames (:async :scopes/util/async) 
-                    (:lp :lparallel) 
-                    (:lpq :lparallel.queue)
-                    (:shape :scopes/shape)
-                    (:util :scopes/util))
-  (:export #:start #:stop #:become #:create #:send
-           #:message #:content #:customer
-           #:*logger* #:*root*
-           #:echo #:inc #:lgi
-           #:calculator #:plus #:minus #:show #:send-value))
-
-(in-package :scopes/core/actor-ng)
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (async:init))
-
-;;;; basic message implementation
-
-(defclass message ()
-  ((content :reader content :initarg :content :initform nil)
-   (customer :reader customer :initarg :customer :initform nil)))
-
-(defmethod x-print-object ((msg message) stream)
-  (shape:print-slots msg stream 'content 'customer))
-
-(defun message (content &optional customer)
-  (make-instance 'message :content content :customer customer))
-
-;;;; actor loop (listener)
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (when (not (boundp '+quit-message+)) 
-    (defconstant +quit-message+ (gensym "QUIT"))))
-
-(defun start (mb bhv &key foreground)
-  (if foreground
-    (ac-loop mb bhv)
-    (let ((ch (lp:make-channel)))
-      (lp:submit-task ch (lambda () (ac-loop mb bhv)))
-      ch)))
-
-(defun stop (mb)
-  (send mb (message +quit-message+)))
-
-(defun ac-loop (mb bhv)
-  (let ((msg (lpq:pop-queue mb)))
-    (unless (eq (content msg) +quit-message+)
-      (ac-loop mb (or (funcall bhv msg) bhv)))))
-
-;;;; the core (classical, i.e. Hewitt) actor API
-;;;  there is no `become` operation: the behavior just returns the new behavior
-
-(defun create (bhv)
-  (let ((mb (lpq:make-queue))) 
-    (values mb (start mb bhv))))
-
-(defun send (mb msg)
-  ;(util:lgi msg)
-  (lpq:push-queue msg mb))
-
-;;;; predefined behaviors
-
-(defun no-op (msg))
-
-(defun lgi (msg)
-  (util:lgi (content msg)))
-
-(defun echo (msg)
-  (send (customer msg) msg))
-
-;;;; predefined global actors
-
-(defvar *logger* (create #'lgi))
- 
-(defun root-bhv (ac msg)
-  (send *logger* msg))
-
-(defvar *root* (create #'root-bhv))
-
-;;;; example behavior: calculator
-
-(defun calculator (&optional (val 0))
-  (lambda (msg)
-    ;(format t "calc ~a ~a~%" val (content msg))
-    (destructuring-bind (fn &optional param) (content msg)
-      (funcall fn msg val param))))
-
-(defun plus (msg val param)
-  (calculator (+ val param))) 
-(defun minus (msg val param)
-  (calculator (- val param))) 
-(defun show (msg val param)
-  (send (or (customer msg) *logger*) (message val)))
-(defun send-value (msg val param)
-  (send (customer msg) (message val)))
-

core/actor.lisp

@@ -2,10 +2,12 @@
 
 (defpackage :scopes/core/actor
   (:use :common-lisp)
-  (:local-nicknames (:async :scopes/util/async)
+  (:local-nicknames (:async :scopes/util/async) 
+                    (:lp :lparallel) 
+                    (:lpq :lparallel.queue)
+                    (:shape :scopes/shape)
                     (:util :scopes/util))
-  (:export #:bg-actor #:fg-actor #:make-actor #:start #:stop
-           #:become #:create #:send
+  (:export #:start #:stop #:become #:create #:send
            #:message #:content #:customer
            #:*logger* #:*root*
            #:echo #:inc #:lgi
@@ -13,99 +15,86 @@
 
 (in-package :scopes/core/actor)
 
-;;;; basic message and actor implementations
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (async:init))
+
+;;;; basic message implementation
 
 (defclass message ()
   ((content :reader content :initarg :content :initform nil)
    (customer :reader customer :initarg :customer :initform nil)))
 
+(defmethod x-print-object ((msg message) stream)
+  (shape:print-slots msg stream 'content 'customer))
+
 (defun message (content &optional customer)
   (make-instance 'message :content content :customer customer))
 
-(defclass actor ()
-  ((behavior :accessor behavior :initarg :behavior :initform #'no-op)))
+;;;; actor loop (listener)
 
-(defclass bg-actor (actor)
-  ((task :accessor task :initform nil)))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (not (boundp '+quit-message+)) 
+    (defconstant +quit-message+ (gensym "QUIT"))))
 
-(defmethod initialize-instance :after ((ac bg-actor) &key &allow-other-keys)
-  (setf (task ac) (make-task ac)))
+(defun start (mb bhv &key foreground)
+  (if foreground
+    (ac-loop mb bhv)
+    (let ((ch (lp:make-channel)))
+      (lp:submit-task ch (lambda () (ac-loop mb bhv)))
+      ch)))
 
-(defclass fg-actor (bg-actor) ())
+(defun stop (mb)
+  (send mb (message +quit-message+)))
 
-(defmethod initialize-instance :after ((ac fg-actor) &key &allow-other-keys)
-  (setf (task ac) (make-task ac 'async:fg-task)))
-
-(defgeneric start (ac)
-  (:method ((ac actor)))
-  (:method ((ac bg-actor))
-    (async:start (task ac))))
-
-(defgeneric stop (ac)
-  (:method ((ac actor)))
-  (:method ((ac bg-actor)) 
-    (async:stop (task ac))))
-
-(defun make-actor (bhv &optional (cls 'bg-actor) &rest args &key &allow-other-keys)
-  (apply #'make-instance cls :behavior bhv args))
-
-(defun make-task (ac &optional (cls 'async:task))
-  (async:make-task :cls cls
-                   :handle-message 
-                      #'(lambda (ax msg) (funcall (behavior ac) ac msg))))
+(defun ac-loop (mb bhv)
+  (let ((msg (lpq:pop-queue mb)))
+    (unless (eq (content msg) +quit-message+)
+      (ac-loop mb (or (funcall bhv msg) bhv)))))
 
 ;;;; the core (classical, i.e. Hewitt) actor API
+;;;  there is no `become` operation: the behavior just returns the new behavior
 
-(defun become (ac bhv)
-  (setf (behavior ac) bhv))
+(defun create (bhv)
+  (let ((mb (lpq:make-queue))) 
+    (values mb (start mb bhv))))
 
-(defun create (bhv &optional (cls 'actor) &rest args &key &allow-other-keys)
-  (let ((ac (apply #'make-actor bhv cls args)))
-    (start ac)
-    ac))
-
-(defgeneric send (addr content &key &allow-other-keys)
-  (:method ((addr t) (content t) &key customer &allow-other-keys)
-    (let ((ac addr) (msg (message content customer))) 
-      (send ac msg)))
-  (:method ((ac actor) (msg message) &key &allow-other-keys) 
-    (funcall (behavior ac) ac msg))
-  (:method ((ac bg-actor) (msg message) &key &allow-other-keys)
-    (async:send (task ac) msg)))
+(defun send (mb msg)
+  ;(util:lgi msg)
+  (lpq:push-queue msg mb))
 
 ;;;; predefined behaviors
 
-(defun no-op (ac msg))
+(defun no-op (msg))
 
-(defun lgi (ac msg)
+(defun lgi (msg)
   (util:lgi (content msg)))
 
-(defun echo (ac msg)
+(defun echo (msg)
   (send (customer msg) msg))
 
 ;;;; predefined global actors
 
 (defvar *logger* (create #'lgi))
  
-(defclass root (actor) ())
-
 (defun root-bhv (ac msg)
   (send *logger* msg))
 
-(defvar *root* (create #'root-bhv 'root))
+(defvar *root* (create #'root-bhv))
 
- ;;;; example behavior: calculator
+;;;; example behavior: calculator
 
 (defun calculator (&optional (val 0))
-  #'(lambda (ac msg)
-      (destructuring-bind (fn &optional param) (content msg)
-        (funcall fn ac msg val param))))
+  (lambda (msg)
+    ;(format t "calc ~a ~a~%" val (content msg))
+    (destructuring-bind (fn &optional param) (content msg)
+      (funcall fn msg val param))))
+
+(defun plus (msg val param)
+  (calculator (+ val param))) 
+(defun minus (msg val param)
+  (calculator (- val param))) 
+(defun show (msg val param)
+  (send (or (customer msg) *logger*) (message val)))
+(defun send-value (msg val param)
+  (send (customer msg) (message val)))
 
-(defun plus (ac msg val param)
-  (become ac (calculator (+ val param)))) 
-(defun minus (ac msg val param)
-  (become ac (calculator (- val param)))) 
-(defun show (ac msg val param)
-  (send (or (customer msg) *logger*) val))
-(defun send-value (ac msg val param)
-  (send (customer msg) val))

core/core.lisp

@@ -2,7 +2,7 @@
 
 (defpackage :scopes/core
   (:use :common-lisp)
-  (:local-nicknames (:actor :scopes/core/actor-ng)
+  (:local-nicknames (:actor :scopes/core/actor)
                     (:async :scopes/util/async)
                     (:config :scopes/config)
                     (:message :scopes/core/message)
@@ -94,7 +94,7 @@
   (unwind-protect
     (progn
       (setup-services cfg)
-      (actor:start (mailbox *root*)))
+      (actor:start (mailbox *root*) :foreground t))
     (shutdown)))
  
 (defun shutdown ()

core/message.lisp

@@ -2,7 +2,7 @@
 
 (defpackage :scopes/core/message
   (:use :common-lisp)
-  (:local-nicknames (:actor :scopes/core/actor-ng)
+  (:local-nicknames (:actor :scopes/core/actor)
                     (:shape :scopes/shape))
   (:export #:message-meta #:message #:create
            #:head #:data))

scopes-core.asd

@@ -10,14 +10,14 @@
                :flexi-streams :ironclad :local-time :log4cl 
                :lparallel :qbase64 :serapeum :str)
   :components ((:file "config" :depends-on ("util/util"))
-               (:file "core/actor-ng" 
+               (:file "core/actor" 
                       :depends-on  ("shape/shape" "util/async" "util/util"))
                (:file "core/core" 
                       :depends-on ("config" 
-                                   "core/actor-ng" "core/message" 
+                                   "core/actor" "core/message" 
                                    "forge/forge" "logging" 
                                    "util/async" "util/util"))
-               (:file "core/message" :depends-on ("core/actor-ng" "shape/shape"))
+               (:file "core/message" :depends-on ("core/actor" "shape/shape"))
                (:file "forge/forge" :depends-on ("util/iter" "util/util"))
                (:file "logging" :depends-on ("config" "util/util"))
                (:file "shape/shape")

test/test-core.lisp

@@ -3,7 +3,7 @@
 (defpackage :scopes/test-core
   (:use :common-lisp)
   (:local-nicknames (:alx :alexandria)
-                    (:actor :scopes/core/actor-ng)
+                    (:actor :scopes/core/actor)
                     (:async :scopes/util/async)
                     (:config :scopes/config)
                     (:core :scopes/core)
@@ -66,8 +66,7 @@
         (core:setup-services)
         (test-actor)
         (setf (receiver t:*test-suite*) (core:find-service :test-receiver))
-        (test-send)
-        )
+        (test-send))
       (core:shutdown)
       (check-expected)
       (t:show-result))))
@@ -140,7 +139,7 @@
     (actor:send calc (actor:message '(actor:show)))
     (actor:send calc (actor:message '(actor:show) collector))
     (actor:stop calc)
-    (sleep 0.1)
+    (sleep 0.2)
     (== val -1)
 ))
 

web/response.lisp

@@ -39,7 +39,7 @@
 
 (defvar *html-response-class* nil)
 
-(defclass response (core:base-context actor:fg-actor)
+(defclass response (core:base-context)
   ((context :reader context :initarg :context)
    (core:actions :initform *default-actions*)
    (env :reader env :initarg :env)

web/server.lisp

@@ -2,8 +2,7 @@
 
 (defpackage :scopes/web/server
   (:use :common-lisp)
-  (:local-nicknames (:actor :scopes/core/actor)
-                    (:config :scopes/config)
+  (:local-nicknames (:config :scopes/config)
                     (:core :scopes/core)
                     (:message :scopes/core/message)
                     (:response :scopes/web/response)