Commit | Line | Data |
---|---|---|
14f1d9fe MD |
1 | ;;;; Copyright (C) 1999 Free Software Foundation, Inc. |
2 | ;;;; | |
3 | ;;;; This program is free software; you can redistribute it and/or modify | |
4 | ;;;; it under the terms of the GNU General Public License as published by | |
5 | ;;;; the Free Software Foundation; either version 2, or (at your option) | |
6 | ;;;; any later version. | |
7 | ;;;; | |
8 | ;;;; This program is distributed in the hope that it will be useful, | |
9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | ;;;; GNU General Public License for more details. | |
12 | ;;;; | |
13 | ;;;; You should have received a copy of the GNU General Public License | |
14 | ;;;; along with this software; see the file COPYING. If not, write to | |
15 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, | |
16 | ;;;; Boston, MA 02111-1307 USA | |
17 | ;;;; | |
18 | \f | |
19 | ||
20 | (define-module (oop goops compile) | |
21 | :use-module (oop goops) | |
22 | :use-module (oop goops util) | |
23 | :no-backtrace | |
24 | ) | |
25 | ||
26 | (export compute-cmethod compute-entry-with-cmethod | |
27 | compile-method cmethod-code cmethod-environment) | |
28 | ||
29 | (define source-formals cadr) | |
30 | (define source-body cddr) | |
31 | ||
32 | (define cmethod-code cdr) | |
33 | (define cmethod-environment car) | |
34 | ||
35 | ||
36 | ;;; | |
37 | ;;; Method entries | |
38 | ;;; | |
39 | ||
40 | (define code-table-lookup | |
41 | (letrec ((check-entry (lambda (entry types) | |
42 | (if (null? types) | |
43 | (and (not (struct? (car entry))) | |
44 | entry) | |
45 | (and (eq? (car entry) (car types)) | |
46 | (check-entry (cdr entry) (cdr types))))))) | |
47 | (lambda (code-table types) | |
48 | (cond ((null? code-table) #f) | |
49 | ((check-entry (car code-table) types) | |
50 | => (lambda (cmethod) | |
51 | (cons (car code-table) cmethod))) | |
52 | (else (code-table-lookup (cdr code-table) types)))))) | |
53 | ||
54 | (define (compute-entry-with-cmethod methods types) | |
55 | (or (code-table-lookup (slot-ref (car methods) 'code-table) types) | |
56 | (let* ((method (car methods)) | |
57 | (place-holder (list #f)) | |
58 | (entry (append types place-holder))) | |
59 | ;; In order to handle recursion nicely, put the entry | |
60 | ;; into the code-table before compiling the method | |
61 | (slot-set! (car methods) 'code-table | |
62 | (cons entry (slot-ref (car methods) 'code-table))) | |
63 | (let ((cmethod (compile-method methods types))) | |
64 | (set-car! place-holder (car cmethod)) | |
65 | (set-cdr! place-holder (cdr cmethod))) | |
66 | (cons entry place-holder)))) | |
67 | ||
68 | (define (compute-cmethod methods types) | |
69 | (cdr (compute-entry-with-cmethod methods types))) | |
70 | ||
71 | ;;; | |
72 | ;;; Next methods | |
73 | ;;; | |
74 | ||
75 | ;;; Temporary solution---return #f if x doesn't refer to `next-method'. | |
76 | (define (next-method? x) | |
77 | (and (pair? x) | |
78 | (or (eq? (car x) 'next-method) | |
79 | (next-method? (car x)) | |
80 | (next-method? (cdr x))))) | |
81 | ||
82 | (define (make-final-make-next-method method) | |
83 | (lambda default-args | |
84 | (lambda args | |
85 | (@apply method (if (null? args) default-args args))))) | |
86 | ||
87 | (define (make-final-make-no-next-method gf) | |
88 | (lambda default-args | |
89 | (lambda args | |
90 | (no-next-method gf (if (null? args) default-args args))))) | |
91 | ||
92 | (define (make-make-next-method vcell gf methods types) | |
93 | (lambda default-args | |
94 | (lambda args | |
95 | (if (null? methods) | |
96 | (begin | |
97 | (set-cdr! vcell (make-final-make-no-next-method gf)) | |
98 | (no-next-method gf (if (null? args) default-args args))) | |
99 | (let* ((cmethod (compute-cmethod methods types)) | |
100 | (method (local-eval (cons 'lambda (cmethod-code cmethod)) | |
101 | (cmethod-environment cmethod)))) | |
102 | (set-cdr! vcell (make-final-make-next-method method)) | |
103 | (@apply method (if (null? args) default-args args))))))) | |
104 | ||
105 | ;;; | |
106 | ;;; Method compilation | |
107 | ;;; | |
108 | ||
109 | ;;; NOTE: This section is far from finished. It will finally be | |
110 | ;;; implemented on C level. | |
111 | ||
112 | (define (compile-method methods types) | |
113 | (let* ((proc (method-procedure (car methods))) | |
114 | (src (procedure-source proc)) | |
115 | (formals (source-formals src)) | |
116 | (body (source-body src))) | |
117 | (if (next-method? body) | |
118 | (let ((vcell (cons 'goops:make-next-method #f))) | |
119 | (set-cdr! vcell | |
120 | (make-make-next-method | |
121 | vcell | |
122 | (method-generic-function (car methods)) | |
123 | (cdr methods) types)) | |
124 | ;;*fixme* | |
125 | `(,(cons vcell (procedure-environment proc)) | |
126 | ,formals | |
127 | ;;*fixme* Only do this on source where next-method can't be inlined | |
128 | (let ((next-method ,(if (list? formals) | |
129 | `(goops:make-next-method ,@formals) | |
130 | `(apply goops:make-next-method | |
131 | ,@(improper->proper formals))))) | |
132 | ,@body))) | |
133 | (cons (procedure-environment proc) | |
134 | (cons formals | |
135 | body)) | |
136 | ))) |