HCoop / bpt / guile.git / blame
| 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))))) |