I'm thinking about writing an interface for this as a macro, but I'd
like some feedback/critcism on my plans before I start. If you have
an idea for a better name for the macro that would help too.
The macro would look something like this:
def-mp-interruption (name stop-tag) varlist &rest body
Its use would look like this:
USER(2): (def-mp-interruption (big-loop stop-tag) (x)
(let ((i x))
(stop-tag
(loop do (incf i)))
(setq *result* i)))
BIG-LOOP
USER(3): (start-big-loop 10)
#<MULTIPROCESSING:PROCESS big loop @ #x4eb2322>
USER(4): (stop-big-loop)
NIL
USER(5): *result*
298856
This isn't an expansion, but shows what I'd like the expansion to do:
(progn
(defun big-loop (x)
(declare (ignore args))
(let ((i x))
(catch 'stop-tag
(loop do (incf i)))
(setq *result* i)))
(defun start-big-loop (&rest args)
(let ((proc))
(if (setq proc (find "big-loop" system:*all-processes* :key #'mp:process-name :test #'string-equal))
(error "Process, ~A, already running -- START-BIG-LOOP" proc)
(apply #'mp:process-run-function "big-loop" #'big-loop args))))
(defun stop-big-loop-internal (value)
(ignore-errors (throw 'stop-tag value)))
(defun stop-big-loop (&optional value)
(let ((process (find "big-loop" system:*all-processes* :key #'mp:process-name :test #'string-equal)))
(when process (mp:process-interrupt process #'stop-big-loop-internal value)))))
From: Jason Kantz
Subject: Re: interrupting long computations
Date:
Message-ID: <wkr98eic1t.fsf@kantz.com>
I haven't written too many macros--any comments or suggestions that
might help me improve this code would be much appreciated.
;;; def-long-comp.lisp
(in-package user)
;;; Example:
;USER(1): (def-long-comp (big-loop stop-tag) (x)
; (let ((i x))
; (stop-tag
; (loop do (incf i)))
; (setq *result* i)))
;BIG-LOOP
;USER(2): (start-big-loop 10)
;#<MULTIPROCESSING:PROCESS BIG-LOOP @ #x4ef27b2>
;USER(3): (stop-big-loop)
;NIL
;USER(4): *result*
;191666
;;; Code:
(defmacro def-long-comp ((name stop-tag) varlist &body body)
"use to define a function that will be run as a process with
start-[function-name] and interrupted with stop-[function-name]
when code is wrapped in the specified stop-tag"
`(progn
(macrolet ((,stop-tag (&rest bod)
(make-catch ',stop-tag bod)))
(defun ,name ,varlist ,@body))
(defun ,(symb "start-" name) (&rest args)
(let ((proc))
(if (setq proc (find-process ,(mkstr name)))
(error "Process, ~A, already running -- ~A"
proc ',(symb "start-" name))
(apply #'mp:process-run-function
,(mkstr name) (function ,name) args))))
(defun ,(symb "stop-" name "-internal") (value)
(ignore-errors (throw (quote ,stop-tag) value)))
(defun ,(symb "stop-" name) (&optional value)
(let ((process (find-process ,(mkstr name))))
(when process
(mp:process-interrupt process
(function
,(symb "stop-" name "-internal"))
value))))
',name))
;;; helper funs
(defun make-catch (symb bod)
`(catch ',symb ,@bod))
(defun mkstr (&rest args)
(with-output-to-string (s)
(dolist (a args) (princ a s))))
(defun symb (&rest args)
(values (intern (string-upcase (apply #'mkstr args)))))
(defun find-process (string)
(find (string-upcase string) system:*all-processes*
:key (lambda (proc) (string-upcase (mp:process-name proc)))
:test #'string-equal))
;;; def-long-comp.lisp ends here