Commit | Line | Data |
---|---|---|
6e7d5622 | 1 | ;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc. |
14f1d9fe | 2 | ;;;; |
73be1d9e MV |
3 | ;;;; This library is free software; you can redistribute it and/or |
4 | ;;;; modify it under the terms of the GNU Lesser General Public | |
5 | ;;;; License as published by the Free Software Foundation; either | |
6 | ;;;; version 2.1 of the License, or (at your option) any later version. | |
14f1d9fe | 7 | ;;;; |
73be1d9e | 8 | ;;;; This library is distributed in the hope that it will be useful, |
14f1d9fe | 9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
11 | ;;;; Lesser General Public License for more details. | |
14f1d9fe | 12 | ;;;; |
73be1d9e MV |
13 | ;;;; You should have received a copy of the GNU Lesser General Public |
14 | ;;;; License along with this library; if not, write to the Free Software | |
92205699 | 15 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
14f1d9fe MD |
16 | ;;;; |
17 | \f | |
18 | ||
4631414e AW |
19 | ;; There are circularities here; you can't import (oop goops compile) |
20 | ;; before (oop goops). So when compiling, make sure that things are | |
21 | ;; kosher. | |
b15dea68 | 22 | (eval-when (compile) (resolve-module '(oop goops))) |
4631414e | 23 | |
14f1d9fe MD |
24 | (define-module (oop goops compile) |
25 | :use-module (oop goops) | |
26 | :use-module (oop goops util) | |
47c8983f | 27 | :export (compute-cmethod) |
14f1d9fe MD |
28 | :no-backtrace |
29 | ) | |
30 | ||
14f1d9fe MD |
31 | ;;; |
32 | ;;; Method entries | |
33 | ;;; | |
34 | ||
35 | (define code-table-lookup | |
36 | (letrec ((check-entry (lambda (entry types) | |
37 | (if (null? types) | |
38 | (and (not (struct? (car entry))) | |
39 | entry) | |
40 | (and (eq? (car entry) (car types)) | |
41 | (check-entry (cdr entry) (cdr types))))))) | |
42 | (lambda (code-table types) | |
43 | (cond ((null? code-table) #f) | |
e177058b | 44 | ((check-entry (car code-table) types)) |
14f1d9fe MD |
45 | (else (code-table-lookup (cdr code-table) types)))))) |
46 | ||
e177058b | 47 | (define (compute-cmethod methods types) |
14f1d9fe MD |
48 | (or (code-table-lookup (slot-ref (car methods) 'code-table) types) |
49 | (let* ((method (car methods)) | |
5487977b AW |
50 | (cmethod (compile-method methods types)) |
51 | (entry (append types cmethod))) | |
52 | (slot-set! method 'code-table | |
53 | (cons entry (slot-ref method 'code-table))) | |
e177058b | 54 | cmethod))) |
14f1d9fe | 55 | |
5487977b | 56 | ;;; |
e177058b | 57 | ;;; Compiling next methods into method bodies |
5487977b AW |
58 | ;;; |
59 | ||
60 | ;;; So, for the reader: there basic idea is that, given that the | |
61 | ;;; semantics of `next-method' depend on the concrete types being | |
62 | ;;; dispatched, why not compile a specific procedure to handle each type | |
47c8983f | 63 | ;;; combination that we see at runtime. |
5487977b AW |
64 | ;;; |
65 | ;;; In theory we can do much better than a bytecode compilation, because | |
66 | ;;; we know the *exact* types of the arguments. It's ideal for native | |
67 | ;;; compilation. A task for the future. | |
68 | ;;; | |
69 | ;;; I think this whole generic application mess would benefit from a | |
70 | ;;; strict MOP. | |
71 | ||
e177058b AW |
72 | (define (compile-method methods types) |
73 | (let ((make-procedure (slot-ref (car methods) 'make-procedure))) | |
74 | (if make-procedure | |
75 | (make-procedure | |
76 | (if (null? methods) | |
77 | (lambda args | |
78 | (no-next-method (method-generic-function (car methods)) args)) | |
79 | (compute-cmethod (cdr methods) types))) | |
80 | (method-procedure (car methods))))) |