Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

changed the object writer to use a special writer for r6rs records

  • Loading branch information...
commit 3eff7812fe79468c2d4714aa61e0c9cbec755ea5 1 parent 5af6a0a
@marcomaggi authored
Showing with 49 additions and 18 deletions.
  1. +21 −18 scheme/ikarus.writer.sls
  2. +28 −0 tests/test-vicare-records-procedural.sps
View
39 scheme/ikarus.writer.sls
@@ -20,8 +20,9 @@
(export write display format printf fprintf print-error
print-unicode print-graph put-datum traverse
traversal-helpers)
-
- (import
+ (import (except (ikarus)
+ write display format printf fprintf print-error print-unicode print-graph
+ put-datum)
(rnrs hashtables)
(ikarus system $chars)
(ikarus system $strings)
@@ -40,9 +41,8 @@
input/output-port?)
io.)
(only (ikarus.pretty-formats) get-fmt)
- (except (ikarus)
- write display format printf fprintf print-error print-unicode print-graph
- put-datum))
+ (only (ikarus records procedural)
+ print-r6rs-record-instance))
(define print-unicode
(make-parameter #f))
@@ -540,19 +540,22 @@
(write-char* "#<unknown>" p)
i]
[else
- (write-char #\# p)
- (write-char #\[ p)
- (let ([i (wr (struct-name x) p m h i)])
- (let ([n (struct-length x)])
- (let f ([idx 0] [i i])
- (cond
- [(fx= idx n)
- (write-char #\] p)
- i]
- [else
- (write-char #\space p)
- (f (fxadd1 idx)
- (wr (struct-ref x idx) p m h i))]))))]))
+ (if (record-type-descriptor? (struct-type-descriptor x))
+ (print-r6rs-record-instance x p)
+ (begin ;it is a Vicare's struct
+ (write-char #\# p)
+ (write-char #\[ p)
+ (let ([i (wr (struct-name x) p m h i)])
+ (let ([n (struct-length x)])
+ (let f ([idx 0] [i i])
+ (cond
+ [(fx= idx n)
+ (write-char #\] p)
+ i]
+ [else
+ (write-char #\space p)
+ (f (fxadd1 idx)
+ (wr (struct-ref x idx) p m h i))]))))))]))
(define (write-custom-struct out p m h i)
(let ([i
(let f ([cache (cdr out)])
View
28 tests/test-vicare-records-procedural.sps
@@ -623,6 +623,34 @@
((record-predicate rtd) (builder)))
=> #t))
+ (check ;protocol function calling maker directly
+ (catch #f
+ (let* ((rtd (make-record-type-descriptor
+ (name: 'rtd-0) (parent: #f) (uid: #f)
+ (sealed: #f) (opaque: #f) (fields: '#()))))
+ (make-record-constructor-descriptor
+ (rtd: rtd) (parent-rcd: #f) (protocol: (lambda (maker) (maker))))))
+ => '())
+
+ #t)
+
+
+(parametrise ((check-test-name 'printer))
+
+ (check
+ (let* ((rtd (make-record-type-descriptor
+ (name: 'rtd-0) (parent: #f) (uid: #f)
+ (sealed: #f) (opaque: #f) (fields: '#((mutable a) (mutable b)))))
+ (rcd (make-record-constructor-descriptor
+ (rtd: rtd) (parent-rcd: #f) (protocol: #f)))
+ (builder (record-constructor rcd)))
+ (call-with-string-output-port
+ (lambda (port)
+ (display (builder 1 2) port)
+ )))
+ => "#[r6rs-record: rtd-0 a=1 b=2]\n")
+
+
#t)
Please sign in to comment.
Something went wrong with that request. Please try again.