All the basic examples for Application Delivery show how to replace the toplevel function with your own. Once that function is done, the application exits. I was wondering what's the best way to create a toplevel function for an application that is long running. My code is
(ql:quickload :my-app)
(defun main ()
(swank:create-server :dont-close t)
(my-app:start-server) ; Essentially creates a hunchentoot handler and returns
(loop for x = (read-line)
when (string= x "q") do (quit)
do (format t "Type q to quit~%" x)))
(save-application "my-app" :toplevel-function #'main :prepend-kernel t)
Is there a better way? I don't like the loop but something which frees up the terminal is also ok.
As you say, once the main function is done, the application exits. Ergo, you need to keep the function running until you wish to exit the application.
The simplest solution is to just leave the main loop in an infinite loop of sleep:
(defun main ()
(swank:create-server :dont-close t)
(my-app:start-server)
(loop (sleep 60)))
As you are starting a Swank server, you might want to include functionality for cleanly exiting the application through a SLIME connection. You could, for example, write something like the following, using the bt-semaphore package:
(defvar *quit-my-app* (bt-semaphore:make-semamphore))
(defun main ()
(swank:create-server :dont-close t)
(my-app:start-server)
(bt-semaphore:wait-on-semaphore *quit-my-app*)
(my-app:clean-up)) ; or whatever you need to do for cleaning up
(defun quit-my-app ()
(bt-semaphore:signal-semaphore *quit-my-app*))
Now you can simply evaluate (quit-my-app) on a SLIME connection to shut down the application.
You could also use the main thread for maintenance duties. In my server, I perform simple log rotation there:
(defun seconds-until-tomorrow ()
(multiple-value-bind (second minute hour day month year daylight-p zone)
(decode-universal-time (+ (get-universal-time) (* 60 60 26))) ; safely tomorrow
(declare (ignore second minute hour daylight-p))
(- (encode-universal-time 0 0 0 day month year zone)
(get-universal-time))))
(defun main ()
(swank:create-server :dont-close t)
(let (cur-logfile
cur-logfile-name
;; assuming that start-server returns the Hunchentoot acceptor
(acpt (my-app:start-server)))
(loop
(let* ((lf-stem (log-file-name))
(logfile-name (merge-pathnames lf-stem *temp-path*))
(new-logfile (open logfile-name :direction :output
:if-exists :append
:if-does-not-exist :create)))
(setf (hunchentoot:acceptor-message-log-destination acpt) new-logfile
(hunchentoot:acceptor-access-log-destination acpt) new-logfile)
(when cur-logfile
(close cur-logfile)
(run-program "/usr/bin/xz" (list (princ-to-string cur-logfile-name))))
(setf cur-logfile new-logfile
cur-logfile-name logfile-name)
(when (bt-semaphore:wait-on-semaphore *quit-my-app* (seconds-until-tomorrow))
(return)))))
Related
From SBCL's documentation, we can learn:
Invokes the signal facility on a condition formed from DATUM and
ARGUMENTS. If the condition is not handled, NIL is returned.
It does not elaborate on what signal returns in case of a handled condition.
So, I assumed (guessed), that the handler can somehow determine the return value of the signal function:
(defun countdown (&optional
(start-value 10)
(fail-value 1))
(loop
repeat start-value
for i from 0
collecting
(if (= i fail-value)
(signal "fail-value (~D) hit!" i)
i)))
(defun countdown-progress-indicator-style (&optional
(start-value 10)
(fail-value 1))
(handler-bind
((simple-condition (lambda (c)
(format t "fail (~A)~%" c)
fail-value))) ;; <--- I hoped the return value of the handler is returned by signal!
(countdown start-value fail-value)))
But: even if handled, signal returns nil.
(countdown-progress-indicator-style)
fail (fail-value (1) hit!)
(0 NIL 2 3 4 5 6 7 8 9)
Hence, my question, if there is a function or mechanism I missed, which allows the handler to influence signal's return value.
I think the CLHS explains it nicely: in order to handle a condition, you need to transfer control. This can be all kinds of things, but the usual way is to invoke a restart.
(defun countdown (&optional
(start-value 10)
(fail-value 1))
(loop repeat start-value
for i from 0
collecting
(restart-case
(if (= i fail-value)
(signal "fail-value (~D) hit!" i)
i)
(use-fail-value (fv)
fv))))
(defun countdown-progress-indicator-style (&optional
(start-value 10)
(fail-value 1))
(handler-bind
((simple-condition (lambda (c)
(format t "Handling simple condition~%")
(apply #'format t
(simple-condition-format-control c)
(simple-condition-format-arguments c))
(invoke-restart 'use-fail-value
(first (simple-condition-format-arguments c))))))
(countdown start-value fail-value)))
This somewhat abuses simple-conditions arguments; you should probably make your own condition, which takes the value explicitly.
Another way to put it is that you made a nice discovery. You can signal an exceptional situation, have it processed by handler-bind, and carry on execution (or choose not to by using restarts).
With handler-case, you can exit early with a return value.
(handler-case (countdown 3)
(simple-condition ()
(print :exiting-now!)))
;;=>
:EXITING-NOW!
:EXITING-NOW!
If a condition is signaled for which there is an appropriate error-clause during the execution of expression and if there is no intervening handler for a condition of that type, then control is transferred to the body of the relevant error-clause.
http://clhs.lisp.se/Body/m_hand_1.htm#handler-case
I am trying a simple echo server in common lisp (I use clisp). I've tried the example in http://rosettacode.org/wiki/Echo_server#Common_Lisp
The CLISP version (without usocket) works fine.
When I try the usocket version (with clisp) I get the following error:
* - The condition
CDR: :INPUT is not a list
occurred.
Thank you in advance for your replies,
Dimitris
I'm not sure of the answer, but I think this can be tracked down to wait-for-input and wait-for-input-internal. The function wait-for-input has the following definition (abbreviated):
(defun wait-for-input (socket-or-sockets &key timeout ready-only)
"Waits for one or more streams to become ready for reading from
the socket. When `timeout' (a non-negative real number) is
specified, wait `timeout' seconds, or wait indefinitely when
it isn't specified. A `timeout' value of 0 (zero) means polling. …"
(unless (wait-list-p socket-or-sockets)
(let ((wl (make-wait-list (if (listp socket-or-sockets)
socket-or-sockets (list socket-or-sockets)))))
(multiple-value-bind
(socks to)
(wait-for-input wl :timeout timeout :ready-only ready-only)
(return-from wait-for-input
(values (if ready-only socks socket-or-sockets) to)))))
(let* ((start (get-internal-real-time))
(sockets-ready 0))
(dolist (x (wait-list-waiters socket-or-sockets))
(when (setf (state x)
#+(and win32 (or sbcl ecl)) nil ; they cannot rely on LISTEN
#-(and win32 (or sbcl ecl))
(if (and (stream-usocket-p x)
(listen (socket-stream x)))
:read
nil))
(incf sockets-ready)))
;; the internal routine is responsibe for
;; making sure the wait doesn't block on socket-streams of
;; which theready- socket isn't ready, but there's space left in the
;; buffer
(wait-for-input-internal socket-or-sockets
:timeout (if (zerop sockets-ready) timeout 0))
(let ((to-result (when timeout
(let ((elapsed (/ (- (get-internal-real-time) start)
internal-time-units-per-second)))
(when (< elapsed timeout)
(- timeout elapsed))))))
(values (if ready-only
(remove-if #'null (wait-list-waiters socket-or-sockets) :key #'state)
socket-or-sockets)
to-result))))
Note that the last section calls wait-for-input-internal with
(wait-for-input-internal socket-or-sockets
:timeout (if (zerop sockets-ready) timeout 0))
Now, the name socket-or-sockets implies that its value may be a single socket or a list of sockets. However, let's take a look at the definition of wait-for-input-internal for CLISP (it's defined in the backend/<implementation>.lisp):
(defmethod wait-for-input-internal (wait-list &key timeout)
(with-mapped-conditions ()
(multiple-value-bind
(secs musecs)
(split-timeout (or timeout 1))
(dolist (x (wait-list-%wait wait-list))
(setf (cdr x) :INPUT))
(let* ((request-list (wait-list-%wait wait-list))
(status-list (if timeout
(socket:socket-status request-list secs musecs)
(socket:socket-status request-list)))
(sockets (wait-list-waiters wait-list)))
(do* ((x (pop sockets) (pop sockets))
(y (cdr (pop status-list)) (cdr (pop status-list))))
((null x))
(when (member y '(T :INPUT))
(setf (state x) :READ)))
wait-list))))
There are two uses of :INPUT there. It appears that each element of the wait-list is supposed to be a cons whose cdr contains some sort of state. Perhaps wait-for-input is getting called with a single socket (after all, the argument name is socket-or-sockets, and when wait-for-input-internal is called, it's expecting a list. That could lead to the latter getting (<something> . :INPUT) when expecting ((<something . :INPUT)). I'm not sure, though. In any case, though, the error is coming from somewhere around here.
I've put together the following rudimentary stopwatch in Racket (just learning now, the final aim is a pomodoro-timer).
#lang racket
(define start-time 0)
(define end-times '())
(define (start);; stores start-time
(set! start-time (current-seconds)))
(define (lap);; stores "laps" in list
(set! end-times (cons (current-seconds) end-times)))
(define (stop);; stores final time, displays lap-times in h, m, s and resets end-times
(begin
(set! end-times (cons (current-seconds) end-times))
(display
(reverse
(map (lambda (an-end)
(let ((the-date (seconds->date(- an-end start-time))))
(list
(sub1(date-hour the-date))
;; sub1 is needed because (date-hour(seconds->date 0) = 1
(date-minute the-date)
(date-second the-date)))) end-times)))
(set! end-times '())
))
While this does exactly what it should, I was wondering how I could avoid mutable state. If I follow HTDP, this is the kind of situation where mutable state is warranted, but after browsing Wadler's "Monads for Functional Programming", I'm still curious about how I could do without set!.
I know that to make it functional, I should add arguments to my functions. For instance, start would become
(define (start [now (current-seconds)])
now)
and a similar approach could work with lap and stop.
Still, while I know that after adding additional arguments to restore functionality, I should also pass arguments rather than storing values in variables, I don't see how in this case I can leverage this to avoid set! as well.
Update: Since all three answers below are highly valuable (thanks!), I didn't mark any of them as the unique correct one. Below is the minimal solution to my initial question. It is a combination of the loop-proposal of #Metaxal, with the example-usage of #Greg Hendershott.
#lang racket
(define (run)
(displayln "Enter 'lap' or 'quit':")
(let loop ([t0 (current-seconds)] [times '()])
(match (read-line)
["quit" (reverse
(map (lambda (x)
(let ((the-date (seconds->date x)))
(list
(sub1(date-hour the-date))
(date-minute the-date)
(date-second the-date)))) times))]
["lap" (loop t0 (cons (- (current-seconds) t0) times))]
[_ (loop t0 times)])))
What will likely happen in the following of your program is that you will have a loop.
Then this loop can be a function that takes as input the whole current state, and when you want to update its state, just call the loop again with the new state (you may also call the loop again with the same exact state of course).
Simplified example:
(define (loop [t0 (current-seconds)] [times '()])
;; ... do things here, possibly depending on user input ...
;; then loop with a new state:
(cond [<some-start-condition> (loop (current-seconds) '())]
[<some-lap-condition> (loop t0 (cons (- (current-seconds) t0) times))]
[<some-stop-condition> times])) ; stop, no loop, return value
This certainly changes the approach to your design though.
It's harder to use this approach when designing GUI programs, because the event loop often prevents you from (or makes it difficult) passing values from one event to the next.
However, in Racket, there is (the pedagogical, but still very good) big-bang that is made just for that.
In this case using set! is justified and hard to avoid, because we must "remember" state between invocations of the procedures. What we can do is improving the encapsulation of state, by hiding the variables that change inside a procedure and using a message dispatcher for accessing the procedures that refer to the mutable state. This is very similar to what we do with object-oriented programming, but only lambdas are required to implement it!
(define (make-timer)
; the "attributes" of the object
(let ([start-time 0]
[end-times '()])
; the "methods" of the object
(define (start)
(set! start-time (current-seconds)))
(define (lap)
(set! end-times (append end-times (list (current-seconds)))))
(define (stop)
(lap)
(display
(map (lambda (an-end)
(let ((the-date (seconds->date (- an-end start-time))))
(list
(sub1 (date-hour the-date))
(date-minute the-date)
(date-second the-date))))
end-times))
(set! end-times '()))
; return a dispatch procedure
(lambda (msg)
(case msg
((start) (start)) ; call the start procedure defined above
((lap) (lap)) ; call the lap procedure defined above
((stop) (stop)) ; call the stop procedure defined above
(else (error "unknown message:" msg))))))
I took the liberty of modifying some of your procedures to make them a bit simpler. Here's how we would use the timer object we just created:
(define timer (make-timer))
(timer 'start)
(sleep 1)
(timer 'lap)
(sleep 1)
(timer 'lap)
(sleep 1)
(timer 'lap)
(sleep 1)
(timer 'stop)
=> ((18 0 1) (18 0 2) (18 0 3) (18 0 4))
This technique is called "message passing", learn more about it in the wonderful SICP book.
For a simple example like this, I would probably do what #Metaxal
suggested.
However another approach is that you could explicitly define the state
as a struct:
(struct state (start-time end-times))
Then change the start, lap, and stop to be functions on state:
;; start : -> state
;; stores start-time
(define (start)
(state (current-seconds) '()))
;; lap : state -> state
;; stores "laps" in list
(define (lap st)
(match-define (state start-time end-times) st)
(state start-time
(cons (current-seconds) end-times)))
;; stop : state -> list
;; stores final time, displays lap-times in h, m, s
(define (stop st)
(match-define (state start-time end-times*) st)
(define end-times (cons (current-seconds) end-times*))
(reverse
(map (lambda (an-end)
(let ((the-date (seconds->date(- an-end start-time))))
(list
(sub1(date-hour the-date))
;; sub1 is needed because (date-hour(seconds->date 0) = 1
(date-minute the-date)
(date-second the-date)))) end-times)))
As in #Metaxal's answer, your "main loop" needs to handle the state and "thread" it through the functions as appropriate:
Example usage:
(define (run)
(displayln "Enter 'lap' or 'quit':")
(let loop ([st (start)])
(match (read-line)
["quit" (stop st)]
["lap" (loop (lap st))]
[_ (loop st)])))
Whereas #Óscar López's answer shows a style of OOP as explained in SICP.
A nice thing about Racket (and Scheme) is that you can choose whatever approach on the spectrum you think best fits the problem at hand, and your taste -- simple imperative, OOP imperative, pure functional.
I am looking for a general way for Emacs to do some checks, and (bing) when something is true or false.
I have 2 examples at the moment. There is an auction website, and I figured it would be nice for Emacs to check whether there has been an update. I did this using R (Emacs-ESS) to load source code of the website. Then I use a selfmade function in Emacs to:
Switch buffer, reload the URL info, send the info to the screen, (sleep-for ) to wait a little. Search for "Today". Then it has to check the value after this string, if it is higher than 0, then it means I have something new of interest, and it PINGS.
This is a long introduction, but I really like that this works.
I now do the same with Gnus, I have a timer that runs a function that opens Gnus every 10 seconds, searches for "Inbox", checks the value, and if it is higher than 0 then it notifies me (otherwise it just switches the buffer back). The only problem is that this takes around 0.5 seconds, in which you can see point move to another buffer and switch back.
Is there a general approach to have these automated things be done, without disturbing the user?
EDIT: Wouldn't it be nice for Emacs to perform a check to see whether there is a new post with our favorite tag here on Stackoverflow?
Emacs is single-threaded, so we are screwed - there is not way to do this without bothering the user at all.
The trick is to select a good balance between the frequency and cost of the check so that the user can bear it.
Here is the code I used once:
(defvar sds-new-mail-line nil "cache")
(defun sds-new-mail-line (&optional arg)
"add or remove the mode-line new-mail marker"
(or sds-new-mail-line (error "sds-new-mail-line has not been initialized"))
(let* ((mlf (default-value 'mode-line-format))
(already-have (eq sds-new-mail-line (car mlf))))
(if (or (eq arg nil) (< arg 0))
(when already-have
(setq-default mode-line-format (cdr mlf)))
(unless already-have
(setq-default mode-line-format (cons sds-new-mail-line mlf))))))
(defun sds-gnus-scan-mail ()
"check for new mail, notify if there is some"
(when (gnus-alive-p)
(with-current-buffer gnus-group-buffer
(gnus-group-get-new-news 3)
(gnus-group-get-new-news 2)
(goto-char (point-min))
;; look for new messages in groups of level 1 and 2
(cond ((search-forward-regexp "^ *s[12] *[1-9][0-9]*n" nil t)
(message "you have new mail! (%s)" (user-time-format))
(sds-new-mail-line 1)
(ding))
(t (sds-new-mail-line -1)
(message "no new mail (%s)" (user-time-format))))
(goto-char (point-min)))))
(defun sds-gnus-load-hook ()
(unless sds-new-mail-line ; init
(let ((str "mail") (map (make-sparse-keymap)))
(define-key map [mode-line down-mouse-1] 'ignore)
(define-key map [mode-line mouse-1] read-mail-command)
(add-text-properties 0 (length str)
(list 'display gnus-mode-line-image-cache
'help-echo "you have new mail - read it!"
'local-map map)
str)
(setq sds-new-mail-line str))
(gnus-demon-add-handler 'sds-gnus-scan-mail 3 t))
(add-hook 'gnus-summary-prepared-hook 'gnus-summary-first-unread-subject)
(add-hook 'gnus-summary-prepare-exit-hook 'gnus-summary-catchup))
;; cannot use gnus-load-hook here!
(eval-after-load "gnus-start" '(sds-gnus-load-hook))
I am sure you can adapt it to your needs.
[solved]
I have something similar with these four functions: base, init, func and some. The func is recursive and calls itself: in the "stop case" it would call some and return its value, then it should return control back to "init", wherefrom it is invoked; the latter being once called from base.
base
-> init
-> func
-> init
-> func
-> some
|
_________+
|
v
; should continue from here (in `func`)
[not anymore]
Instead, after the first call to some, the control is yielded directly to base, skipping what I would expect to be the intermediate (init,func) pair call(s).
I actually tried several simpler cases using block, return and recursion (e.g., "mutual tail-recursive factorial"), and all worked well. I mention that func uses a test helper function that catch a throw (but I tried even an example with (catch 'test (throw 'test 0)), and it was ok); just so whatever could my real program have something causing the issue.
This is elisp: each defun commences with block, and all functions use return, as in the following.
[I switched from using "defun/block" to "defun*"]
(defmacro 4+ (number)
"Add 4 to NUMBER, where NUMBER is a number."
(list 'setq number (list '1+ (list '1+ (list '1+ (list '1+ number))))))
(defmacro 4- (number)
"Subtract 4 from NUMBER, where NUMBER is a number."
(list 'setq number (list '1- (list '1- (list '1- (list '1- number))))))
(defun mesg (s &optional o)
"Use ATAB to tabulate message S at 4-multiple column; next/prev tab if O=1/0."
(when (null o) (setq o 0))
(case o (0 (4- atab)) (1 nil))
(message (concat "%" (format "%d" (+ atab (length s))) "s") s)
(case o (0 nil) (1 (4+ atab))))
(defun* base ()
(let (pack)
(setq atab 0)
(mesg "base->" 1)
(setq pack (init))
(mesg "<-base")))
(defun* init ()
(mesg "init->" 1)
(return-from init (progn (setq temp (func)) (mesg "<-init") temp)))
(defun* func (&optional pack)
(mesg "func->" 1)
(when (not (null pack)) (return-from func (progn (mesg "<+func") pack)))
(when (< 0 (mod (random) 2)); stop case
(return-from func (progn (setq temp (some)) (mesg "<-func") temp)))
(setq pack (init))
(case (mod (random) 2)
(0 (return-from func (progn (mesg "<0func") pack)))
(1 (return-from func (progn (setq temp (func pack)) (mesg "<1func") temp))) ; use tail-recursion instead of `while'
(t (error "foo bar"))))
(defun* some ()
(mesg "some->" 1)
(return-from some (progn (mesg "<-some") (list 2 3 4))))
(base)
The pack variable is my value-list as data structure. I also use func to reiterate itself (in tail-recursive call) with a special accumulating-parameter so that I avoid "imperative" while.
So instead of what I would expect (each > is paired by <)
base->
init->
func->
init->
func->
some->
<-some
<-func
<-init
func-> ; tail-recursion
<+func
<1func
<-init
<-base
my program behaves as follows.
base
-> init
-> func
-> init
-> func
-> some
|
__________________________+
|
v
; control yielded here (to `base`)
[not anymore]
Why is the control yielded too soon back to the start of the program, and not continue in the first call to func, after return from the second call via init?
Appreciate any help,
Sebastian
Looking at your code, it is not clear to me what's the extent of the block in func. If the block includes the whole func definition, then yes, the control reaches func when returning, but the block is skipped completely, hence the function completely, and comes back all the way up where it was called (eventually base). May be that the case?
If that's so, you have to put the code that you want to execute after a return after the block.
EDIT: Looking again at your code, I think you're not using the return as it should be used. For instance in init you have
(block nil
...
(return (func ...)))
This return "cancels" the block, and takes the same effect as not having the block at all, unless some function called in "..." does have a return without a block. So the return here cancels the possible return points of func.
Thanks both for your answer: inserting into my program those messages I tried as with the code I added for explanations revealed there are no defun* problems with elisp, but some things I mistook in design.