<commit_before>;;; -*- Gerbil -*-
;;; (C) vyzo
;;; actor message primitives and macros
package: std/actor

(import :gerbil/gambit/threads
        :gerbil/gambit/os
        :std/event
        :std/error)
(export
  (struct-out message proxy)
  (struct-out actor-error)
  actor-error:::init!
  -> send send-message send-message/timeout
  << <- receive-message
  !)

;; ~~lib/_gambit#.scm
(extern namespace: #f
  macro-absent-obj
  macro-mailbox-mutex
  macro-mailbox-condvar
  macro-mailbox-cursor
  macro-mailbox-cursor-set!
  macro-mailbox-fifo
  macro-fifo-next
  macro-fifo-next-set!
  macro-fifo-elem
  macro-fifo-tail-set!)

(defstruct (actor-error <error>) ()
  constructor: :init!)

(defmethod {:init! actor-error}
  (lambda (self where what . irritants)
    (struct-instance-init! self what irritants where)))

;;; structured messages
(defstruct message (e source dest options)
  final: #t)

(defstruct proxy (handler))

;;; send primitives
(def (send dest msg (check-dead? #f))
  (let lp ((dest dest))
    (cond
     ((thread? dest)
      (cond
       ((not check-dead?)
        (thread-send dest msg))
       ((thread-send/check dest msg))
       (else
        (raise (make-actor-error 'send "Cannot send message; dead thread" dest msg)))))
     ((proxy? dest)
      (lp (proxy-handler dest)))
     (else
      (lp (call-method ':actor dest))))))

(def (send-message dest value (options #f) (check-dead? (proxy? dest)))
  (send dest (make-message value (current-thread) dest options)
        check-dead?))

(def (send-message/timeout dest value timeo (check-dead? (proxy? dest)))
  (send dest (make-message value (current-thread) dest [timeout: timeo])
        check-dead?))

(extern thread-send/check)
(begin-foreign
  (namespace ("std/actor/message#" send thread-send/check))
  (define (thread-send/check thread msg)
    (declare (not interrupts-enabled))
    (macro-check-initialized-thread thread (send thread msg)
      (if (macro-thread-end-condvar thread)
        (##thread-send thread msg)
        #f))))

(defsyntax (-> stx)
  (syntax-case stx ()
    ((macro msg)
     (with-syntax ((dest (stx-identifier #'macro '@source)))
       #'(send-message dest msg)))
    ((macro msg timeout: timeo)
     (with-syntax ((dest (stx-identifier #'macro '@source)))
       #'(send-message/timeout dest msg)))))

;;; receive primitives
;; receive macros
;; <- matches a structured message, << raw matches the raw message
(begin-syntax
  (def (generate-receive stx generate-test-e generate-recv-e)
    (syntax-case stx ()
      ((_ clause ...)
       (with-syntax* (((values clauses events else-e)
                       (parse-receive stx #'(clause ...)))
                      ((event ...) events)
                      (test-e (generate-test-e stx clauses))
                      (recv-e (generate-recv-e stx clauses))
                      (else-e else-e))
         #'(receive-message test-e recv-e else-e [event ...])))))

  (def (parse-receive stx clauses)
    (let lp ((rest clauses) (clauses []) (events []) (else-e #f))
      (syntax-case rest (=> ! else)
        (((! evt => K) . rest)
         (lp #'rest clauses
             (cons #'(cons evt K) events)
             else-e))
        (((! (var evt) body ...) . rest)
         (identifier? #'var)
         (lp #'rest clauses
             (cons #'(cons evt (lambda (var) body ...)) events)
             else-e))
        (((! ((var ...) evt) body ...) . rest)
         (identifier-list? #'(var ...))
         (lp #'rest clauses
             (cons #'(cons evt (lambda (var ...) body ...)) events)
             else-e))
        (((! evt body ...) . rest)
         (lp #'rest clauses
             (cons #'(cons evt (lambda (_) body ...)) events)
             else-e))
        (((else body ...) . rest)
         (if else-e
           (raise-syntax-error #f "Bad syntax; duplicate else"
                               stx (stx-car #'rest))
           (lp #'rest clauses events
               #'(lambda () body ...))))
        ((clause . rest)
         (lp #'rest
             (cons #'clause clauses)
             events else-e))
        (()
         (values (reverse clauses) (reverse events) else-e))
        (_ (raise-syntax-error #f "Bad syntax; bad clause" stx rest)))))

  (def (generate-receive-raw-test-e stx clauses)
    (with-syntax ((((hd . body) ...) clauses))
      #'(lambda (msg)<commit_msg>std/actor/message: kill complex event variable bindings in message reaction<commit_after>;;; -*- Gerbil -*-
;;; (C) vyzo
;;; actor message primitives and macros
package: std/actor

(import :gerbil/gambit/threads
        :gerbil/gambit/os
        :std/event
        :std/error)
(export
  (struct-out message proxy)
  (struct-out actor-error)
  actor-error:::init!
  -> send send-message send-message/timeout
  << <- receive-message
  !)

;; ~~lib/_gambit#.scm
(extern namespace: #f
  macro-absent-obj
  macro-mailbox-mutex
  macro-mailbox-condvar
  macro-mailbox-cursor
  macro-mailbox-cursor-set!
  macro-mailbox-fifo
  macro-fifo-next
  macro-fifo-next-set!
  macro-fifo-elem
  macro-fifo-tail-set!)

(defstruct (actor-error <error>) ()
  constructor: :init!)

(defmethod {:init! actor-error}
  (lambda (self where what . irritants)
    (struct-instance-init! self what irritants where)))

;;; structured messages
(defstruct message (e source dest options)
  final: #t)

(defstruct proxy (handler))

;;; send primitives
(def (send dest msg (check-dead? #f))
  (let lp ((dest dest))
    (cond
     ((thread? dest)
      (cond
       ((not check-dead?)
        (thread-send dest msg))
       ((thread-send/check dest msg))
       (else
        (raise (make-actor-error 'send "Cannot send message; dead thread" dest msg)))))
     ((proxy? dest)
      (lp (proxy-handler dest)))
     (else
      (lp (call-method ':actor dest))))))

(def (send-message dest value (options #f) (check-dead? (proxy? dest)))
  (send dest (make-message value (current-thread) dest options)
        check-dead?))

(def (send-message/timeout dest value timeo (check-dead? (proxy? dest)))
  (send dest (make-message value (current-thread) dest [timeout: timeo])
        check-dead?))

(extern thread-send/check)
(begin-foreign
  (namespace ("std/actor/message#" send thread-send/check))
  (define (thread-send/check thread msg)
    (declare (not interrupts-enabled))
    (macro-check-initialized-thread thread (send thread msg)
      (if (macro-thread-end-condvar thread)
        (##thread-send thread msg)
        #f))))

(defsyntax (-> stx)
  (syntax-case stx ()
    ((macro msg)
     (with-syntax ((dest (stx-identifier #'macro '@source)))
       #'(send-message dest msg)))
    ((macro msg timeout: timeo)
     (with-syntax ((dest (stx-identifier #'macro '@source)))
       #'(send-message/timeout dest msg)))))

;;; receive primitives
;; receive macros
;; <- matches a structured message, << raw matches the raw message
(begin-syntax
  (def (generate-receive stx generate-test-e generate-recv-e)
    (syntax-case stx ()
      ((_ clause ...)
       (with-syntax* (((values clauses events else-e)
                       (parse-receive stx #'(clause ...)))
                      ((event ...) events)
                      (test-e (generate-test-e stx clauses))
                      (recv-e (generate-recv-e stx clauses))
                      (else-e else-e))
         #'(receive-message test-e recv-e else-e [event ...])))))

  (def (parse-receive stx clauses)
    (let lp ((rest clauses) (clauses []) (events []) (else-e #f))
      (syntax-case rest (=> ! else)
        (((! evt => K) . rest)
         (lp #'rest clauses
             (cons #'(cons evt K) events)
             else-e))
        (((! evt body ...) . rest)
         (lp #'rest clauses
             (cons #'(cons evt (lambda (_) body ...)) events)
             else-e))
        (((else body ...) . rest)
         (if else-e
           (raise-syntax-error #f "Bad syntax; duplicate else"
                               stx (stx-car #'rest))
           (lp #'rest clauses events
               #'(lambda () body ...))))
        ((clause . rest)
         (lp #'rest
             (cons #'clause clauses)
             events else-e))
        (()
         (values (reverse clauses) (reverse events) else-e))
        (_ (raise-syntax-error #f "Bad syntax; bad clause" stx rest)))))

  (def (generate-receive-raw-test-e stx clauses)
    (with-syntax ((((hd . body) ...) clauses))
      #'(lambda (msg)
{'fraction_non_alphanumeric': 0.1642644431209053, 'fraction_numerical': 0.0, 'mean_word_length': 2.2342064714946073, 'pattern_counts': {'":': 0, '<': 17, '<?xml version=': 0, '>': 13, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2194091', 'n_tokens_mistral': 2737, 'n_tokens_neox': 2622, 'n_words': 729}