Commit | Line | Data |
---|---|---|
b432fb4b | 1 | ;;;; Copyright (C) 1999, 2001 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 | |
15 | ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
14f1d9fe MD |
16 | ;;;; |
17 | \f | |
18 | ||
19 | (define-module (oop goops compile) | |
20 | :use-module (oop goops) | |
21 | :use-module (oop goops util) | |
1a179b03 MD |
22 | :export (compute-cmethod compute-entry-with-cmethod |
23 | compile-method cmethod-code cmethod-environment) | |
14f1d9fe MD |
24 | :no-backtrace |
25 | ) | |
26 | ||
14f1d9fe MD |
27 | (define source-formals cadr) |
28 | (define source-body cddr) | |
29 | ||
30 | (define cmethod-code cdr) | |
31 | (define cmethod-environment car) | |
32 | ||
33 | ||
34 | ;;; | |
35 | ;;; Method entries | |
36 | ;;; | |
37 | ||
38 | (define code-table-lookup | |
39 | (letrec ((check-entry (lambda (entry types) | |
40 | (if (null? types) | |
41 | (and (not (struct? (car entry))) | |
42 | entry) | |
43 | (and (eq? (car entry) (car types)) | |
44 | (check-entry (cdr entry) (cdr types))))))) | |
45 | (lambda (code-table types) | |
46 | (cond ((null? code-table) #f) | |
47 | ((check-entry (car code-table) types) | |
48 | => (lambda (cmethod) | |
49 | (cons (car code-table) cmethod))) | |
50 | (else (code-table-lookup (cdr code-table) types)))))) | |
51 | ||
52 | (define (compute-entry-with-cmethod methods types) | |
53 | (or (code-table-lookup (slot-ref (car methods) 'code-table) types) | |
54 | (let* ((method (car methods)) | |
55 | (place-holder (list #f)) | |
56 | (entry (append types place-holder))) | |
57 | ;; In order to handle recursion nicely, put the entry | |
58 | ;; into the code-table before compiling the method | |
59 | (slot-set! (car methods) 'code-table | |
60 | (cons entry (slot-ref (car methods) 'code-table))) | |
61 | (let ((cmethod (compile-method methods types))) | |
62 | (set-car! place-holder (car cmethod)) | |
63 | (set-cdr! place-holder (cdr cmethod))) | |
64 | (cons entry place-holder)))) | |
65 | ||
66 | (define (compute-cmethod methods types) | |
67 | (cdr (compute-entry-with-cmethod methods types))) | |
68 | ||
69 | ;;; | |
70 | ;;; Next methods | |
71 | ;;; | |
72 | ||
73 | ;;; Temporary solution---return #f if x doesn't refer to `next-method'. | |
74 | (define (next-method? x) | |
75 | (and (pair? x) | |
76 | (or (eq? (car x) 'next-method) | |
77 | (next-method? (car x)) | |
78 | (next-method? (cdr x))))) | |
79 | ||
80 | (define (make-final-make-next-method method) | |
81 | (lambda default-args | |
82 | (lambda args | |
83 | (@apply method (if (null? args) default-args args))))) | |
84 | ||
85 | (define (make-final-make-no-next-method gf) | |
86 | (lambda default-args | |
87 | (lambda args | |
88 | (no-next-method gf (if (null? args) default-args args))))) | |
89 | ||
90 | (define (make-make-next-method vcell gf methods types) | |
91 | (lambda default-args | |
92 | (lambda args | |
93 | (if (null? methods) | |
94 | (begin | |
95 | (set-cdr! vcell (make-final-make-no-next-method gf)) | |
96 | (no-next-method gf (if (null? args) default-args args))) | |
97 | (let* ((cmethod (compute-cmethod methods types)) | |
98 | (method (local-eval (cons 'lambda (cmethod-code cmethod)) | |
99 | (cmethod-environment cmethod)))) | |
100 | (set-cdr! vcell (make-final-make-next-method method)) | |
101 | (@apply method (if (null? args) default-args args))))))) | |
102 | ||
103 | ;;; | |
104 | ;;; Method compilation | |
105 | ;;; | |
106 | ||
107 | ;;; NOTE: This section is far from finished. It will finally be | |
108 | ;;; implemented on C level. | |
109 | ||
b432fb4b MD |
110 | (define %tag-body |
111 | (nested-ref the-root-module '(app modules oop goops %tag-body))) | |
112 | ||
14f1d9fe MD |
113 | (define (compile-method methods types) |
114 | (let* ((proc (method-procedure (car methods))) | |
296ff5e7 MV |
115 | ;; XXX - procedure-source can not be guaranteed to be |
116 | ;; reliable or efficient | |
117 | (src (procedure-source proc)) | |
14f1d9fe MD |
118 | (formals (source-formals src)) |
119 | (body (source-body src))) | |
120 | (if (next-method? body) | |
121 | (let ((vcell (cons 'goops:make-next-method #f))) | |
122 | (set-cdr! vcell | |
123 | (make-make-next-method | |
124 | vcell | |
125 | (method-generic-function (car methods)) | |
126 | (cdr methods) types)) | |
127 | ;;*fixme* | |
128 | `(,(cons vcell (procedure-environment proc)) | |
129 | ,formals | |
130 | ;;*fixme* Only do this on source where next-method can't be inlined | |
131 | (let ((next-method ,(if (list? formals) | |
132 | `(goops:make-next-method ,@formals) | |
133 | `(apply goops:make-next-method | |
134 | ,@(improper->proper formals))))) | |
135 | ,@body))) | |
136 | (cons (procedure-environment proc) | |
137 | (cons formals | |
b432fb4b | 138 | (%tag-body body))) |
14f1d9fe | 139 | ))) |