diff options
Diffstat (limited to '2d')
| -rw-r--r-- | 2d/mvars.scm | 173 | ||||
| -rw-r--r-- | 2d/repl/repl.scm | 4 |
2 files changed, 88 insertions, 89 deletions
diff --git a/2d/mvars.scm b/2d/mvars.scm index 70674a4..77461ae 100644 --- a/2d/mvars.scm +++ b/2d/mvars.scm @@ -20,118 +20,104 @@ ;;; Code: (define-module (2d mvars) - #:use-module (srfi srfi-8) ; receive - #:use-module (srfi srfi-9) ; records - #:use-module (srfi srfi-9 gnu) #:use-module (ice-9 threads) - #:export (new-mvar mvar? mvar-empty? - take-mvar put-mvar read-mvar swap-mvar - try-take-mvar try-put-mvar try-read-mvar - with-mvar modify-mvar modify-mvar*)) + #:use-module (srfi srfi-8) ; receive + #:use-module (srfi srfi-9) ; records + #:use-module (srfi srfi-9 gnu) + #:export (mvar? + mvar-empty? new-empty-mvar new-mvar + take-mvar put-mvar read-mvar swap-mvar + try-take-mvar try-put-mvar + with-mvar modify-mvar modify-mvar*)) (define-record-type <mvar> - (make-mvar contents empty? mutex condvar) + (make-mvar contents empty? mutex full-condition empty-condition) mvar? - (contents mvar-contents set-mvar-contents!) - (empty? mvar-empty? set-mvar-empty?!) - (mutex mvar-mutex) - (condvar mvar-condvar)) + (contents %mvar-contents %set-mvar-contents!) + (empty? %mvar-empty? %set-mvar-empty?!) + (mutex mvar-mutex) + (full-condition mvar-full-condition) + (empty-condition mvar-empty-condition)) -(set-record-type-printer! - <mvar> - (lambda (mvar port) - (display "#<mvar " port) - (display (number->string (object-address mvar) 16) port) - (display " " port) - (write (receive (x full?) (try-read-mvar mvar) - (if full? (list x) '())) - port) - (display ">" port))) - -(define new-mvar - (case-lambda - "Return a freshly allocated mvar. The optional argument, if provided,\n\ -specifies the initial contents of the mvar, otherwise it will be empty." - (() (make-mvar #f #t (make-mutex) (make-condition-variable))) - ((x) (make-mvar x #f (make-mutex) (make-condition-variable))))) +(define (mvar-empty? mvar) + (with-mutex (mvar-mutex mvar) + (%mvar-empty? mvar))) + +(define (new-empty-mvar) + "Return a freshly allocated mvar that is initially empty." + (make-mvar #f ; contents + #t ; empty? + (make-mutex) + (make-condition-variable) + (make-condition-variable))) + +(define (new-mvar x) + "Return a freshly allocated mvar with initial contents X." + (make-mvar x ; contents + #f ; empty? + (make-mutex) + (make-condition-variable) + (make-condition-variable))) (define (take-mvar mvar) "Block until MVAR is full, then atomically remove and return its contents." (with-mutex (mvar-mutex mvar) - (when (mvar-empty? mvar) - (wait-condition-variable (mvar-condvar mvar) (mvar-mutex mvar)) - (when (mvar-empty? mvar) - (error "take-mvar: expected full mvar after waiting"))) - (let ((x (mvar-contents mvar))) - (set-mvar-contents! mvar #f) - (set-mvar-empty?! mvar #t) - (signal-condition-variable (mvar-condvar mvar)) + (when (%mvar-empty? mvar) + (wait-condition-variable (mvar-full-condition mvar) (mvar-mutex mvar))) + (let ((x (%mvar-contents mvar))) + (%set-mvar-contents! mvar #f) + (%set-mvar-empty?! mvar #t) + (signal-condition-variable (mvar-empty-condition mvar)) x))) (define (put-mvar mvar x) "Block until MVAR is empty, then put X into it." (with-mutex (mvar-mutex mvar) - (unless (mvar-empty? mvar) - (wait-condition-variable (mvar-condvar mvar) (mvar-mutex mvar)) - (unless (mvar-empty? mvar) - (error "put-mvar: expected empty mvar after waiting"))) - (set-mvar-contents! mvar x) - (set-mvar-empty?! mvar #f) - (signal-condition-variable (mvar-condvar mvar)) + (unless (%mvar-empty? mvar) + (wait-condition-variable (mvar-empty-condition mvar) (mvar-mutex mvar))) + (%set-mvar-contents! mvar x) + (%set-mvar-empty?! mvar #f) + (signal-condition-variable (mvar-full-condition mvar)) *unspecified*)) (define (read-mvar mvar) - "Block until MVAR is full, then return its contents, leaving MVAR unchanged." - (with-mutex (mvar-mutex mvar) - (when (mvar-empty? mvar) - (wait-condition-variable (mvar-condvar mvar) (mvar-mutex mvar)) - (when (mvar-empty? mvar) - (error "read-mvar: expected full mvar after waiting"))) - (mvar-contents mvar))) - -(define (swap-mvar mvar new) - "Block until MVAR is full, and then atomically swap its contents\n\ -with NEW and return the previous contents." - (with-mutex (mvar-mutex mvar) - (when (mvar-empty? mvar) - (wait-condition-variable (mvar-condvar mvar) (mvar-mutex mvar)) - (when (mvar-empty? mvar) - (error "swap-mvar: expected full mvar after waiting"))) - (let ((old (mvar-contents mvar))) - (set-mvar-contents! mvar new) - old))) + "Take a value x from MVAR, then put it back and return x. This +procedure is atomic only if there are no other producers for MVAR." + (let ((x (take-mvar mvar))) + (put-mvar mvar x) + x)) + +(define (swap-mvar mvar y) + "Take a value x from MVAR, then put Y into MVAR and return x. This +procedure is atomic only if there are no other producers for MVAR." + (let ((x (take-mvar mvar))) + (put-mvar mvar y) + x)) (define (try-take-mvar mvar) "If MVAR is full, return its contents and #t, else return #f and #f." (with-mutex (mvar-mutex mvar) - (if (mvar-empty? mvar) + (if (%mvar-empty? mvar) (values #f #f) - (let ((x (mvar-contents mvar))) - (set-mvar-contents! mvar #f) - (set-mvar-empty?! mvar #t) - (signal-condition-variable (mvar-condvar mvar)) + (let ((x (%mvar-contents mvar))) + (%set-mvar-contents! mvar #f) + (%set-mvar-empty?! mvar #t) + (signal-condition-variable (mvar-empty-condition mvar)) (values x #t))))) (define (try-put-mvar mvar x) "If MVAR is empty, put X into it and return #t, else return #f." (with-mutex (mvar-mutex mvar) - (and (mvar-empty? mvar) + (and (%mvar-empty? mvar) (begin - (set-mvar-contents! mvar x) - (set-mvar-empty?! mvar #f) - (signal-condition-variable (mvar-condvar mvar)) + (%set-mvar-contents! mvar x) + (%set-mvar-empty?! mvar #f) + (signal-condition-variable (mvar-full-condition mvar)) #t)))) -(define (try-read-mvar mvar) - "If MVAR is full, return its contents and #t, else return #f and #f." - (with-mutex (mvar-mutex mvar) - (if (mvar-empty? mvar) - (values #f #f) - (values (mvar-contents mvar) #t)))) - (define (with-mvar mvar proc) - "Take a value from MVAR and apply PROC to it. If an exception is raised,\n\ -the original value is put back into MVAR. This procedure is atomic only if\n\ + "Take a value from MVAR and apply PROC to it. If an exception is raised, +the original value is put back into MVAR. This procedure is atomic only if there are no other producers for MVAR." (let ((x (take-mvar mvar))) (catch #t @@ -141,8 +127,8 @@ there are no other producers for MVAR." (apply throw key args))))) (define (modify-mvar mvar f) - "Take a value x from MVAR, and then put back (F x). If an exception is\n\ -raised, the original value is put back into MVAR. This procedure is\n\ + "Take a value x from MVAR, and then put back (F x). If an exception is +raised, the original value is put back into MVAR. This procedure is atomic only if there are no other producers for MVAR." (let ((old (take-mvar mvar))) (catch #t @@ -152,10 +138,10 @@ atomic only if there are no other producers for MVAR." (apply throw key args))))) (define (modify-mvar* mvar f) - "Take a value x from MVAR, and apply F to it. (F x) should return one\n\ -or more values: the new value to be put back into MVAR, and zero or more\n\ -additional values to be returned from MODIFY-MVAR*. If an exception is\n\ -raised, the original value is put back into MVAR. This procedure is\n\ + "Take a value x from MVAR, and apply F to it. (F x) should return one +or more values: the new value to be put back into MVAR, and zero or more +additional values to be returned from MODIFY-MVAR*. If an exception is +raised, the original value is put back into MVAR. This procedure is atomic only if there are no other producers for MVAR." (let ((old (take-mvar mvar))) (catch #t @@ -166,3 +152,16 @@ atomic only if there are no other producers for MVAR." (lambda (key . args) (put-mvar mvar old) (apply throw key args))))) + +(set-record-type-printer! + <mvar> + (lambda (mvar port) + (display "#<mvar " port) + (display (number->string (object-address mvar) 16) port) + (display " " port) + (write (with-mutex (mvar-mutex mvar) + (if (%mvar-empty? mvar) + '() + (list (%mvar-contents mvar)))) + port) + (display ">" port))) diff --git a/2d/repl/repl.scm b/2d/repl/repl.scm index 253789d..4ff8f52 100644 --- a/2d/repl/repl.scm +++ b/2d/repl/repl.scm @@ -130,8 +130,8 @@ ;;; The repl ;;; -(define repl-input-mvar (new-mvar)) -(define repl-output-mvar (new-mvar)) +(define repl-input-mvar (new-empty-mvar)) +(define repl-output-mvar (new-empty-mvar)) (define* (start-repl #:optional (lang (current-language)) #:key debug) ;; ,language at the REPL will update the current-language. Make |