Hi all, Here's a relatively straightforward patch, which fixes #1581 as we discussed at SaarCHICKEN.
Cheers, Peter
From 3f14284a504ec86e0e3410c6f760755ee2de404f Mon Sep 17 00:00:00 2001 From: Peter Bex <[email protected]> Date: Sun, 7 Apr 2019 23:24:35 +0200 Subject: [PATCH] Allow record-instance? without module name prefix Fixes #1581 --- NEWS | 3 +++ lolevel.scm | 11 +++++++-- manual/Module (chicken memory representation) | 7 +++++- tests/lolevel-tests.scm | 33 +++++++++++++++++++++++++++ 4 files changed, 51 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index 2d3e62fb..4306d446 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,9 @@ than #!key, #!rest or #!optional is now preserved (#1572). - When using (set-file-position!) on a port, its EOF status will now be reset. + - record-instance? now returns #t for records created by a constructor + from a module when given an symbol that is not prefixed by any + module name. If it is prefixed, it works as before (#1581). - Runtime system - Removed the unused, undocumented (and incorrect!) C functions diff --git a/lolevel.scm b/lolevel.scm index f5cbffb4..59eabf12 100644 --- a/lolevel.scm +++ b/lolevel.scm @@ -414,7 +414,8 @@ EOF record-instance-slot-set! record-instance-type record-instance? set-procedure-data! vector-like?) -(import scheme chicken.base chicken.fixnum chicken.foreign) + (import scheme chicken.base chicken.fixnum chicken.foreign + chicken.string) ;;; Copy arbitrary object: @@ -503,7 +504,13 @@ EOF (define (record-instance? x #!optional type) (and (%record-structure? x) (or (not type) - (eq? type (##sys#slot x 0)))) ) + (eq? type (##sys#slot x 0)) + (and-let* ((record-type (##sys#slot x 0)) + (str-type (symbol->string record-type)) + (t (string-split str-type "#" #t)) + ((pair? (cdr t))) + (plain-name (string->symbol (cadr t)))) + (eq? plain-name type) ) ) ) ) (define (record-instance-type x) (##sys#check-generic-structure x 'record-instance-type) diff --git a/manual/Module (chicken memory representation) b/manual/Module (chicken memory representation) index 765e3209..7d53da5f 100644 --- a/manual/Module (chicken memory representation) +++ b/manual/Module (chicken memory representation) @@ -160,7 +160,12 @@ expands into something quite similar to: Returns {{#t}} if {{X}} is a record structure, or {{#f}} otherwise. Further, returns {{#t}} if {{X}} is of type {{SYMBOL}}, or {{#f}} -otherwise. +otherwise. {{SYMBOL}} can be fully qualified +(e.g. {{module-name#record-name}}) or a plain symbol without module +prefix (e.g. {{record-name}}). + +If the symbol is not prefixed by a module name, it will return {{#t}} +for the record type of that name from ''any'' module. ==== record-instance-type diff --git a/tests/lolevel-tests.scm b/tests/lolevel-tests.scm index 332102a2..320dfb09 100644 --- a/tests/lolevel-tests.scm +++ b/tests/lolevel-tests.scm @@ -261,13 +261,46 @@ (assert (record-instance? some-record 'test)) +(define-record rec) + +(define global-rec (make-rec)) + +(define a-rec (module module-a () + (import (chicken base)) + (define-record rec bar) + (make-rec 1))) + +(define b-rec (module module-b (make-rec) + (import (chicken base)) + (define-record rec bar qux) + (make-rec 1 2))) + +(assert (not (record-instance? global-rec 'test))) +(assert (record-instance? global-rec 'rec)) +(assert (not (record-instance? global-rec 'module-a#rec))) +(assert (not (record-instance? global-rec 'module-b#rec))) + +(assert (not (record-instance? a-rec 'test))) +(assert (record-instance? a-rec 'rec)) +(assert (record-instance? a-rec 'module-a#rec)) +(assert (not (record-instance? a-rec 'module-b#rec))) + +(assert (not (record-instance? b-rec 'test))) +(assert (record-instance? b-rec 'rec)) +(assert (not (record-instance? b-rec 'module-a#rec))) +(assert (record-instance? b-rec 'module-b#rec)) + ; record-instance-type (assert (eq? 'test (record-instance-type some-record))) +(assert (eq? 'module-a#rec (record-instance-type a-rec))) ; record-instance-length (assert (= 2 (record-instance-length some-record))) +(assert (= 0 (record-instance-length global-rec))) +(assert (= 1 (record-instance-length a-rec))) +(assert (= 2 (record-instance-length b-rec))) ; record-instance-slot-set! -- 2.11.0
signature.asc
Description: PGP signature
_______________________________________________ Chicken-hackers mailing list [email protected] https://lists.nongnu.org/mailman/listinfo/chicken-hackers
