Merge pull request #729 from vyzo/misc-fixes

Miscellaneous fixes
mighty-gerbils · Jul 18, 2023 · 981110a · 981110a
2 parents d323131 + 2d29743
commit 981110a
Show file tree

Hide file tree

Showing 3 changed files with 23 additions and 57 deletions.
diff --git a/src/gerbil/prelude/gambit/fixnum.ss b/src/gerbil/prelude/gambit/fixnum.ss
@@ -5,7 +5,7 @@ package: gerbil/gambit
 
 (export #t)
 (extern namespace: #f
-  fxarithmetic-shift-left fxarithmetic-shift-right fxarithmetic-shift-left
+  fxarithmetic-shift-left fxarithmetic-shift-right fxarithmetic-shift
   fxbit-count fxfirst-set-bit fxif fxlength
   fxquotient fxremainder
   fxwrap* fxwrap+ fxwrap-

diff --git a/src/std/interface.ss b/src/std/interface.ss
@@ -7,7 +7,7 @@
                     (only-in :std/sort sort)
                     (only-in :std/misc/symbol compare-symbolic)))
 (export interface interface-out
-        interface-instance?
+        interface-instance? interface-instance-object
         interface-descriptor? interface-descriptor-type interface-descriptor-methods)
 
 ;; base type for all interface instances
@@ -93,7 +93,7 @@
                      (let (info (syntax-local-value spec false))
                        (unless (interface-info? info)
                          (raise-syntax-error #f "Bad syntax; not an interface type" stx spec))
-                       (foldl cons methods (interface-info-methods info)))
+                       (foldl cons methods (map syntax-local-introduce (interface-info-methods info))))
                      (cons spec methods)))
                  []
                  specs))
@@ -178,8 +178,8 @@
       (mixin (identifier? #'mixin) #t)
       (_ #f)))
 
-  (def (method-formals? args)
-    (let lp ((rest args))
+  (def (method-formals? signature)
+    (let lp ((rest signature))
       (syntax-case rest ()
         ((id . rest)
          (identifier? #'id)
@@ -197,8 +197,8 @@
         (() #t)
         (_ #f))))
 
-  (def (method-arguments spec)
-    (let lp ((rest spec) (args []))
+  (def (method-arguments signature)
+    (let lp ((rest signature) (args []))
       (syntax-case rest ()
         ((id . rest)
          (identifier? #'id)
@@ -215,38 +215,13 @@
         (id
          (identifier? #'id)
          (let (args (foldl cons [#'id] args))
-           (check-duplicate-identifiers args spec)
+           (check-duplicate-identifiers args signature)
            args))
         (()
          (let (args (reverse args))
-           (check-duplicate-identifiers args spec)
+           (check-duplicate-identifiers args signature)
            args)))))
 
-  (def (quote-method spec)
-    (syntax-case spec ()
-      ((id . rest)
-       (identifier? #'id)
-       (cons #'id (quote-method #'rest)))
-      (((id default) . rest)
-       (identifier? #'id)
-       (cons [#'id (quote-expr #'default)] (quote-method #'rest)))
-      ((kw id . rest)
-       (and (keyword? #'kw) (identifier? #'id))
-       (cons* #'kw #'id (quote-method #'rest)))
-      ((kw (id default) . rest)
-       (and (keyword? #'kw) (identifier? #'id))
-       (cons* #'kw [#'id (quote-expr #'default)] (quote-method #'rest)))
-      (tail #'tail)))
-
-  (def (quote-expr expr)
-    (syntax-case expr ()
-      ((hd . rest)
-       (cons (quote-expr #'hd) (quote-expr #'rest)))
-      (id
-       (identifier? #'id)
-       #'(unquote (quote-syntax id)))
-      (_ expr)))
-
   (syntax-case stx ()
     ((_ hd spec ...)
      (or (identifier? #'hd)
@@ -316,13 +291,6 @@
                           #'(unchecked-method-impl-name ...)
                           #'(method-signature ...)
                           (iota (length #'(method-name ...)) 2)))
-                    ((bind-method-impl ...)
-                     (map (lambda (method-name method-impl-name)
-                            (with-syntax ((method-name method-name)
-                                          (method-impl method-impl-name))
-                              #'(bind-method! klass 'method-name method-impl)))
-                          #'(method-name ...)
-                          #'(method-impl-name ...)))
                     (field-count
                      (length #'(method-name ...)))
                     (defklass
@@ -346,12 +314,10 @@
                     (defpred-instance
                       #'(def (instance-predicate obj)
                           (satisfies? descriptor obj)))
-                    ((quoted-method ...)
-                     (map quote-method #'(method ...)))
                     (definfo
                       #'(defsyntax name
                           (make-interface-info 'name
-                                               `(quoted-method ...)
+                                               '(method ...)
                                                (quote-syntax klass)
                                                (quote-syntax descriptor)
                                                (quote-syntax make)
@@ -360,8 +326,7 @@
                                                [(quote-syntax method-impl-name) ...]
                                                [(quote-syntax unchecked-method-impl-name) ...]))))
        #'(begin defklass defdescriptor defmake defpred defpred-instance definfo
-                defmethod-impl ...
-                bind-method-impl ...)))))
+                defmethod-impl ...)))))
 
 (defsyntax-for-export (interface-out stx)
   (def (expand body unchecked?)

diff --git a/src/std/test.ss b/src/std/test.ss
@@ -22,7 +22,7 @@
   test-result
   test-report-summary!)
 
-(defstruct !check-fail (e value loc))
+(defstruct !check-fail (e value expected loc))
 (defstruct !check-error (exn check loc))
 (defstruct !test-suite (desc thunk tests))
 (defstruct !test-case (desc checks fail error))
@@ -36,9 +36,9 @@
 ;; this is only necessary for stray checks outside a test-case
 (defmethod {display-exception !check-fail}
   (lambda (self port)
-    (with ((!check-fail check value loc) self)
-      (fprintf port "check ~a at ~a FAILED: ~a~n"
-               check loc value))))
+    (with ((!check-fail check value expected loc) self)
+      (fprintf port "check ~a at ~a FAILED: ~a [expected: ~a]~n"
+               check loc value expected))))
 
 (def *test-verbose* #t)
 
@@ -252,10 +252,11 @@
   (cond
    ((!test-case-fail tc)
     => (lambda (fail)
-         (eprintf "*** FAILED: ~a at ~a; value: ~s~n"
+         (eprintf "*** FAILED: ~a at ~a; value: ~s; expected: ~a~n"
                   (!check-fail-e fail)
                   (!check-fail-loc fail)
-                  (!check-fail-value fail))))
+                  (!check-fail-value fail)
+                  (!check-fail-expected fail))))
    ((!test-case-error tc)
     => (lambda (e)
          (eprintf "*** ERROR: ")
@@ -272,19 +273,19 @@
   (test-case-add-check! (current-test-case))
   (let (val (with-check-error thunk what loc))
     (unless (eqf val value)
-      (raise (make-!check-fail what val loc)))))
+      (raise (make-!check-fail what val value loc)))))
 
 (def (test-check-output what thunk value loc)
   (test-case-add-check! (current-test-case))
   (let (val (with-output-to-string [] (cut with-check-error thunk what loc)))
     (unless (equal? val value)
-      (raise (make-!check-fail what val loc)))))
+      (raise (make-!check-fail what val value loc)))))
 
 (def (test-check-predicate what thunk pred loc)
   (test-case-add-check! (current-test-case))
   (let (val (with-check-error thunk what loc))
     (unless (pred val)
-      (raise (make-!check-fail what val loc)))))
+      (raise (make-!check-fail what val "(predicate check)" loc)))))
 
 (def (test-check-exception what thunk pred loc)
   (test-case-add-check! (current-test-case))
@@ -293,5 +294,5 @@
       (let ((val (with-catch values (lambda () (thunk) (fail-to-throw)))))
         (if (pred val)
           (success)
-          (raise (make-!check-fail what val loc)))))
-    (raise (make-!check-fail what '(failed to throw an exception) loc))))
+          (raise (make-!check-fail what val "(exception check)" loc)))))
+    (raise (make-!check-fail what "(failed to throw an exception)" "(exception check)" loc))))