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. | |
22 | (eval-case ((compile-toplevel) (resolve-module '(oop goops)))) | |
23 | ||
14f1d9fe MD |
24 | (define-module (oop goops compile) |
25 | :use-module (oop goops) | |
26 | :use-module (oop goops util) | |
e177058b | 27 | :export (compute-cmethod compile-make-procedure) |
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 | |
63 | ;;; combination that we see at runtime. There are two compilation | |
64 | ;;; strategies implemented: one for the memoizer, and one for the VM | |
65 | ;;; compiler. | |
66 | ;;; | |
67 | ;;; In theory we can do much better than a bytecode compilation, because | |
68 | ;;; we know the *exact* types of the arguments. It's ideal for native | |
69 | ;;; compilation. A task for the future. | |
70 | ;;; | |
71 | ;;; I think this whole generic application mess would benefit from a | |
72 | ;;; strict MOP. | |
73 | ||
e177058b AW |
74 | ;;; Temporary solution---return #f if x doesn't refer to `next-method'. |
75 | (define (next-method? x) | |
76 | (and (pair? x) | |
77 | (or (eq? (car x) 'next-method) | |
78 | (next-method? (car x)) | |
79 | (next-method? (cdr x))))) | |
14f1d9fe | 80 | |
e177058b AW |
81 | ;; Called by the `method' macro in goops.scm. |
82 | (define (compile-make-procedure formals specializers body) | |
83 | (and (next-method? body) | |
84 | (let ((next-method-sym (gensym " next-method")) | |
85 | (args-sym (gensym))) | |
86 | `(lambda (,next-method-sym) | |
87 | (lambda ,formals | |
88 | (let ((next-method (lambda ,args-sym | |
89 | (if (null? ,args-sym) | |
90 | ,(if (list? formals) | |
91 | `(,next-method-sym ,@formals) | |
92 | `(apply | |
93 | ,next-method-sym | |
94 | ,@(improper->proper formals))) | |
95 | (apply ,next-method-sym ,args-sym))))) | |
96 | ,@(if (null? body) | |
97 | '((begin)) | |
98 | body))))))) | |
4631414e | 99 | |
e177058b AW |
100 | (define (compile-method methods types) |
101 | (let ((make-procedure (slot-ref (car methods) 'make-procedure))) | |
102 | (if make-procedure | |
103 | (make-procedure | |
104 | (if (null? methods) | |
105 | (lambda args | |
106 | (no-next-method (method-generic-function (car methods)) args)) | |
107 | (compute-cmethod (cdr methods) types))) | |
108 | (method-procedure (car methods))))) |