|
|
@@ -44,9 +44,9 @@
|
|
|
(define (func-def-tr entry)
|
|
|
(define args (gensym))
|
|
|
`(define ,(car entry)
|
|
|
- ,(if (null? (cdr entry))
|
|
|
- ''()
|
|
|
- (cadr entry))))
|
|
|
+ ,(if (null? (cdr entry))
|
|
|
+ ''()
|
|
|
+ (cadr entry))))
|
|
|
(define (define-trait-tr name . body)
|
|
|
`(begin
|
|
|
(define ,name
|
|
|
@@ -88,10 +88,10 @@
|
|
|
(create-trait (quote ,cls)
|
|
|
(quote ,(map car body))
|
|
|
(list ,@(map (lambda (x)
|
|
|
- (if (null? (cdr x))
|
|
|
- ''()
|
|
|
- (cadr x)))
|
|
|
- body))
|
|
|
+ (if (null? (cdr x))
|
|
|
+ ''()
|
|
|
+ (cadr x)))
|
|
|
+ body))
|
|
|
,pred
|
|
|
,old-cls))
|
|
|
,@(map func-def-tr body)))
|
|
|
@@ -109,4 +109,36 @@
|
|
|
(else (loop (trait-parent cur))))))
|
|
|
|
|
|
(define-macro (with-type-of obj trait func)
|
|
|
- `(get-trait-func ,trait ,obj (quote ,func))))
|
|
|
+ `(get-trait-func ,trait ,obj (quote ,func)))
|
|
|
+
|
|
|
+ (define-syntax define-overload
|
|
|
+ (ir-macro-transformer
|
|
|
+ (lambda (e i c)
|
|
|
+ (define (impl def . body)
|
|
|
+ (define name (car def))
|
|
|
+ (define (get-param-names args)
|
|
|
+ (let loop ((lst args) (ret '()))
|
|
|
+ (if (null? lst)
|
|
|
+ (reverse ret)
|
|
|
+ (if (symbol? (car lst))
|
|
|
+ (loop (cdr lst) (cons (car lst) ret))
|
|
|
+ (loop (cdr lst) (cons (caar lst) ret))))))
|
|
|
+ (define (get-preds args)
|
|
|
+ (let loop ((lst args) (ret '()))
|
|
|
+ (if (null? lst)
|
|
|
+ (reverse ret)
|
|
|
+ (if (list? (car lst))
|
|
|
+ (loop (cdr lst) (cons (reverse (car lst)) ret))
|
|
|
+ (loop (cdr lst) ret)))))
|
|
|
+ (define param-names (get-param-names (cdr def)))
|
|
|
+ (define preds (get-preds (cdr def)))
|
|
|
+ (define old-func (gensym))
|
|
|
+ `(begin
|
|
|
+ (define ,old-func ,name)
|
|
|
+ (define (,name ,@param-names)
|
|
|
+ (if (and ,@preds)
|
|
|
+ ((lambda (,@param-names) ,@body) ,@param-names)
|
|
|
+ (,old-func ,@param-names)))))
|
|
|
+ (define form (apply impl (cdr e)))
|
|
|
+ ;; (display form) (newline)
|
|
|
+ form))))
|
