Skip to content

Instantly share code, notes, and snippets.

@yamasushi
Last active Dec 17, 2015
Embed
What would you like to do?
diff --git a/lib/gauche/record.scm b/lib/gauche/record.scm
index f00170d..5f58d85 100644
--- a/lib/gauche/record.scm
+++ b/lib/gauche/record.scm
@@ -1,3 +1,5 @@
+;;; listに対応させるテスト
+
;;;
;;; gauche.record - record implementation
;;;
@@ -33,6 +35,7 @@
(define-module gauche.record
(use gauche.sequence)
+ (use gauche.uvector)
(use srfi-1)
(use util.match)
@@ -74,7 +77,6 @@
;;;
;;; Infrastructure
;;;
-
(define-class <record-meta> (<class>)
((field-specs :init-keyword :field-specs)))
(define-class <record> () () :metaclass <record-meta>)
@@ -82,19 +84,35 @@
(define-class <pseudo-record-meta> (<record-meta>) ())
(define-class <pseudo-record> () () :metaclass <pseudo-record-meta>)
-(define-class <vector-pseudo-record-meta> (<pseudo-record-meta>) ())
-(define-class <vector-pseudo-record> () () :metaclass <vector-pseudo-record-meta>)
-(define-class <list-pseudo-record-meta> (<pseudo-record-meta>) ())
-(define-class <list-pseudo-record> () () :metaclass <list-pseudo-record-meta>)
-
-(define-method pseudo-rtd ((class <vector-meta>))
- <vector-pseudo-record>)
-(define-method pseudo-rtd ((class <vector-pseudo-record-meta>))
- <vector-pseudo-record>)
-(define-method pseudo-rtd ((class <list-meta>))
- <list-pseudo-record>)
-(define-method pseudo-rtd ((class <list-pseudo-record-meta>))
- <list-pseudo-record>)
+(define-macro (define-pr-class type)
+ (let* ([class (string->symbol #`"<,|type|>")]
+ [meta (string->symbol #`"<,|type|-meta>")]
+ [pr-class (string->symbol #`"<,|type|-pseudo-record>")]
+ [pr-meta (string->symbol #`"<,|type|-pseudo-record-meta>")] )
+ `(begin
+ (define-class ,pr-meta (<pseudo-record-meta>) ())
+ (define-class ,pr-class () () :metaclass ,pr-meta)
+ (define-method pseudo-rtd ((class ,meta)) ,pr-class)
+ (define-method pseudo-rtd ((class ,pr-meta)) ,pr-class)
+ ) ) )
+
+(define-macro (define-pr-uv-class tag)
+ (let1 tagvector (string->symbol #`",|tag|vector")
+ `(define-pr-class ,tagvector ) ) )
+
+(define-pr-class vector)
+(define-pr-class list )
+(define-pr-uv-class s8 )
+(define-pr-uv-class u8 )
+(define-pr-uv-class s16)
+(define-pr-uv-class u16)
+(define-pr-uv-class s32)
+(define-pr-uv-class u32)
+(define-pr-uv-class s64)
+(define-pr-uv-class u64)
+(define-pr-uv-class f16)
+(define-pr-uv-class f32)
+(define-pr-uv-class f64)
(define-method pseudo-rtd (other)
(error "pseudo-rtd requires a class object <vector>, <list>, \
or other pseudo-rtd, but got" other))
@@ -237,10 +255,11 @@
`(apply (%make) ,rtd ,@(cdr tmps) ,(car tmps))
`((%makev) ,rtd ,argv))
-(define-ctor-generators %vector-ctor-default %vector-ctor-custom
- `(vector ,@vars)
- `(apply vector ,@(cdr tmps) ,(car tmps))
- argv)
+(define-macro (define-pr-ctor-generators %ctor-default% %ctor-custom% %seq-ctor%)
+ `(define-ctor-generators ,%ctor-default% ,%ctor-custom%
+ ,``(,,%seq-ctor% ,@vars)
+ ,``(apply ,,%seq-ctor% ,@(cdr tmps) ,(car tmps))
+ argv) )
;; Returns a vector where V[k] = i means k-th argument of the constructor
;; initializes i-th field.
@@ -260,15 +279,6 @@
[nfields (vector-length all-names)])
(%record-ctor-custom rtd (vector-length (car rest)))))))
-(define-method rtd-constructor ((rtd <vector-pseudo-record-meta>) . rest)
- (%check-rtd rtd)
- (if (null? rest)
- (%vector-ctor-default rtd (length (slot-ref rtd'slots)))
- (let1 all-names (rtd-all-field-names rtd)
- (let ([mapvec (%calculate-field-mapvec all-names (car rest))]
- [nfields (vector-length all-names)])
- (%vector-ctor-custom rtd (vector-length (car rest)))))))
-
(define-method rtd-predicate ((rtd <record-meta>)) (^o (is-a? o rtd)))
(define-method rtd-predicate ((rtd <pseudo-record-meta>))
(errorf "pseudo record type ~s cannot have a predicate" rtd))
@@ -289,25 +299,93 @@
(^o ((with-module gauche.object %record-ref) rtd o k))
(^(o v) ((with-module gauche.object %record-set!) rtd o k v))))))
-(define-method rtd-accessor ((rtd <vector-pseudo-record-meta>) field)
- (receive (k immutable?) (%get-slot-index rtd field #f)
- (if immutable?
- (^o (vector-ref o k))
- (getter-with-setter
- (^o (vector-ref o k))
- (^(o v) (vector-set! o k v))))))
-
(define-method rtd-mutator ((rtd <record-meta>) field)
(receive (k immutable?) (%get-slot-index rtd field #t)
(when immutable?
(errorf "slot ~a of record ~s is immutable" field rtd))
(^(o v) ((with-module gauche.object %record-set!) rtd o k v))))
-(define-method rtd-mutator ((rtd <vector-pseudo-record-meta>) field)
+(define-syntax define-pr-rtd-constructor
+ (syntax-rules ()
+ [ (_ %metaclass% %ctor-default% %ctor-custom%)
+ (define-method rtd-constructor ((rtd %metaclass%) . rest)
+ (%check-rtd rtd)
+ (if (null? rest)
+ (%ctor-default% rtd (length (slot-ref rtd'slots)))
+ (let1 all-names (rtd-all-field-names rtd)
+ (let ([mapvec (%calculate-field-mapvec all-names (car rest))]
+ [nfields (vector-length all-names)])
+ (%ctor-custom% rtd (vector-length (car rest)))))))
+ ] ) )
+(define-syntax define-pr-rtd-accessor
+ (syntax-rules ()
+ [(_ %metaclass% %ref% %set!% )
+ (define-method rtd-accessor ((rtd %metaclass%) field)
+ (receive (k immutable?) (%get-slot-index rtd field #f)
+ (if immutable?
+ (^[o] (%ref% o k))
+ (getter-with-setter
+ (^[o] (%ref% o k))
+ (^(o v) (%set!% o k v))))))
+ ] ) )
+(define-syntax define-pr-rtd-mutator
+ (syntax-rules ()
+ [(_ %metaclass% %set!% )
+ (define-method rtd-mutator ((rtd %metaclass%) field)
(receive (k immutable?) (%get-slot-index rtd field #t)
(when immutable?
(errorf "slot ~a of record ~s is immutable" field rtd))
- (^(o v) (vector-set! o k v))))
+ (^(o v) (%set!% o k v))))
+ ] ) )
+
+(define-syntax define-pr-rtd-predicate
+ (syntax-rules ()
+ [(_ %metaclass% %seq-class% %len% )
+ (define-method rtd-predicate ((rtd %metaclass%))
+ (^[o] (and
+ (is-a? o %seq-class% )
+ (>= (%len% o) ($ vector-length $ rtd-all-field-names rtd) ) ) ) )
+ ] ) )
+
+(define-macro (define-pr-interfase type)
+ (let* ([class (string->symbol #`"<,|type|>")]
+ [meta (string->symbol #`"<,|type|-meta>")]
+ ;;
+ [pr-class (string->symbol #`"<,|type|-pseudo-record>")]
+ [pr-meta (string->symbol #`"<,|type|-pseudo-record-meta>")]
+ [ctor-default (string->symbol #`"%|type|-ctor-default") ]
+ [ctor-custom (string->symbol #`"%|type|-ctor-custom" ) ]
+ ;;
+ [len (case type
+ [(list) 'length]
+ [else (string->symbol #`",|type|-length")] ) ]
+ [ref (string->symbol #`",|type|-ref")]
+ [set (string->symbol #`",|type|-set!")])
+ `(begin
+ (define-pr-ctor-generators ,ctor-default ,ctor-custom ,type)
+ (define-pr-rtd-constructor ,pr-meta ,ctor-default ,ctor-custom)
+ (define-pr-rtd-accessor ,pr-meta ,ref ,set )
+ (define-pr-rtd-mutator ,pr-meta ,set)
+ (define-pr-rtd-predicate ,pr-meta ,class ,len)
+ ) ) )
+
+(define-macro (define-pr-uv-interfase tag)
+ (let1 tagvector (string->symbol #`",|tag|vector")
+ `(define-pr-interfase ,tagvector) ) )
+
+(define-pr-interfase list)
+(define-pr-interfase vector)
+(define-pr-uv-interfase s8 )
+(define-pr-uv-interfase u8 )
+(define-pr-uv-interfase s16)
+(define-pr-uv-interfase u16)
+(define-pr-uv-interfase s32)
+(define-pr-uv-interfase u32)
+(define-pr-uv-interfase s64)
+(define-pr-uv-interfase u64)
+(define-pr-uv-interfase f16)
+(define-pr-uv-interfase f32)
+(define-pr-uv-interfase f64)
;;;
;;; Syntactic layer
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment