|
From: Martin R. <ru...@us...> - 2004-08-07 22:53:10
|
Update of /cvsroot/foo/foo/elkfoo/scm/control/processes In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6585/control/processes Added Files: Makefile.am process.foo scheduler.foo Log Message: initial checkin of scheme files, control, tools --- NEW FILE: process.foo --- (require 'oops 'oops.scm) ;;; ;;; abstract class Process ;;; (define-class Process) ;;; ;;; subclasses of Process must override run ;;; run has to return either a non-negative number ;;; indicating the delay after which it will be ;;; called again by the scheduler, or #t to be deactivated, ;;; or #f to be removed from the scheduler ;;; (define-method Process (run scheduler) (error 'run "subclass responsability")) ;;; ;;; the following two methods are envoked by the scheduler ;;; when the priority or the time of the process was changed ;;; at the moment these methods only print what happened (and ;;; show how one gets to the information of what happened) ;;; (define-method Process (priorityChanged scheduler) (format #t "priority changed to ~a for process id ~a~%" (send scheduler 'priorityOfProcess self) (send scheduler 'idOfProcess self))) (define-method Process (timeChanged scheduler) (format #t "time changed to ~a for process id ~a~%" (send scheduler 'timeOfProcess self) (send scheduler 'idOfProcess self))) --- NEW FILE: Makefile.am --- # foo/elkfoo/scm/control/processes/Makefile.am # 2004 rumori # $Id: Makefile.am,v 1.1 2004/08/07 22:53:01 rumori Exp $ NULL = pkgprocesses_DATA = $(ELKFOO_PROCESSES_FILES) pkgprocessesdir = $(pkgdatadir)/control/processes ELKFOO_PROCESSES_FILES = \ process.foo \ scheduler.foo \ $(NULL) --- NEW FILE: scheduler.foo --- (require 'oops 'oops.scm) (require 'struct 'struct.scm) ;;; ;;; structure thread ;;; (define-structure thread identifier process priority) ;;; ;;; class Scheduler ;;; (define-class Scheduler (instance-vars (time 0) (lastId 0) (processes (list 'head)) (waiting (list 'head)) (queue (list 'head)))) ;;; ;;; public methods: ;;; ;;; activateProcess <aProcess> => #t | #f ;;; addProcess <aProcess> <aPriority> <aDelay> => process id | #f ;;; getTime => time ;;; idOfProcess <aProcess> => process id | #f ;;; priorityOfProcess <aProcess> => process priority | #f ;;; processActive? <aProcess> => #t | #f ;;; processOfId <aNumber> => process | #f ;;; removeProcess <aProcess> => #t | #f ;;; runUntil {<end> | #f} => time ;;; setProcessPriority <aProcess> <aPriority> => #t | #f ;;; setProcessTime <aProcess> <aTime> => #t | #f ;;; setTime <aTime> => old time ;;; step => time | #f ;;; timeOfProcess <aProcess> => process time | #f ;;; (define-method Scheduler (getTime) time) (define-method Scheduler (setTime aTime) (set! time aTime)) (define-method Scheduler (addProcess aProcess aPriority aDelay) (if (number? (send self 'idOfProcess aProcess)) #f (set! lastId (1+ lastId)) (let ((thread (make-thread lastId aProcess aPriority))) (set! processes (append! processes (list thread))) (send self 'enqueue thread (+ aDelay time)) lastId))) (define-method Scheduler (removeProcess aProcess) (let ((thread (send self 'remove thread-process aProcess processes))) (if (not thread) #f (send self 'dequeue thread) #t))) (define-method Scheduler (setProcessPriority aProcess aPriority) (let ((thread (send self 'find thread-process aProcess processes)) (theTime 0)) (if (not thread) #f (set! theTime (send self 'dequeue thread)) (if (not theTime) #f (set-thread-priority! thread aPriority) (send self 'enqueue thread theTime) (send (thread-process thread) 'priorityChanged self) #t)))) (define-method Scheduler (setProcessTime aProcess aTime) (let ((thread (send self 'find thread-process aProcess processes))) (if (not thread) #f (send self 'dequeue thread) (send self 'enqueue thread aTime) (send (thread-process thread) 'timeChanged self) #t))) (define-method Scheduler (priorityOfProcess aProcess) (send self 'finder thread-process thread-priority aProcess)) (define-method Scheduler (timeOfProcess aProcess) (let* ((keyFunc (lambda (x) (thread-process (cdr x)))) (result (send self 'find keyFunc aProcess queue))) (if (not result) #f (car result)))) (define-method Scheduler (idOfProcess aProcess) (send self 'finder thread-process thread-identifier aProcess)) (define-method Scheduler (processOfId anId) (send self 'finder thread-identifier thread-process anId)) (define-method Scheduler (processActive? aProcess) (and (send self 'idOfProcess aProcess) (not (send self 'find thread-process aProcess waiting)))) (define-method Scheduler (activateProcess aProcess aDelay) (let ((thread (send self 'find thread-process aProcess waiting))) (if (not thread) #f (send self 'activate thread aDelay)))) (define-method Scheduler (step) (if (null? (cdr queue)) #f (let* ((thread (cdadr queue)) (telay 0) (process (thread-process thread))) (set! time (caadr queue)) (set-cdr! queue (cddr queue)) (set! telay (send process 'run self)) (if (number? telay) (send self 'enqueue thread (+ time telay)) (if (not telay) (send self 'removeProcess process) (send self 'deactivate thread))) time))) (define-method Scheduler (runUntil end) (if (number? end) (while (and (not (null? (cdr queue))) (<= (caadr queue) end)) (send self 'step)) (while (send self 'step) '())) time) ;;; ;;; private methods ;;; (define-method Scheduler (finder keyFunc valueFunc anObject) (let ((result (send self 'find keyFunc anObject processes))) (if (not result) #f (valueFunc result)))) (define-method Scheduler (find keyFunc anObject source) (define (loop x) (if (null? x) #f (if (eq? (keyFunc (car x)) anObject) (car x) (loop (cdr x))))) (loop (cdr source))) (define-method Scheduler (remove keyFunc anObject source) (define (loop x) (if (null? (cdr x)) #f (if (eq? (keyFunc (cadr x)) anObject) (begin1 (cadr x) (set-cdr! x (cddr x))) (loop (cdr x))))) (loop source)) (define-method Scheduler (enqueue thread time) (let ((priority (thread-priority thread)) (id (thread-identifier thread))) (define (insert x) (if (null? (cdr x)) (set! queue (append! queue (list (cons time thread)))) (if (or (< (caadr x) time) (or (and (= (caadr x) time) (> (thread-priority (cdadr x)) priority)) (and (= (caadr x) time) (= (thread-priority (cdadr x)) priority) (< (thread-identifier (cdadr x)) id)))) (insert (cdr x)) (set-cdr! x (append! (list (cons time thread)) (cdr x)))))) (insert queue))) (define-method Scheduler (dequeue thread) (let ((result (send self 'remove cdr thread queue))) (if result (car result) result))) (define-method Scheduler (deactivate thread) (set! waiting (append! waiting (list thread)))) (define-method Scheduler (activate thread telay) (define (remove x) (if (null? (cdr x)) #f (if (eq? (cadr x) thread) (begin1 (cadr x) (set-cdr! x (cddr x))) (remove (cdr x))))) (let ((thread (remove waiting))) (if (not thread) #f (send self 'enqueue thread (+ time telay)) #t))) |