module/oop/goops/compile.scm

   1 ;;;;    Copyright (C) 1999, 2001, 2006, 2009 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 ;;; Compiling next methods into method bodies
  33 ;;;
  34
  35 ;;; So, for the reader: there basic idea is that, given that the
  36 ;;; semantics of `next-method' depend on the concrete types being
  37 ;;; dispatched, why not compile a specific procedure to handle each type
  38 ;;; combination that we see at runtime.
  39 ;;;
  40 ;;; In theory we can do much better than a bytecode compilation, because
  41 ;;; we know the *exact* types of the arguments. It's ideal for native
  42 ;;; compilation. A task for the future.
  43 ;;;
  44 ;;; I think this whole generic application mess would benefit from a
  45 ;;; strict MOP.
  46
  47 (define (compute-cmethod methods types)
  48   (let ((make-procedure (slot-ref (car methods) 'make-procedure)))
  49     (if make-procedure
  50         (make-procedure
  51          (if (null? (cdr methods))
  52              (lambda args
  53                (no-next-method (method-generic-function (car methods)) args))
  54              (compute-cmethod (cdr methods) types)))
  55         (method-procedure (car methods)))))