X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/97aab575af3c28e78810374eb843d9037340f3b6..7521ba2569eed0ba031eeffdbca9e9f6d109896b:/packages/fsm/fsm.el diff --git a/packages/fsm/fsm.el b/packages/fsm/fsm.el index db2a17a29..42dda1542 100644 --- a/packages/fsm/fsm.el +++ b/packages/fsm/fsm.el @@ -1,9 +1,12 @@ -;;; fsm.el --- state machine library +;;; 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 -;; Version: 0.1ttn4 +;; Author: Magnus Henoch +;; Maintainer: Thomas Fitzsimmons +;; 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 @@ -56,14 +59,15 @@ ;; Here is a simple (not using all the features of fsm.el) example: ;; -;; (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)))) +;; ;; -*- lexical-binding: t; -*- +;; (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): ") @@ -85,11 +89,18 @@ ;; ;; 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: @@ -105,9 +116,9 @@ ;;; 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. @@ -126,11 +137,11 @@ FORMAT and ARGS are passed to `format'." (save-excursion (goto-char (point-max)) (insert (if fsm-debug-timestamp-format - (format-time-string fsm-debug-timestamp-format) - (concat (current-time-string) ": ")) - (apply 'format format args) "\n"))))) + (format-time-string fsm-debug-timestamp-format) + (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 @@ -156,31 +167,33 @@ arguments. stringp def-body)] [":sleep" function-form]))) (let ((start-name (intern (format "start-%s" name))) - interactive-spec) - (destructuring-bind (arglist docstring &body body) start + interactive-spec) + (cl-destructuring-bind (arglist docstring &body body) start (when (and (consp (car body)) (eq 'interactive (caar body))) - (setq interactive-spec (list (pop body)))) + (setq interactive-spec (list (pop body)))) (unless (stringp docstring) (error "Docstring is not a string")) `(progn - (put ',name :fsm-enter (make-hash-table :size 11 :test 'eq)) - (put ',name :fsm-event (make-hash-table :size 11 :test 'eq)) + (put ',name :fsm-enter (make-hash-table :size 11 :test 'eq)) + (put ',name :fsm-event (make-hash-table :size 11 :test 'eq)) (defun ,start-name ,arglist ,docstring - ,@interactive-spec + ,@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: @@ -209,9 +222,9 @@ which case the event will be resent when the state machine enters another state." (declare (debug (&define name name :name handler lambda-list def-body))) `(setf (gethash ',state-name (get ',fsm-name :fsm-event)) - (lambda ,arglist ,@body))) + (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: @@ -228,14 +241,14 @@ TIMEOUT A number: send timeout event after this many seconds :keep: let existing timer continue" (declare (debug (&define name name :name enter lambda-list def-body))) `(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)) + (lambda ,arglist ,@body))) + +(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. @@ -253,19 +266,19 @@ FSM-NAME, STATE-DATA-NAME, CALLBACK-NAME, and EVENT-NAME are symbols, 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). @@ -277,10 +290,10 @@ any state machines using them. Return nil." (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) @@ -288,20 +301,17 @@ any state machines using them. Return nil." 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." @@ -320,10 +330,11 @@ CALLBACK with the response as only argument." (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 @@ -332,19 +343,18 @@ CALLBACK with the response as only argument." (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)))))) @@ -353,9 +363,9 @@ CALLBACK with the response as only argument." 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. @@ -368,11 +378,11 @@ CALLBACK with the response as only argument." ;; 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)) + (fsm-debug-output "Warning: event %S ignored in state %s/%s" + event fsm-name state)) ((eq (car-safe result) :error-signaled) (fsm-debug-output "Error in %s/%s: %s" fsm-name state @@ -380,7 +390,8 @@ CALLBACK with the response as only argument." ((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" @@ -389,9 +400,8 @@ CALLBACK with the response as only argument." (defun fsm-call (fsm event) "Send EVENT to FSM synchronously, and wait for a reply. -Return the reply. -`with-timeout' might be useful." - (lexical-let (reply) +Return the reply. `with-timeout' might be useful." + (let (reply) (fsm-send-sync fsm event (lambda (r) (setq reply (list r)))) (while (null reply) (fsm-sleep fsm 1)) @@ -400,26 +410,26 @@ Return the reply. (defun fsm-make-filter (fsm) "Return a filter function that sends events to FSM. Events sent are of the form (:filter PROCESS STRING)." - (lexical-let ((fsm fsm)) + (let ((fsm fsm)) (lambda (process string) (fsm-send-sync fsm (list :filter process string))))) (defun fsm-make-sentinel (fsm) "Return a sentinel function that sends events to FSM. Events sent are of the form (:sentinel PROCESS STRING)." - (lexical-let ((fsm fsm)) - (lambda (process string) - (fsm-send-sync fsm (list :sentinel process string))))) + (let ((fsm fsm)) + (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)