1 ;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
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.
8 ;;;; This library 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 GNU
11 ;;;; Lesser General Public License for more details.
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 (define-module (oop goops compile)
20 :use-module (oop goops)
21 :use-module (oop goops util)
22 :export (compute-cmethod compute-entry-with-cmethod
23 compile-method cmethod-code cmethod-environment)
27 (define source-formals cadr)
28 (define source-body cddr)
30 (define cmethod-code cdr)
31 (define cmethod-environment car)
38 (define code-table-lookup
39 (letrec ((check-entry (lambda (entry types)
41 (and (not (struct? (car 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)
49 (cons (car code-table) cmethod)))
50 (else (code-table-lookup (cdr code-table) types))))))
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))))
66 (define (compute-cmethod methods types)
67 (cdr (compute-entry-with-cmethod methods types)))
73 ;;; Temporary solution---return #f if x doesn't refer to `next-method'.
74 (define (next-method? x)
76 (or (eq? (car x) 'next-method)
77 (next-method? (car x))
78 (next-method? (cdr x)))))
80 (define (make-final-make-next-method method)
83 (@apply method (if (null? args) default-args args)))))
85 (define (make-final-make-no-next-method gf)
88 (no-next-method gf (if (null? args) default-args args)))))
90 (define (make-make-next-method vcell gf methods types)
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)))))))
104 ;;; Method compilation
107 ;;; NOTE: This section is far from finished. It will finally be
108 ;;; implemented on C level.
111 (nested-ref the-root-module '(app modules oop goops %tag-body)))
113 (define (compile-method methods types)
114 (let* ((proc (method-procedure (car methods)))
115 ;; XXX - procedure-source can not be guaranteed to be
116 ;; reliable or efficient
117 (src (procedure-source proc))
118 (formals (source-formals src))
119 (body (source-body src)))
120 (if (next-method? body)
121 (let ((vcell (cons 'goops:make-next-method #f)))
123 (make-make-next-method
125 (method-generic-function (car methods))
126 (cdr methods) types))
128 `(,(cons vcell (procedure-environment proc))
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)))))
136 (cons (procedure-environment proc)