From a5c973ce77a236d2f7da8cefadcbfb5f4ef0c84b Mon Sep 17 00:00:00 2001 From: vyzo Date: Mon, 17 Jul 2023 20:00:28 +0300 Subject: [PATCH 1/4] simplify interface macro internals - the syntax quote is harmful, bombs in the interpreter; it is also probably unnecessary, will cross that bridge when we get there. - no need to bind methods in the interface type, dynamic dispatch is against the spirit of interfaces --- src/std/interface.ss | 53 ++++++++------------------------------------ 1 file changed, 9 insertions(+), 44 deletions(-) diff --git a/src/std/interface.ss b/src/std/interface.ss index a80d1f583..8d9b413f5 100644 --- 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 @@ -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?) From 455a41e84089672117a4410133c5311dc916cb56 Mon Sep 17 00:00:00 2001 From: vyzo Date: Mon, 17 Jul 2023 20:05:25 +0300 Subject: [PATCH 2/4] syntax local introduce methods that come from mixins that should help with symbol visibility. --- src/std/interface.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/std/interface.ss b/src/std/interface.ss index 8d9b413f5..674d31665 100644 --- a/src/std/interface.ss +++ b/src/std/interface.ss @@ -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)) From 742f5464174c872ec2613f2856be990aa7ffc65e Mon Sep 17 00:00:00 2001 From: vyzo Date: Mon, 17 Jul 2023 20:02:34 +0300 Subject: [PATCH 3/4] fix typo in :gerbil/gambit/fixnum --- src/gerbil/prelude/gambit/fixnum.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/gerbil/prelude/gambit/fixnum.ss b/src/gerbil/prelude/gambit/fixnum.ss index 92babfe01..b33b16844 100644 --- 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- From 2d297438ae5d104589d89cdcf6eb34b1fb3303fe Mon Sep 17 00:00:00 2001 From: vyzo Date: Tue, 18 Jul 2023 00:41:25 +0300 Subject: [PATCH 4/4] std/test: display expected values on failed checks. --- src/std/test.ss | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/src/std/test.ss b/src/std/test.ss index a7579e340..8faca239a 100644 --- 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))))