guile18/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 (define-module (oop goops compile)
  20   :use-module (oop goops)
  21   :use-module (oop goops util)
  22   :export (compute-cmethod compute-entry-with-cmethod
  23            compile-method cmethod-code cmethod-environment)
  24   :no-backtrace
  25   )
  26
  27 (define source-formals cadr)
  28 (define source-body cddr)
  29
  30 (define cmethod-code cdr)
  31 (define cmethod-environment car)
  32
  33
  34 ;;;
  35 ;;; Method entries
  36 ;;;
  37
  38 (define code-table-lookup
  39   (letrec ((check-entry (lambda (entry types)
  40                           (if (null? types)
  41                               (and (not (struct? (car entry)))
  42                                    entry)
  43                               (and (eq? (car entry) (car types))
  44                                    (check-entry (cdr entry) (cdr types)))))))
  45     (lambda (code-table types)
  46       (cond ((null? code-table) #f)
  47             ((check-entry (car code-table) types)
  48              => (lambda (cmethod)
  49                   (cons (car code-table) cmethod)))
  50             (else (code-table-lookup (cdr code-table) types))))))
  51
  52 (define (compute-entry-with-cmethod methods types)
  53   (or (code-table-lookup (slot-ref (car methods) 'code-table) types)
  54       (let* ((method (car methods))
  55              (place-holder (list #f))
  56              (entry (append types place-holder)))
  57         ;; In order to handle recursion nicely, put the entry
  58         ;; into the code-table before compiling the method
  59         (slot-set! (car methods) 'code-table
  60                    (cons entry (slot-ref (car methods) 'code-table)))
  61         (let ((cmethod (compile-method methods types)))
  62           (set-car! place-holder (car cmethod))
  63           (set-cdr! place-holder (cdr cmethod)))
  64         (cons entry place-holder))))
  65
  66 (define (compute-cmethod methods types)
  67   (cdr (compute-entry-with-cmethod methods types)))
  68
  69 ;;;
  70 ;;; Next methods
  71 ;;;
  72
  73 ;;; Temporary solution---return #f if x doesn't refer to `next-method'.
  74 (define (next-method? x)
  75   (and (pair? x)
  76        (or (eq? (car x) 'next-method)
  77            (next-method? (car x))
  78            (next-method? (cdr x)))))
  79
  80 (define (make-final-make-next-method method)
  81   (lambda default-args
  82     (lambda args
  83       (@apply method (if (null? args) default-args args)))))
  84
  85 (define (make-final-make-no-next-method gf)
  86   (lambda default-args
  87     (lambda args
  88       (no-next-method gf (if (null? args) default-args args)))))
  89
  90 (define (make-make-next-method vcell gf methods types)
  91   (lambda default-args
  92     (lambda args
  93       (if (null? methods)
  94           (begin
  95             (set-cdr! vcell (make-final-make-no-next-method gf))
  96             (no-next-method gf (if (null? args) default-args args)))
  97           (let* ((cmethod (compute-cmethod methods types))
  98                  (method (local-eval (cons 'lambda (cmethod-code cmethod))
  99                                      (cmethod-environment cmethod))))
 100             (set-cdr! vcell (make-final-make-next-method method))
 101             (@apply method (if (null? args) default-args args)))))))
 102
 103 ;;;
 104 ;;; Method compilation
 105 ;;;
 106
 107 ;;; NOTE: This section is far from finished.  It will finally be
 108 ;;; implemented on C level.
 109
 110 (define %tag-body
 111   (nested-ref the-root-module '(app modules oop goops %tag-body)))
 112
 113 (define (compile-method methods types)
 114   (let* ((proc (method-procedure (car methods)))
 115          ;; XXX - procedure-source can not be guaranteed to be
 116          ;;       reliable or efficient
 117          (src (procedure-source proc))
 118          (formals (source-formals src))
 119          (body (source-body src)))
 120     (if (next-method? body)
 121         (let ((vcell (cons 'goops:make-next-method #f)))
 122           (set-cdr! vcell
 123                     (make-make-next-method
 124                      vcell
 125                      (method-generic-function (car methods))
 126                      (cdr methods) types))
 127           ;;*fixme*
 128           `(,(cons vcell (procedure-environment proc))
 129             ,formals
 130             ;;*fixme* Only do this on source where next-method can't be inlined
 131             (let ((next-method ,(if (list? formals)
 132                                     `(goops:make-next-method ,@formals)
 133                                     `(apply goops:make-next-method
 134                                             ,@(improper->proper formals)))))
 135               ,@body)))
 136         (cons (procedure-environment proc)
 137               (cons formals
 138                     (%tag-body body)))
 139         )))