source: project/release/5/fast-generic/trunk/fast-generic-compile-time.scm @ 36273

Last change on this file since 36273 was 36273, checked in by Ivan Raikov, 13 months ago

fast-generic: removed unnecessary print

File size: 6.0 KB
Line 
1;;;; fast-generic-compile-time.scm
2
3
4(module fast-generic-compile-time (generic-build-name
5                                   generic-data-add
6                                   build-or-clause
7                                   generic-forms
8                                   is-a
9                                   register-type
10                                   type-heritage)
11
12        (import scheme (chicken base) (chicken syntax) (chicken format)
13                (chicken sort) (chicken plist)
14                srfi-1 matchable)
15
16
17(define (is-a? derived base)
18  (if (eq? derived base)
19      #t
20      (let ((d (get derived 'is-a)))
21        (if (and d (memq base (cdr d)))
22            #t
23            #f))))
24
25(define (is-a derived base)
26  (if (is-a? base derived)
27      (error 'is-a
28             (sprintf "declaring a ~a to be a ~a creates circularity"
29                      derived
30                      base))
31      (let ((d (get derived 'is-a)))
32        (if d
33            (if (and (not (null? (cdr d)))
34                     (not (eq? (cadr d) base)))
35                (warning 
36                 (sprintf "~a is-a ~a replaces ~a is-a ~a"
37                          derived base derived (cadr d))))
38            (begin
39              (set! d (cons derived '()))
40              (put! derived 'is-a d)))
41        (let ((b (get base 'is-a)))
42          (if (not b)
43              (begin
44                (set! b (cons base '()))
45                (put! base 'is-a b)))
46          (set-cdr! d b)))))
47
48(define (generic-forms name)
49  (let ((tree (get name 'generic-trees))
50        (forms '()))
51    (let tree-loop ((tree tree)
52                    (args '()))
53      (if (car tree)
54          (set! forms (cons (cons (car tree) (reverse args)) forms)))
55      (if (not (null? (cdr tree)))
56          (let type-loop ((types (cdr tree)))
57            (if (not (null? types))
58                (begin
59                  (tree-loop (cdar types) (cons (caar types) args))
60                  (type-loop (cdr types)))))))
61    forms))
62
63(define (generic-method-at-depth? d tree)
64  (if (positive? d)
65      (if (or (null? tree)
66              (null? (cdr tree)))
67          #f
68          (any (lambda (x)
69                 (generic-method-at-depth? (- d 1) (cdr x)))
70               (cdr tree)))
71      (car tree)))
72
73(define (generic-build-name name predicates)
74  (letrec ((build-predlist
75            (lambda (preds)
76              (if (null? preds)
77                  ""
78                  (string-append "-"
79                                 (symbol->string (car preds))
80                                 (build-predlist (cdr preds)))))))
81    (string->symbol
82     (string-append (symbol->string name)
83                    "<"
84                    (if (null? predicates)
85                        ""
86                        (string-append (symbol->string (car predicates))
87                                       (build-predlist (cdr predicates))))
88                    ">"))))
89
90(define (generic-tree-depth tree)
91  (if (or (null? tree)
92          (null? (cdr tree)))
93      0
94      (+ 1
95         (apply max (map (lambda (x)
96                           (generic-tree-depth (cdr x)))
97                         (cdr tree))))))
98
99(define (build-next-arg-clause tree arg-names r)
100  (if (null? tree)
101      '#f
102      (let* ((arg (gensym))
103             (arg-names (cons arg arg-names)))
104        `(,(r 'let) ((,arg (,(r 'car) args))
105                     (args (,(r 'cdr) args)))
106          (,(r 'or) ,@(map (lambda (t)
107                             (build-pred-clause t arg-names r)) 
108                           tree))))))
109
110(define (type->predicate t)
111  (let ((types (get (strip-syntax t) 'generic-types)))
112    (if (symbol? types)
113        types                           ; for builtin `any' type
114        (let* ((cm (##sys#current-module))
115               (a (assq cm types)))
116          (if a
117              (cdr a)
118              (error 'define-generic "undefined type" t))))))
119
120(define (type->test t arg r)
121  (if (eq? t 'any)
122      `(##core#let ((,(gensym) ,arg))
123                   #t)
124      (let ((p (type->predicate t)))
125        (list (r p) arg))))
126
127(define (build-pred-clause tree arg-names r)
128  (if (null? tree)
129      `#f
130      `(,(r 'and) ,(type->test (car tree) (car arg-names) r)
131        ,(build-match-clause (cdr tree) arg-names r))))
132
133(define (build-match-clause tree arg-names r)
134  `(,(r 'if) (,(r 'null?) args)
135    ,(if (car tree)
136         `(,(r 'begin)
137           (,(r 'set!) result (,(car tree) ,@(reverse arg-names)))
138           #t)
139         #f)
140    ,(if (null? (cdr tree))
141         #f
142         (build-next-arg-clause (cdr tree) arg-names r))))
143
144(define (generic-tree-insert tree full-name preds)
145  (if (null? tree)
146      (set! tree (cons #f '())))
147  (if (null? preds)
148      (begin
149        (if (car tree)
150            (warning "redefining generic" full-name))
151        (set-car! tree full-name))
152      (let* ((choices (cdr tree))
153             (rest (assq (car preds) choices)))
154        (if rest
155            (set-cdr! rest (generic-tree-insert (cdr rest)
156                                                full-name
157                                                (cdr preds)))
158            (set-cdr! tree
159                      (sort
160                       (cons (cons (car preds)
161                                   (generic-tree-insert
162                                    '() full-name (cdr preds)))
163                             choices)
164                       (lambda (a b) (is-a? (car a) (car b)))
165                       )))))
166  tree)
167
168(define (generic-data-add name full-name preds)
169  (let ((tree (get name 'generic-trees)))
170    (if (not tree)
171        (set! tree '()))
172    (set! tree (generic-tree-insert tree full-name preds))
173    (put! name 'generic-trees tree)))
174
175(define (build-or-clause tree args full-args return-arg r)
176  (if (null? args)
177      `(,(r 'begin) (,(r 'set!) ,return-arg (,(car tree) ,@full-args))
178        #t)
179      (let ((and-clause (build-and-clause (cdr tree)
180                                          args
181                                          full-args
182                                          return-arg
183                                          r)))
184        (if (null? and-clause)
185            #f
186            `(,(r 'or) ,@and-clause)))))
187
188(define (build-and-clause clauses args full-args return-arg r)
189  (if (null? clauses)
190      '()
191      (let ((clause (car clauses))
192            (l (length args))
193            (rest (build-and-clause (cdr clauses)
194                                    args
195                                    full-args
196                                    return-arg
197                                    r)))
198        (let ((or-clause (build-or-clause (cdr clause)
199                                          (cdr args)
200                                          full-args
201                                          return-arg
202                                          r)))
203          (if (generic-method-at-depth? (- l 1) (cdr clause))
204;;            (if ((eval (car clause)) (car raw-args))
205;;                (cons or-clause rest)
206;;                (if (and (symbol? (car raw-args))
207;;                         or-clause)
208;;                    (cons `(,(r 'and) (,(car clause) ,(car args))
209;;                            ,or-clause)
210;;                          rest)
211;;                    rest))
212              (cons `(,(r 'and) ,(type->test (car clause) (car args) r)
213                      ,or-clause)
214                    rest)
215              rest)))))
216
217(define (type-heritage type)
218  (let ((t (get type 'is-a)))
219    (if (not t)
220        (begin
221          (set! t (cons type '()))
222          (put! type 'is-a t)))
223    t))
224
225(define (register-type b p d)
226  (define (defderived b p d)
227    (is-a b (base d))
228    (put! b 'generic-types
229          (cons (cons (##sys#current-module) p)
230                (get b 'generic-types))))
231  (define (base def)
232    (match def
233      ((? symbol?) def)
234      ((b p) (base `(,b ,p any)))
235      (((? symbol? d) p b2)
236       (defderived d p b2)
237       d)))
238  (defderived b p d))
239
240
241(put! 'any 'generic-type '##fast-generic#any?)
242
243)
Note: See TracBrowser for help on using the repository browser.