module/oop/goops/compile.scm

   1 ;;;;    Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
   2 ;;;;
   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 3 of the License, or (at your option) any later version.
   7 ;;;;
   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.
  12 ;;;;
  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
  16 ;;;;
  17 \f
  18
  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-when (compile) (resolve-module '(oop goops)))
  23
  24 (define-module (oop goops compile)
  25   :use-module (oop goops)
  26   :use-module (oop goops util)
  27   :export (compute-cmethod)
  28   :no-backtrace
  29   )
  30
  31 ;;;
  32 ;;; Method entries
  33 ;;;
  34
  35 (define code-table-lookup
  36   (letrec ((check-entry (lambda (entry types)
  37                           (cond
  38                            ((not (pair? entry)) (and (null? types) entry))
  39                            ((null? types) #f)
  40                            (else
  41                             (and (eq? (car entry) (car types))
  42                                  (check-entry (cdr entry) (cdr types))))))))
  43     (lambda (code-table types)
  44       (cond ((null? code-table) #f)
  45             ((check-entry (car code-table) types))
  46             (else (code-table-lookup (cdr code-table) types))))))
  47
  48 (define (compute-cmethod methods types)
  49   (or (code-table-lookup (slot-ref (car methods) 'code-table) types)
  50       (let* ((method (car methods))
  51              (cmethod (compile-method methods types))
  52              (entry (append types cmethod)))
  53         (slot-set! method 'code-table
  54                    (cons entry (slot-ref method 'code-table)))
  55         cmethod)))
  56
  57 ;;;
  58 ;;; Compiling next methods into method bodies
  59 ;;;
  60
  61 ;;; So, for the reader: there basic idea is that, given that the
  62 ;;; semantics of `next-method' depend on the concrete types being
  63 ;;; dispatched, why not compile a specific procedure to handle each type
  64 ;;; combination that we see at runtime.
  65 ;;;
  66 ;;; In theory we can do much better than a bytecode compilation, because
  67 ;;; we know the *exact* types of the arguments. It's ideal for native
  68 ;;; compilation. A task for the future.
  69 ;;;
  70 ;;; I think this whole generic application mess would benefit from a
  71 ;;; strict MOP.
  72
  73 (define (compile-method methods types)
  74   (let ((make-procedure (slot-ref (car methods) 'make-procedure)))
  75     (if make-procedure
  76         (make-procedure
  77          (if (null? methods)
  78              (lambda args
  79                (no-next-method (method-generic-function (car methods)) args))
  80              (compute-cmethod (cdr methods) types)))
  81         (method-procedure (car methods)))))