Created
August 12, 2013 07:34
-
-
Save NalaGinrut/6208843 to your computer and use it in GitHub Desktop.
recv.scm of termite port to GNU Guile.
NOTE: this may not be the best port, but it seems logical for the expanding of hygienic macro.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;; All hail the RECV form | |
(define-syntax-rule (recv . clauses) | |
(let ((msg (gensym "msg")) ;; the current mailbox message | |
(loop (gensym "loop"))) ;; the mailbox seeking loop | |
;; check the last clause to see if it's a timeout | |
(let ((sesualc (reverse clauses))) | |
(if (and (pair? (car sesualc)) | |
(eq? (caar sesualc) 'after)) | |
(let ((clauses1 (reverse (cdr sesualc))) | |
;; the code to compute the timeout | |
(init (cadar sesualc)) | |
;; the variable holding the timeout | |
(timeout (gensym "timeout")) | |
;; the code to be executed on a timeout | |
(on-timeout (cddar sesualc)) | |
;; the timeout exception-handler to the whole match | |
(e (gensym "e"))) | |
(primitive-eval | |
(syntax->datum | |
;; RECV code when there is a timeout | |
#`(let ((#,timeout #,init)) | |
(with-exception-catcher | |
(lambda (#,e) | |
(if (mailbox-receive-timeout-exception? #,e) | |
(begin | |
(thread-mailbox-rewind) | |
#,@on-timeout) | |
(raise #,e))) | |
(lambda () | |
(let #,loop ((#,msg (thread-mailbox-next #,timeout))) | |
(match/action | |
(thread-mailbox-extract-and-rewind) | |
(#,loop | |
(thread-mailbox-next #,timeout)) | |
#,msg | |
;; extra clause to handle system events | |
(event | |
(where (termite-exception? event)) | |
(handle-exception-message event)) | |
;; the user clauses | |
#,@clauses1))))))) | |
(primitive-eval | |
(syntax->datum | |
;; RECV code when there is no timeout | |
#`(let #,loop ((#,msg (thread-mailbox-next))) | |
(match/action | |
(thread-mailbox-extract-and-rewind) | |
(#,loop | |
(thread-mailbox-next)) | |
#,msg | |
;; extra clause to handle system events | |
(event | |
(where (termite-exception? event)) | |
(handle-exception-message event)) | |
;; the user clauses | |
#,@clauses)))))))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment