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 2.1 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                           (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)
  44             ((check-entry (car code-table) types))
  45             (else (code-table-lookup (cdr code-table) types))))))
  46
  47 (define (compute-cmethod methods types)
  48   (or (code-table-lookup (slot-ref (car methods) 'code-table) types)
  49       (let* ((method (car methods))
  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)))
  54         cmethod)))
  55
  56 ;;;
  57 ;;; Compiling next methods into method bodies
  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
  63 ;;; combination that we see at runtime.
  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
  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)))))