fix interface mixins (#1247)

they were broken in the transition to core.
mighty-gerbils · Jun 15, 2024 · 1f8a942 · 1f8a942
1 parent 101bd88
commit 1f8a942
Show file tree

Hide file tree

Showing 3 changed files with 42 additions and 28 deletions.
diff --git a/src/gerbil/core/contract.ss b/src/gerbil/core/contract.ss
@@ -1081,7 +1081,7 @@ package: gerbil/core
 
     (def (make-procedure-lambda-signature stx signature return unchecked)
       (def (type-e contract)
-        (syntax-case contract (: :? :~ :- ::= :=)
+        (syntax-case contract (: :? :~ :- ::- :=)
           ((: type . maybe-default)
            (resolve-type->type-descriptor stx #'type))
           ((~ type . maybe-default)
@@ -1203,30 +1203,39 @@ package: gerbil/core
           (_ (reverse! (filter identity result))))))
 
     (def (compatible-signatures? left right)
-      (let/cc return
-        (let ((left-arity (signature-arity left))
-              (right-arity (signature-arity right)))
-          (unless (equal? left-arity right-arity)
-            (return #f)))
-        (let ((left-kws (signature-keywords left))
-              (right-kws (signature-keywords right)))
-          (unless (equal? left-kws right-kws)
-            (return #f)))
-        (let (((values left-positional-contract left-kw-contract)
-               (signature-type-contract left))
-              ((values right-positional-contract right-kw-contract)
-               (signature-type-contract right)))
-          (let ((left-contract
-                 (append left-positional-contract
-                         (foldr (lambda (kwc r) (cons (cdr kwc) r))
-                                [] left-kw-contract)))
-                (right-contract
-                 (append right-positional-contract
-                         (foldr (lambda (kwc r) (cons (cdr kwc) r))
-                                [] right-kw-contract))))
-            (unless (compatible-signature-type-contract? left-contract right-contract)
-              (return #f))))
-        #t))
+      (let ((left (syntax->list left))
+            (right (syntax->list right)))
+        (let ((left-args (cadr left))
+              (left-return (caddr left))
+              (right-args (cadr right))
+              (right-return (caddr right)))
+          (let/cc return
+            (let ((left-arity (signature-arity left-args))
+                  (right-arity (signature-arity right-args)))
+              (unless (equal? left-arity right-arity)
+                (return #f)))
+            (let ((left-kws (signature-keywords left-args))
+                  (right-kws (signature-keywords right-args)))
+              (unless (equal? left-kws right-kws)
+                (return #f)))
+            (let (((values left-positional-contract left-kw-contract)
+                   (signature-type-contract left-args))
+                  ((values right-positional-contract right-kw-contract)
+                   (signature-type-contract right-args)))
+              (let ((left-contract
+                     (append left-positional-contract
+                             (foldr (lambda (kwc r) (cons (cdr kwc) r))
+                                    [] left-kw-contract)))
+                    (right-contract
+                     (append right-positional-contract
+                             (foldr (lambda (kwc r) (cons (cdr kwc) r))
+                                    [] right-kw-contract))))
+                (unless (compatible-signature-type-contract? left-contract right-contract)
+                  (return #f))))
+            (unless (free-identifier=? (resolve-type->identifier left left-return)
+                                       (resolve-type->identifier right right-return))
+              (return #f))
+            #t))))
 
     (def (compatible-signature-type-contract? left right)
       (let loop ((left-rest left) (right-rest right))
@@ -1425,7 +1434,7 @@ package: gerbil/core
 
 
     (def (signature-arity spec)
-      (let lp ((rest (stx-cdr spec)) (required 0) (optional 0))
+      (let lp ((rest spec) (required 0) (optional 0))
         (syntax-case rest (:=)
           ((id . rest)
            (identifier? #'id)
@@ -1556,7 +1565,7 @@ package: gerbil/core
                       (predicate (stx-identifier #'name #'name "?"))
                       (instance-predicate (stx-identifier #'name "is-" #'name "?"))
                       ((mixin ...)
-                       (if (identifier? #'hd) [] (stx-cdr #'hd)))
+                       (if (identifier? #'hd) [] (syntax->list (stx-cdr #'hd))))
                       ((method ...)
                        (fold-methods #'(mixin ...) #'(spec ...)))
                       ((method-name ...)

diff --git a/src/gerbil/test/compiler-test-support/interface-mixin.ss b/src/gerbil/test/compiler-test-support/interface-mixin.ss
@@ -0,0 +1,3 @@
+(import :std/io)
+
+(interface (TestMixin Reader Writer))
diff --git a/src/gerbil/test/compiler-test.ss b/src/gerbil/test/compiler-test.ss
@@ -84,4 +84,6 @@
 (def compiler-syntax-test
   (test-suite "compiler syntactic features"
     (test-case "deep dots"
-      (must-compile-and-execute "compiler-test-support/deep-dots.ss"))))
+      (must-compile-and-execute "compiler-test-support/deep-dots.ss"))
+    (test-case "interface mixins"
+      (must-compile-and-execute "compiler-test-support/interface-mixin.ss"))))