home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / 1.6.0 / oop / goops / compile.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  5.7 KB  |  165 lines
  1. ;;;;     Copyright (C) 1999, 2001 Free Software Foundation, Inc.
  2. ;;;; 
  3. ;;;; This program is free software; you can redistribute it and/or modify
  4. ;;;; it under the terms of the GNU General Public License as published by
  5. ;;;; the Free Software Foundation; either version 2, or (at your option)
  6. ;;;; any later version.
  7. ;;;; 
  8. ;;;; This program 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
  11. ;;;; GNU General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU General Public License
  14. ;;;; along with this software; see the file COPYING.  If not, write to
  15. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16. ;;;; Boston, MA 02111-1307 USA
  17. ;;;;
  18. ;;;; As a special exception, the Free Software Foundation gives permission
  19. ;;;; for additional uses of the text contained in its release of GUILE.
  20. ;;;;
  21. ;;;; The exception is that, if you link the GUILE library with other files
  22. ;;;; to produce an executable, this does not by itself cause the
  23. ;;;; resulting executable to be covered by the GNU General Public License.
  24. ;;;; Your use of that executable is in no way restricted on account of
  25. ;;;; linking the GUILE library code into it.
  26. ;;;;
  27. ;;;; This exception does not however invalidate any other reasons why
  28. ;;;; the executable file might be covered by the GNU General Public License.
  29. ;;;;
  30. ;;;; This exception applies only to the code released by the
  31. ;;;; Free Software Foundation under the name GUILE.  If you copy
  32. ;;;; code from other Free Software Foundation releases into a copy of
  33. ;;;; GUILE, as the General Public License permits, the exception does
  34. ;;;; not apply to the code that you add in this way.  To avoid misleading
  35. ;;;; anyone as to the status of such modified files, you must delete
  36. ;;;; this exception notice from them.
  37. ;;;;
  38. ;;;; If you write modifications of your own for GUILE, it is your choice
  39. ;;;; whether to permit this exception to apply to your modifications.
  40. ;;;; If you do not wish that, delete this exception notice.
  41. ;;;; 
  42.  
  43.  
  44. (define-module (oop goops compile)
  45.   :use-module (oop goops)
  46.   :use-module (oop goops util)
  47.   :export (compute-cmethod compute-entry-with-cmethod
  48.        compile-method cmethod-code cmethod-environment)
  49.   :no-backtrace
  50.   )
  51.  
  52. (define source-formals cadr)
  53. (define source-body cddr)
  54.  
  55. (define cmethod-code cdr)
  56. (define cmethod-environment car)
  57.  
  58.  
  59. ;;;
  60. ;;; Method entries
  61. ;;;
  62.  
  63. (define code-table-lookup
  64.   (letrec ((check-entry (lambda (entry types)
  65.               (if (null? types)
  66.                   (and (not (struct? (car entry)))
  67.                    entry)
  68.                   (and (eq? (car entry) (car types))
  69.                    (check-entry (cdr entry) (cdr types)))))))
  70.     (lambda (code-table types)
  71.       (cond ((null? code-table) #f)
  72.         ((check-entry (car code-table) types)
  73.          => (lambda (cmethod)
  74.           (cons (car code-table) cmethod)))
  75.         (else (code-table-lookup (cdr code-table) types))))))
  76.  
  77. (define (compute-entry-with-cmethod methods types)
  78.   (or (code-table-lookup (slot-ref (car methods) 'code-table) types)
  79.       (let* ((method (car methods))
  80.          (place-holder (list #f))
  81.          (entry (append types place-holder)))
  82.     ;; In order to handle recursion nicely, put the entry
  83.     ;; into the code-table before compiling the method 
  84.     (slot-set! (car methods) 'code-table
  85.            (cons entry (slot-ref (car methods) 'code-table)))
  86.     (let ((cmethod (compile-method methods types)))
  87.       (set-car! place-holder (car cmethod))
  88.       (set-cdr! place-holder (cdr cmethod)))
  89.     (cons entry place-holder))))
  90.  
  91. (define (compute-cmethod methods types)
  92.   (cdr (compute-entry-with-cmethod methods types)))
  93.  
  94. ;;;
  95. ;;; Next methods
  96. ;;;
  97.  
  98. ;;; Temporary solution---return #f if x doesn't refer to `next-method'.
  99. (define (next-method? x)
  100.   (and (pair? x)
  101.        (or (eq? (car x) 'next-method)
  102.        (next-method? (car x))
  103.        (next-method? (cdr x)))))
  104.  
  105. (define (make-final-make-next-method method)
  106.   (lambda default-args
  107.     (lambda args
  108.       (@apply method (if (null? args) default-args args)))))      
  109.  
  110. (define (make-final-make-no-next-method gf)
  111.   (lambda default-args
  112.     (lambda args
  113.       (no-next-method gf (if (null? args) default-args args)))))
  114.  
  115. (define (make-make-next-method vcell gf methods types)
  116.   (lambda default-args
  117.     (lambda args
  118.       (if (null? methods)
  119.       (begin
  120.         (set-cdr! vcell (make-final-make-no-next-method gf))
  121.         (no-next-method gf (if (null? args) default-args args)))
  122.       (let* ((cmethod (compute-cmethod methods types))
  123.          (method (local-eval (cons 'lambda (cmethod-code cmethod))
  124.                      (cmethod-environment cmethod))))
  125.         (set-cdr! vcell (make-final-make-next-method method))
  126.         (@apply method (if (null? args) default-args args)))))))
  127.  
  128. ;;;
  129. ;;; Method compilation
  130. ;;;
  131.  
  132. ;;; NOTE: This section is far from finished.  It will finally be
  133. ;;; implemented on C level.
  134.  
  135. (define %tag-body
  136.   (nested-ref the-root-module '(app modules oop goops %tag-body)))
  137.  
  138. (define (compile-method methods types)
  139.   (let* ((proc (method-procedure (car methods)))
  140.      ;; XXX - procedure-source can not be guaranteed to be
  141.      ;;       reliable or efficient
  142.      (src (procedure-source proc)) 
  143.      (formals (source-formals src))
  144.      (body (source-body src)))
  145.     (if (next-method? body)
  146.     (let ((vcell (cons 'goops:make-next-method #f)))
  147.       (set-cdr! vcell
  148.             (make-make-next-method
  149.              vcell
  150.              (method-generic-function (car methods))
  151.              (cdr methods) types))
  152.       ;;*fixme*
  153.       `(,(cons vcell (procedure-environment proc))
  154.         ,formals
  155.         ;;*fixme* Only do this on source where next-method can't be inlined
  156.         (let ((next-method ,(if (list? formals)
  157.                     `(goops:make-next-method ,@formals)
  158.                     `(apply goops:make-next-method
  159.                         ,@(improper->proper formals)))))
  160.           ,@body)))
  161.     (cons (procedure-environment proc)
  162.           (cons formals
  163.             (%tag-body body)))
  164.     )))
  165.