|
@@ -1,32 +1,32 @@
|
|
|
(module trait (trait?
|
|
|
- define-trait
|
|
|
- define-trait-impl
|
|
|
- with-type
|
|
|
- with-type-of
|
|
|
- ;; functions below are supposed to be used only in
|
|
|
- ;; code generated by macros
|
|
|
- __create_trait
|
|
|
- __trait-get-func
|
|
|
- __trait-reg-func
|
|
|
- __trait-select-func
|
|
|
- __trait-select-func-of
|
|
|
- __trait-reg-func-to-cls)
|
|
|
+ define-trait
|
|
|
+ define-trait-impl
|
|
|
+ with-type
|
|
|
+ with-type-of
|
|
|
+ ;; functions below are supposed to be used only in
|
|
|
+ ;; code generated by macros
|
|
|
+ __create_trait
|
|
|
+ __trait-get-func
|
|
|
+ __trait-reg-func
|
|
|
+ __trait-select-func
|
|
|
+ __trait-select-func-of
|
|
|
+ __trait-reg-func-to-cls)
|
|
|
(import scheme
|
|
|
- (chicken base)
|
|
|
- (chicken syntax)
|
|
|
- srfi-69)
|
|
|
+ (chicken base)
|
|
|
+ (chicken syntax)
|
|
|
+ srfi-69)
|
|
|
|
|
|
(define-syntax define-macro
|
|
|
(er-macro-transformer
|
|
|
(lambda (exp r c)
|
|
|
(let ((def (cadr exp))
|
|
|
- (body (cddr exp)))
|
|
|
+ (body (cddr exp)))
|
|
|
`(define-syntax ,(car def)
|
|
|
- (er-macro-transformer
|
|
|
- (lambda (e2 r2 c2)
|
|
|
- (define (transform-func ,@(cdr def))
|
|
|
- ,@body)
|
|
|
- (apply transform-func (cdr e2)))))))))
|
|
|
+ (er-macro-transformer
|
|
|
+ (lambda (e2 r2 c2)
|
|
|
+ (define (transform-func ,@(cdr def))
|
|
|
+ ,@body)
|
|
|
+ (apply transform-func (cdr e2)))))))))
|
|
|
;; body
|
|
|
(define-record trait name func-names func-table)
|
|
|
|
|
@@ -38,40 +38,40 @@
|
|
|
(define (__trait-select-func pred func name)
|
|
|
(define cls (hash-table-ref func-to-class-table func))
|
|
|
(define func-list (hash-table-ref (trait-func-table cls)
|
|
|
- name))
|
|
|
+ name))
|
|
|
(define (find-in lst)
|
|
|
(if (null? lst)
|
|
|
- '()
|
|
|
- (if (or (eq? pred (caar lst))
|
|
|
- (null? (caar lst)))
|
|
|
- (cdar lst)
|
|
|
- (find-in (cdr lst)))))
|
|
|
+ '()
|
|
|
+ (if (or (eq? pred (caar lst))
|
|
|
+ (null? (caar lst)))
|
|
|
+ (cdar lst)
|
|
|
+ (find-in (cdr lst)))))
|
|
|
(find-in func-list))
|
|
|
|
|
|
(define (__create_trait name func-names default-funcs)
|
|
|
(let ((table (make-hash-table)))
|
|
|
(define cls (make-trait name func-names table))
|
|
|
(define (init-table func-names)
|
|
|
- (if (null? func-names)
|
|
|
- '()
|
|
|
- (let ()
|
|
|
- (hash-table-set! (trait-func-table cls)
|
|
|
- (car func-names)
|
|
|
- '())
|
|
|
- (init-table (cdr func-names)))))
|
|
|
+ (if (null? func-names)
|
|
|
+ '()
|
|
|
+ (let ()
|
|
|
+ (hash-table-set! (trait-func-table cls)
|
|
|
+ (car func-names)
|
|
|
+ '())
|
|
|
+ (init-table (cdr func-names)))))
|
|
|
(init-table func-names)
|
|
|
cls))
|
|
|
|
|
|
(define (__trait-get-func cls func-sym obj)
|
|
|
(define func-list (hash-table-ref (trait-func-table cls)
|
|
|
- func-sym))
|
|
|
+ func-sym))
|
|
|
(define (find-in lst)
|
|
|
(if (null? lst)
|
|
|
- '()
|
|
|
- (if (or (null? (caar lst))
|
|
|
- ((caar lst) obj))
|
|
|
- (cdar lst)
|
|
|
- (find-in (cdr lst)))))
|
|
|
+ '()
|
|
|
+ (if (or (null? (caar lst))
|
|
|
+ ((caar lst) obj))
|
|
|
+ (cdar lst)
|
|
|
+ (find-in (cdr lst)))))
|
|
|
(find-in func-list))
|
|
|
|
|
|
(define (__trait-select-func-of obj func name)
|
|
@@ -81,40 +81,40 @@
|
|
|
(define (__trait-reg-func cls func-sym pred func)
|
|
|
(define func-table (trait-func-table cls))
|
|
|
(hash-table-set! func-table
|
|
|
- func-sym
|
|
|
- (cons (cons pred func)
|
|
|
- (hash-table-ref func-table func-sym))))
|
|
|
+ func-sym
|
|
|
+ (cons (cons pred func)
|
|
|
+ (hash-table-ref func-table func-sym))))
|
|
|
|
|
|
(define-macro (define-trait name . body)
|
|
|
(let ()
|
|
|
(define (func-def-tr entry)
|
|
|
- (define args (gensym))
|
|
|
- `(begin
|
|
|
- (define (,(car entry) . ,args)
|
|
|
- (apply (__trait-get-func ,name
|
|
|
- (quote ,(car entry))
|
|
|
- (car ,args))
|
|
|
- ,args))
|
|
|
- (__trait-reg-func-to-cls ,(car entry) ,name)))
|
|
|
+ (define args (gensym))
|
|
|
+ `(begin
|
|
|
+ (define (,(car entry) . ,args)
|
|
|
+ (apply (__trait-get-func ,name
|
|
|
+ (quote ,(car entry))
|
|
|
+ (car ,args))
|
|
|
+ ,args))
|
|
|
+ (__trait-reg-func-to-cls ,(car entry) ,name)))
|
|
|
(define (default-func-register-tr entry)
|
|
|
- `(__trait-reg-func ,name
|
|
|
- (quote ,(car entry))
|
|
|
- '()
|
|
|
- ,(if (null? (cdr entry))
|
|
|
- '(quote ())
|
|
|
- (cadr entry))))
|
|
|
+ `(__trait-reg-func ,name
|
|
|
+ (quote ,(car entry))
|
|
|
+ '()
|
|
|
+ ,(if (null? (cdr entry))
|
|
|
+ '(quote ())
|
|
|
+ (cadr entry))))
|
|
|
(define (define-trait-tr name . body)
|
|
|
- `(begin
|
|
|
- (define ,name
|
|
|
- (__create_trait (quote ,name)
|
|
|
- (quote ,(map car body))
|
|
|
- (quote ,(map (lambda (x)
|
|
|
- (if (null? (cdr x))
|
|
|
- '()
|
|
|
- (cadr x)))
|
|
|
- body))))
|
|
|
- ,@(map func-def-tr body)
|
|
|
- ,@(map default-func-register-tr body)))
|
|
|
+ `(begin
|
|
|
+ (define ,name
|
|
|
+ (__create_trait (quote ,name)
|
|
|
+ (quote ,(map car body))
|
|
|
+ (quote ,(map (lambda (x)
|
|
|
+ (if (null? (cdr x))
|
|
|
+ '()
|
|
|
+ (cadr x)))
|
|
|
+ body))))
|
|
|
+ ,@(map func-def-tr body)
|
|
|
+ ,@(map default-func-register-tr body)))
|
|
|
(define form (apply define-trait-tr (cons name body)))
|
|
|
;; (display form) (newline)
|
|
|
form))
|
|
@@ -122,15 +122,15 @@
|
|
|
(define-macro (define-trait-impl name . body)
|
|
|
(let ()
|
|
|
(define (define-trait-impl-tr name . body)
|
|
|
- (define cls (car name))
|
|
|
- (define pred (cadr name))
|
|
|
- (define (reg-func-tr entry)
|
|
|
- `(__trait-reg-func ,cls
|
|
|
- (quote ,(car entry))
|
|
|
- ,pred
|
|
|
- ,(cadr entry)))
|
|
|
- `(begin
|
|
|
- ,@(map reg-func-tr body)))
|
|
|
+ (define cls (car name))
|
|
|
+ (define pred (cadr name))
|
|
|
+ (define (reg-func-tr entry)
|
|
|
+ `(__trait-reg-func ,cls
|
|
|
+ (quote ,(car entry))
|
|
|
+ ,pred
|
|
|
+ ,(cadr entry)))
|
|
|
+ `(begin
|
|
|
+ ,@(map reg-func-tr body)))
|
|
|
(define form (apply define-trait-impl-tr (cons name body)))
|
|
|
;; (display form) (newline)
|
|
|
form))
|