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 compile-make-procedure)
  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. There are two compilation
  64 ;;; strategies implemented: one for the memoizer, and one for the VM
  65 ;;; compiler.
  66 ;;;
  67 ;;; In theory we can do much better than a bytecode compilation, because
  68 ;;; we know the *exact* types of the arguments. It's ideal for native
  69 ;;; compilation. A task for the future.
  70 ;;;
  71 ;;; I think this whole generic application mess would benefit from a
  72 ;;; strict MOP.
  73
  74 ;;; Temporary solution---return #f if x doesn't refer to `next-method'.
  75 (define (next-method? x)
  76   (and (pair? x)
  77        (or (eq? (car x) 'next-method)
  78            (next-method? (car x))
  79            (next-method? (cdr x)))))
  80
  81 ;; Called by the `method' macro in goops.scm.
  82 (define (compile-make-procedure formals specializers body)
  83   (and (next-method? body)
  84        (let ((next-method-sym (gensym " next-method"))
  85              (args-sym (gensym)))
  86          `(lambda (,next-method-sym)
  87             (lambda ,formals
  88               (let ((next-method (lambda ,args-sym
  89                                    (if (null? ,args-sym)
  90                                        ,(if (list? formals)
  91                                             `(,next-method-sym ,@formals)
  92                                             `(apply
  93                                               ,next-method-sym
  94                                               ,@(improper->proper formals)))
  95                                        (apply ,next-method-sym ,args-sym)))))
  96                 ,@(if (null? body)
  97                       '((begin))
  98                       body)))))))
  99
 100 (define (compile-method methods types)
 101   (let ((make-procedure (slot-ref (car methods) 'make-procedure)))
 102     (if make-procedure
 103         (make-procedure
 104          (if (null? methods)
 105              (lambda args
 106                (no-next-method (method-generic-function (car methods)) args))
 107              (compute-cmethod (cdr methods) types)))
 108         (method-procedure (car methods)))))