Changeset 39702 in project

Timestamp:

03/14/21 17:08:10 (5 weeks ago)

Author:

Kon Lovett

Message:

doesn't require record-variants (regression)

Location:

release/5/mailbox/trunk

Files:

• mailbox.egg (modified) (1 diff)
• mailbox.scm (modified) (3 diffs)

release/5/mailbox/trunk/mailbox.egg

@@ -5 +5 @@
 ((synopsis "Thread-safe queues with timeout")
  (category hell)
- (version "3.3.7")
+ (version "3.3.8")
  (author "[[felix winkelman]] and [[kon lovett]]")
  (license "BSD")
- (dependencies srfi-1 srfi-18 record-variants)
+ (dependencies srfi-1 srfi-18)
  (test-dependencies test)
  (components

release/5/mailbox/trunk/mailbox.scm

@@ -72 +72 @@
     current-thread
     thread-signal! thread-sleep!
-    thread-suspend! thread-resume!)
-  record-variants)
+    thread-suspend! thread-resume!))
 
 ;;; Support
+
+;;record-variants
+
+(define-syntax define-record-type-variant
+  (er-macro-transformer
+   (lambda (form r c)
+     (define (any p L)
+       (and (pair? L)
+            (or (p (car L))
+                (any p (cdr L)))))
+     (##sys#check-syntax 'define-record-type-variant form
+                         '(_ _ #(variable 0)
+                             #(variable 1) _ . _))
+     (let* ((name-spec (cadr form))
+            (name (if (pair? name-spec) (car name-spec) name-spec))
+            (t (if (pair? name-spec) (cadr name-spec) name-spec))
+            (variant? (lambda (type) (any (lambda (x) (c x (r type)))
+                                          (caddr form))))
+            (unsafe? (variant? 'unsafe))
+            (unchecked? (variant? 'unchecked))
+            (inline? (variant? 'inline))
+            (constructor? (eq? name t))
+
+            (conser (cadddr form))
+            (predspec (car (cddddr form)))
+            (pred (if (pair? predspec) (car predspec) predspec))
+            (checker (if (and (pair? predspec)
+                              (pair? (cdr predspec)))
+                         (cadr predspec) #f))
+            (slots (cdr (cddddr form)))
+            (%begin (r 'begin))
+            (%lambda (r 'lambda))
+            (%define (if inline? (r 'define-inline) (r 'define)))
+            (vars (cdr conser))
+            (x (r 'x))
+            (y (r 'y))
+            (%getter-with-setter (r 'getter-with-setter))
+            (slotnames (map car slots)))
+       `(,%begin
+         ,(if constructor?
+              `(,%define ,conser
+                         (##sys#make-structure
+                          ,t
+                          ,@(map (lambda (sname)
+                                   (if (memq sname vars)
+                                       sname
+                                       '(##core#undefined)))
+                                 slotnames)))
+              `(,%begin))
+         (,%define (,pred ,x) (##sys#structure? ,x ,t))
+         ,(if checker
+              `(,%define (,checker ,x)
+                         (##core#check (##sys#check-structure ,x ,t)))
+              `(,%begin))
+         ,@(let loop ([slots slots] [i 1])
+             (if (null? slots)
+                 '()
+                 (let* ([slot (car slots)]
+                        (setters (memq #:record-setters ##sys#features))
+                        (setr? (pair? (cddr slot)))
+                        (getr `(,%lambda (,x)
+                                         ,(if unchecked?
+                                              `(,%begin)
+                                              `(##core#check
+                                                (##sys#check-structure ,x ,t)))
+                                         ,(if unsafe?
+                                              `(##sys#slot ,x ,i)
+                                              `(##sys#block-ref ,x ,i)))))
+                   `(,@(if setr?
+                           `((,%define (,(caddr slot) ,x ,y)
+                                       ,(if unchecked?
+                                            `(,%begin)
+                                            `(##core#check
+                                              (##sys#check-structure ,x ,t)))
+                                       ,(if unsafe?
+                                            `(##sys#setslot ,x ,i ,y)
+                                            `(##sys#block-set! ,x ,i ,y))))
+                           '())
+                     (,%define ,(cadr slot)
+                               ,(if (and setr? setters)
+                                    `(,%getter-with-setter ,getr ,(caddr slot))
+                                    getr) )
+                     ,@(loop (cdr slots) (add1 i)))))))))))
 
 ;;miscmacros
@@ -109 +191 @@
 
 ;;
-
-(define-inline (%delq! x ls0)
-  ;(assert (proper-list? ls0))
-  (let find-elm ((ls ls0) (ppr #f))
-    (cond ((null? ls)
-           ls0 )
-          ((eq? x (car ls))
-           (cond (ppr
-                  (set-cdr! ppr (cdr ls))
-                  ls0 )
-                 (else
-                  (cdr ls) ) ) )
-          (else
-           (find-elm (cdr ls) ls) ) ) ) )
 
 (define-inline (%thread-blocked? th) (eq? 'blocked (##sys#slot th 3)))
@@ -238 +306 @@
 
 (define-inline (%mailbox-waiters-delete! mb th)
-  (%mailbox-waiters-set! mb (%delq! th (%mailbox-waiters mb))) )
+  (%mailbox-waiters-set! mb (delete! th (%mailbox-waiters mb))) )
 
 (define-inline (%mailbox-waiters-pop! mb)