;;; fsm.el --- state machine library -*- lexical-binding: t; -*-
-;; Copyright (C) 2006, 2007, 2008 Magnus Henoch
+;; Copyright (C) 2006, 2007, 2008, 2015 Free Software Foundation, Inc.
-;; Author: Magnus Henoch <mange@freemail.hu>
-;; Version: 0.1ttn4
+;; Author: Magnus Henoch <magnus.henoch@gmail.com>
+;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
+;; Version: 0.2
+;; Package-Requires: ((emacs "24.1") (cl-lib "0.5"))
+;; Keywords: extensions
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; Here is a simple (not using all the features of fsm.el) example:
;;
;; ;; -*- lexical-binding: t; -*-
-;; (require 'cl)
-;; (labels ((hey (n ev)
-;; (message "%d (%s)\tp%sn%s!" n ev
-;; (if (zerop (% n 4)) "o" "i")
-;; (make-string (max 1 (abs n)) ?g))))
-;; (macrolet ((zow (next timeout)
-;; `(progn (hey (incf count) event)
-;; (list ,next count ,timeout))))
+;; (require 'fsm)
+;; (cl-labels ((hey (n ev)
+;; (message "%d (%s)\tp%sn%s!" n ev
+;; (if (zerop (% n 4)) "o" "i")
+;; (make-string (max 1 (abs n)) ?g))))
+;; (cl-macrolet ((zow (next timeout)
+;; `(progn (hey (cl-incf count) event)
+;; (list ,next count ,timeout))))
;; (define-fsm pingpong
;; :start ((init) "Start a pingpong fsm."
;; (interactive "nInit (number, negative to auto-terminate): ")
;;
;; Copy into a buffer, uncomment, and type M-x eval-buffer RET.
;; Alternatively, you can replace the `fsm-goodbye-cruel-world'
-;; form with `nil', eval just the `labels' form and then type
+;; form with `nil', eval just the `cl-labels' form and then type
;; M-x start-pingpong RET -16 RET.
;; Version 0.2:
;; -- Delete trailing whitespace.
;; -- Fix formatting.
;; -- Use lexical binding.
+;; -- Port to cl-lib.
+;; -- Remove unnecessary fsm-debug-output message.
+;; -- Add FSM name to fsm-debug-output messages that were not including it.
+;; -- Fix checkdoc errors.
+;; -- Change FSMs from plists to uninterned symbols.
;; NOTE: This is version 0.1ttn4 of fsm.el, with the following
;; mods (an exercise in meta-meta-programming ;-) by ttn:
;;; Code:
-;; We require cl at runtime, since we insert `destructuring-bind' into
+;; We require cl-lib at runtime, since we insert `cl-destructuring-bind' into
;; modules that use fsm.el.
-(require 'cl)
+(require 'cl-lib)
(defvar fsm-debug "*fsm-debug*"
"*Name of buffer for fsm debug messages.
(concat (current-time-string) ": "))
(apply 'format format args) "\n")))))
-(defmacro* define-state-machine (name &key start sleep)
+(cl-defmacro define-state-machine (name &key start sleep)
"Define a state machine class called NAME.
A function called start-NAME is created, which uses the argument
list and body specified in the :start argument. BODY should
[":sleep" function-form])))
(let ((start-name (intern (format "start-%s" name)))
interactive-spec)
- (destructuring-bind (arglist docstring &body body) start
+ (cl-destructuring-bind (arglist docstring &body body) start
(when (and (consp (car body)) (eq 'interactive (caar body)))
(setq interactive-spec (list (pop body))))
(unless (stringp docstring)
,docstring
,@interactive-spec
(fsm-debug-output "Starting %s" ',name)
- (let ((fsm (list :fsm ',name)))
- (destructuring-bind (state state-data &optional timeout)
+ (let ((fsm (cl-gensym (concat "fsm-" ,(symbol-name name) "-"))))
+ (cl-destructuring-bind (state state-data &optional timeout)
(progn ,@body)
- (nconc fsm (list :state nil :state-data nil
- :sleep ,(or sleep (lambda (secs)
- (accept-process-output
- nil secs)))
- :deferred nil))
+ (put fsm :name ',name)
+ (put fsm :state nil)
+ (put fsm :state-data nil)
+ (put fsm :sleep ,(or sleep (lambda (secs)
+ (accept-process-output
+ nil secs))))
+ (put fsm :deferred nil)
(fsm-update fsm state state-data timeout)
fsm)))))))
-(defmacro* define-state (fsm-name state-name arglist &body body)
+(cl-defmacro define-state (fsm-name state-name arglist &body body)
"Define a state called STATE-NAME in the state machine FSM-NAME.
ARGLIST and BODY make a function that gets called when the state
machine receives an event in this state. The arguments are:
`(setf (gethash ',state-name (get ',fsm-name :fsm-event))
(lambda ,arglist ,@body)))
-(defmacro* define-enter-state (fsm-name state-name arglist &body body)
+(cl-defmacro define-enter-state (fsm-name state-name arglist &body body)
"Define a function to call when FSM-NAME enters the state STATE-NAME.
ARGLIST and BODY make a function that gets called when the state
machine enters this state. The arguments are:
`(setf (gethash ',state-name (get ',fsm-name :fsm-enter))
(lambda ,arglist ,@body)))
-(defmacro* define-fsm (name &key
- start sleep states
- (fsm-name 'fsm)
- (state-data-name 'state-data)
- (callback-name 'callback)
- (event-name 'event))
+(cl-defmacro define-fsm (name &key
+ start sleep states
+ (fsm-name 'fsm)
+ (state-data-name 'state-data)
+ (callback-name 'callback)
+ (event-name 'event))
"Define a state machine class called NAME, along with its STATES.
This macro is (further) syntatic sugar for `define-state-machine',
`define-state' and `define-enter-state' macros, q.v.
used to construct the state functions' arglists."
`(progn
(define-state-machine ,name :start ,start :sleep ,sleep)
- ,@(loop for (state-name . spec) in states
- if (assq :enter spec) collect
- `(define-enter-state ,name ,state-name
- (,fsm-name ,state-data-name)
- ,@(cdr it))
- end
- if (assq :event spec) collect
- `(define-state ,name ,state-name
- (,fsm-name ,state-data-name
- ,event-name
- ,callback-name)
- ,@(cdr it))
- end)))
+ ,@(cl-loop for (state-name . spec) in states
+ if (assq :enter spec) collect
+ `(define-enter-state ,name ,state-name
+ (,fsm-name ,state-data-name)
+ ,@(cdr it))
+ end
+ if (assq :event spec) collect
+ `(define-state ,name ,state-name
+ (,fsm-name ,state-data-name
+ ,event-name
+ ,callback-name)
+ ,@(cdr it))
+ end)))
(defun fsm-goodbye-cruel-world (name)
"Unbind functions related to fsm NAME (a symbol).
(let (ht)
(when (hash-table-p (setq ht (get name :fsm-event)))
(clrhash ht)
- (remprop name :fsm-event))
+ (cl-remprop name :fsm-event))
(when (hash-table-p (setq ht (get name :fsm-enter)))
(clrhash ht)
- (remprop name :fsm-enter)))
+ (cl-remprop name :fsm-enter)))
nil)
(defun fsm-start-timer (fsm secs)
The timer is canceled if another event occurs before, unless the
event handler explicitly asks to keep the timer."
(fsm-stop-timer fsm)
- (setf (cddr fsm)
- (plist-put
- (cddr fsm)
- :timeout (run-with-timer secs
- nil
- #'fsm-send-sync fsm
- :timeout))))
+ (put fsm
+ :timeout (run-with-timer
+ secs nil
+ #'fsm-send-sync fsm :timeout)))
(defun fsm-stop-timer (fsm)
"Stop the timeout timer of FSM."
- (let ((timer (plist-get (cddr fsm) :timeout)))
+ (let ((timer (get fsm :timeout)))
(when (timerp timer)
(cancel-timer timer)
- (setf (cddr fsm) (plist-put (cddr fsm) :timeout nil)))))
+ (put fsm :timeout nil))))
(defun fsm-maybe-change-timer (fsm timeout)
"Change the timer of FSM according to TIMEOUT."
(run-with-timer 0 nil #'fsm-send-sync fsm event callback))
(defun fsm-update (fsm new-state new-state-data timeout)
- (let ((fsm-name (cadr fsm))
- (old-state (plist-get (cddr fsm) :state)))
- (plist-put (cddr fsm) :state new-state)
- (plist-put (cddr fsm) :state-data new-state-data)
+ "Update FSM with NEW-STATE, NEW-STATE-DATA and TIMEOUT."
+ (let ((fsm-name (get fsm :name))
+ (old-state (get fsm :state)))
+ (put fsm :state new-state)
+ (put fsm :state-data new-state-data)
(fsm-maybe-change-timer fsm timeout)
;; On state change, call enter function and send deferred events
(fsm-debug-output "%s enters %s" fsm-name new-state)
(let ((enter-fn (gethash new-state (get fsm-name :fsm-enter))))
(when (functionp enter-fn)
- (fsm-debug-output "Found enter function for %S" new-state)
+ (fsm-debug-output "Found enter function for %s/%s" fsm-name new-state)
(condition-case e
- (destructuring-bind (newer-state-data newer-timeout)
+ (cl-destructuring-bind (newer-state-data newer-timeout)
(funcall enter-fn fsm new-state-data)
- (fsm-debug-output "Using data from enter function")
- (plist-put (cddr fsm) :state-data newer-state-data)
+ (put fsm :state-data newer-state-data)
(fsm-maybe-change-timer fsm newer-timeout))
((debug error)
- (fsm-debug-output "Didn't work: %S" e)))))
+ (fsm-debug-output "%s/%s update didn't work: %S"
+ fsm-name new-state e)))))
- (let ((deferred (nreverse (plist-get (cddr fsm) :deferred))))
- (setf (cddr fsm)
- (plist-put (cddr fsm) :deferred nil))
+ (let ((deferred (nreverse (get fsm :deferred))))
+ (put fsm :deferred nil)
(dolist (event deferred)
(apply 'fsm-send-sync fsm event))))))
If the state machine generates a response, eventually call
CALLBACK with the response as only argument."
(save-match-data
- (let* ((fsm-name (second fsm))
- (state (plist-get (cddr fsm) :state))
- (state-data (plist-get (cddr fsm) :state-data))
+ (let* ((fsm-name (get fsm :name))
+ (state (get fsm :state))
+ (state-data (get fsm :state-data))
(state-fn (gethash state (get fsm-name :fsm-event))))
;; If the event is a list, output only the car, to avoid an
;; overflowing debug buffer.
;; Special case for deferring an event until next state change.
(cond
((eq result :defer)
- (let ((deferred (plist-get (cddr fsm) :deferred)))
- (plist-put (cddr fsm) :deferred
- (cons (list event callback) deferred))))
+ (let ((deferred (get fsm :deferred)))
+ (put fsm :deferred (cons (list event callback) deferred))))
((null result)
(fsm-debug-output "Warning: event %S ignored in state %s/%s"
event fsm-name state))
((and (listp result)
(<= 2 (length result))
(<= (length result) 3))
- (destructuring-bind (new-state new-state-data &optional timeout)
- result
+ (cl-destructuring-bind (new-state new-state-data &optional timeout)
+ result
(fsm-update fsm new-state new-state-data timeout)))
(t
(fsm-debug-output "Incorrect return value in %s/%s: %S"
(defun fsm-call (fsm event)
"Send EVENT to FSM synchronously, and wait for a reply.
-Return the reply.
-`with-timeout' might be useful."
+Return the reply. `with-timeout' might be useful."
(let (reply)
(fsm-send-sync fsm event (lambda (r) (setq reply (list r))))
(while (null reply)
"Return a sentinel function that sends events to FSM.
Events sent are of the form (:sentinel PROCESS STRING)."
(let ((fsm fsm))
- (lambda (process string)
- (fsm-send-sync fsm (list :sentinel process string)))))
+ (lambda (process string)
+ (fsm-send-sync fsm (list :sentinel process string)))))
(defun fsm-sleep (fsm secs)
"Sleep up to SECS seconds in a way that lets FSM receive events."
- (funcall (plist-get (cddr fsm) :sleep) secs))
+ (funcall (get fsm :sleep) secs))
(defun fsm-get-state-data (fsm)
"Return the state data of FSM.
Note the absence of a set function. The fsm should manage its
state data itself; other code should just send messages to it."
- (plist-get (cddr fsm) :state-data))
+ (get fsm :state-data))
(provide 'fsm)