diff options
author | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2000-10-25 14:51:33 +0000 |
---|---|---|
committer | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2000-10-25 14:51:33 +0000 |
commit | 14f1d9fec8091a5d29c3f2ac57b31c28825476cb (patch) | |
tree | 0c1e0e26600d9f19050c911bce4922a68cf896cd /oop/goops/compile.scm | |
parent | 5e8904311f10522a2288b9d2d340964fe21028a7 (diff) | |
download | guile-14f1d9fec8091a5d29c3f2ac57b31c28825476cb.tar.gz |
*** empty log message ***
Diffstat (limited to 'oop/goops/compile.scm')
-rw-r--r-- | oop/goops/compile.scm | 136 |
1 files changed, 136 insertions, 0 deletions
diff --git a/oop/goops/compile.scm b/oop/goops/compile.scm new file mode 100644 index 000000000..ab185f3c5 --- /dev/null +++ b/oop/goops/compile.scm @@ -0,0 +1,136 @@ +;;;; Copyright (C) 1999 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + + +(define-module (oop goops compile) + :use-module (oop goops) + :use-module (oop goops util) + :no-backtrace + ) + +(export compute-cmethod compute-entry-with-cmethod + compile-method cmethod-code cmethod-environment) + +(define source-formals cadr) +(define source-body cddr) + +(define cmethod-code cdr) +(define cmethod-environment car) + + +;;; +;;; Method entries +;;; + +(define code-table-lookup + (letrec ((check-entry (lambda (entry types) + (if (null? types) + (and (not (struct? (car entry))) + entry) + (and (eq? (car entry) (car types)) + (check-entry (cdr entry) (cdr types))))))) + (lambda (code-table types) + (cond ((null? code-table) #f) + ((check-entry (car code-table) types) + => (lambda (cmethod) + (cons (car code-table) cmethod))) + (else (code-table-lookup (cdr code-table) types)))))) + +(define (compute-entry-with-cmethod methods types) + (or (code-table-lookup (slot-ref (car methods) 'code-table) types) + (let* ((method (car methods)) + (place-holder (list #f)) + (entry (append types place-holder))) + ;; In order to handle recursion nicely, put the entry + ;; into the code-table before compiling the method + (slot-set! (car methods) 'code-table + (cons entry (slot-ref (car methods) 'code-table))) + (let ((cmethod (compile-method methods types))) + (set-car! place-holder (car cmethod)) + (set-cdr! place-holder (cdr cmethod))) + (cons entry place-holder)))) + +(define (compute-cmethod methods types) + (cdr (compute-entry-with-cmethod methods types))) + +;;; +;;; Next methods +;;; + +;;; Temporary solution---return #f if x doesn't refer to `next-method'. +(define (next-method? x) + (and (pair? x) + (or (eq? (car x) 'next-method) + (next-method? (car x)) + (next-method? (cdr x))))) + +(define (make-final-make-next-method method) + (lambda default-args + (lambda args + (@apply method (if (null? args) default-args args))))) + +(define (make-final-make-no-next-method gf) + (lambda default-args + (lambda args + (no-next-method gf (if (null? args) default-args args))))) + +(define (make-make-next-method vcell gf methods types) + (lambda default-args + (lambda args + (if (null? methods) + (begin + (set-cdr! vcell (make-final-make-no-next-method gf)) + (no-next-method gf (if (null? args) default-args args))) + (let* ((cmethod (compute-cmethod methods types)) + (method (local-eval (cons 'lambda (cmethod-code cmethod)) + (cmethod-environment cmethod)))) + (set-cdr! vcell (make-final-make-next-method method)) + (@apply method (if (null? args) default-args args))))))) + +;;; +;;; Method compilation +;;; + +;;; NOTE: This section is far from finished. It will finally be +;;; implemented on C level. + +(define (compile-method methods types) + (let* ((proc (method-procedure (car methods))) + (src (procedure-source proc)) + (formals (source-formals src)) + (body (source-body src))) + (if (next-method? body) + (let ((vcell (cons 'goops:make-next-method #f))) + (set-cdr! vcell + (make-make-next-method + vcell + (method-generic-function (car methods)) + (cdr methods) types)) + ;;*fixme* + `(,(cons vcell (procedure-environment proc)) + ,formals + ;;*fixme* Only do this on source where next-method can't be inlined + (let ((next-method ,(if (list? formals) + `(goops:make-next-method ,@formals) + `(apply goops:make-next-method + ,@(improper->proper formals))))) + ,@body))) + (cons (procedure-environment proc) + (cons formals + body)) + ))) |