goops.scm

MSYS在windows下模拟了一个类unix的终端

;;; installed-scm-file

;;;; 	Copyright (C) 1998, 1999, 2000, 2001 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
;;;;
;;;; As a special exception, the Free Software Foundation gives permission
;;;; for additional uses of the text contained in its release of GUILE.
;;;;
;;;; The exception is that, if you link the GUILE library with other files
;;;; to produce an executable, this does not by itself cause the
;;;; resulting executable to be covered by the GNU General Public License.
;;;; Your use of that executable is in no way restricted on account of
;;;; linking the GUILE library code into it.
;;;;
;;;; This exception does not however invalidate any other reasons why
;;;; the executable file might be covered by the GNU General Public License.
;;;;
;;;; This exception applies only to the code released by the
;;;; Free Software Foundation under the name GUILE.  If you copy
;;;; code from other Free Software Foundation releases into a copy of
;;;; GUILE, as the General Public License permits, the exception does
;;;; not apply to the code that you add in this way.  To avoid misleading
;;;; anyone as to the status of such modified files, you must delete
;;;; this exception notice from them.
;;;;
;;;; If you write modifications of your own for GUILE, it is your choice
;;;; whether to permit this exception to apply to your modifications.
;;;; If you do not wish that, delete this exception notice.
;;;; 


;;;; This software is a derivative work of other copyrighted softwares; the
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;;
;;;; This file is based upon stklos.stk from the STk distribution by
;;;; Erick Gallesio <[e-mail]>.
;;;;

(define-module (oop goops)
  :export-syntax (define-class class
		  define-generic define-accessor define-method
		  method)
  :export (goops-version is-a?
           ensure-metaclass ensure-metaclass-with-supers
	   make-class
	   make-generic ensure-generic
	   make-accessor ensure-accessor
	   make-method add-method!
	   object-eqv? object-equal?
	   class-slot-ref class-slot-set! slot-unbound slot-missing 
	   slot-definition-name  slot-definition-options
	   slot-definition-allocation
	   slot-definition-getter slot-definition-setter
	   slot-definition-accessor
	   slot-definition-init-value slot-definition-init-form
	   slot-definition-init-thunk slot-definition-init-keyword 
	   slot-init-function class-slot-definition
	   method-source
	   compute-cpl compute-std-cpl compute-get-n-set compute-slots
	   compute-getter-method compute-setter-method
	   allocate-instance initialize make-instance make
	   no-next-method  no-applicable-method no-method
	   change-class update-instance-for-different-class
	   shallow-clone deep-clone
	   class-redefinition
	   apply-generic apply-method apply-methods
	   compute-applicable-methods %compute-applicable-methods
	   method-more-specific? sort-applicable-methods
	   class-subclasses class-methods
	   goops-error
	   min-fixnum max-fixnum
	   ;;; *fixme* Should go into goops.c
	   instance?  slot-ref-using-class
	   slot-set-using-class! slot-bound-using-class?
	   slot-exists-using-class? slot-ref slot-set! slot-bound?
	   class-name class-direct-supers class-direct-subclasses
	   class-direct-methods class-direct-slots class-precedence-list
	   class-slots class-environment
	   generic-function-name
	   generic-function-methods method-generic-function method-specializers
	   primitive-generic-generic enable-primitive-generic!
	   method-procedure accessor-method-slot-definition
	   slot-exists? make find-method get-keyword)
  :re-export (class-of)  ;; from (guile)
  :no-backtrace)

;; First initialize the builtin part of GOOPS
(%init-goops-builtins)

;; Then load the rest of GOOPS
(use-modules (oop goops util)
	     (oop goops dispatch)
	     (oop goops compile))


(define min-fixnum (- (expt 2 29)))

(define max-fixnum (- (expt 2 29) 1))

;;
;; goops-error
;;
(define (goops-error format-string . args)
  (save-stack)
  (scm-error 'goops-error #f format-string args '()))

;;
;; is-a?
;;
(define (is-a? obj class)
  (and (memq class (class-precedence-list (class-of obj))) #t))


;;;
;;; {Meta classes}
;;;

(define ensure-metaclass-with-supers
  (let ((table-of-metas '()))
    (lambda (meta-supers)
      (let ((entry (assoc meta-supers table-of-metas)))
	(if entry
	    ;; Found a previously created metaclass
	    (cdr entry)
	    ;; Create a new meta-class which inherit from "meta-supers"
	    (let ((new (make <class> #:dsupers meta-supers
			             #:slots   '()
				     #:name   (gensym "metaclass"))))
	      (set! table-of-metas (cons (cons meta-supers new) table-of-metas))
	      new))))))

(define (ensure-metaclass supers env)
  (if (null? supers)
      <class>
      (let* ((all-metas (map (lambda (x) (class-of x)) supers))
	     (all-cpls  (apply append
			       (map (lambda (m)
				      (cdr (class-precedence-list m))) 
				    all-metas)))
	     (needed-metas '()))
	;; Find the most specific metaclasses.  The new metaclass will be
	;; a subclass of these.
	(for-each
	 (lambda (meta)
	   (if (and (not (member meta all-cpls))
		      (not (member meta needed-metas)))
	     (set! needed-metas (append needed-metas (list meta)))))
	 all-metas)
	;; Now return a subclass of the metaclasses we found.
	(if (null? (cdr needed-metas))
	    (car needed-metas)  ; If there's only one, just use it.
	    (ensure-metaclass-with-supers needed-metas)))))

;;;
;;; {Classes}
;;;

;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...)
;;;
;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
;;;   OPTION ::= KEYWORD VALUE
;;;
(define (define-class-pre-definition keyword exp env)
  (case keyword
    ((#:getter #:setter)
     (if (defined? exp env)
	 `(define ,exp (ensure-generic ,exp ',exp))
	 `(define ,exp (make-generic ',exp))))
    ((#:accessor)
     (if (defined? exp env)
	 `(define ,exp (ensure-accessor ,exp ',exp))
	 `(define ,exp (make-accessor ',exp))))
    (else #f)))

;;; This code should be implemented in C.
;;;
(define define-class
  (letrec (;; Some slot options require extra definitions to be made.
	   ;; In particular, we want to make sure that the generic
	   ;; function objects which represent accessors exist
	   ;; before `make-class' tries to add methods to them.
	   ;;
	   ;; Postpone error handling to class macro.
	   ;;
	   (pre-definitions
	    (lambda (slots env)
	      (do ((slots slots (cdr slots))
		   (definitions '()
		     (if (pair? (car slots))
			 (do ((options (cdar slots) (cddr options))
			      (definitions definitions
				(cond ((not (symbol? (cadr options)))
				       definitions)
				      ((define-class-pre-definition
					 (car options)
					 (cadr options)
					 env)
				       => (lambda (definition)
					    (cons definition definitions)))
				      (else definitions))))
			     ((not (and (pair? options)
					(pair? (cdr options))))
			      definitions))
			 definitions)))
		  ((or (not (pair? slots))
		       (keyword? (car slots)))
		   (reverse definitions)))))
	   
	   ;; Syntax
	   (name cadr)
	   (slots cdddr))
    
    (procedure->macro
      (lambda (exp env)
	(cond ((not (top-level-env? env))
	       (goops-error "define-class: Only allowed at top level"))
	      ((not (and (list? exp) (>= (length exp) 3)))
	       (goops-error "missing or extra expression"))
	      (else
	       (let ((name (name exp)))
		 `(begin
		    ;; define accessors
		    ,@(pre-definitions (slots exp) env)
		 
		    ,(if (defined? name env)
		      
			 ;; redefine an old class
			 `(define ,name
			    (let ((old ,name)
				  (new (class ,@(cddr exp) #:name ',name)))
			      (if (and (is-a? old <class>)
				       ;; Prevent redefinition of non-objects
				       (memq <object>
					     (class-precedence-list old)))
				  (class-redefinition old new)
				  new)))
		      
			 ;; define a new class
			 `(define ,name
			    (class ,@(cddr exp) #:name ',name)))))))))))

(define standard-define-class define-class)

;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
;;;
;;;   SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
;;;   OPTION ::= KEYWORD VALUE
;;;
(define class
  (letrec ((slot-option-keyword car)
	   (slot-option-value cadr)
	   (process-slot-options
	    (lambda (options)
	      (let loop ((options options)
			 (res '()))
		(cond ((null? options)
		       (reverse res))
		      ((null? (cdr options))
		       (goops-error "malformed slot option list"))
		      ((not (keyword? (slot-option-keyword options)))
		       (goops-error "malformed slot option list"))
		      (else
		       (case (slot-option-keyword options)
			 ((#:init-form)
			  (loop (cddr options)
				(append (list `(lambda ()
						 ,(slot-option-value options))
					      #:init-thunk
					      (list 'quote
						    (slot-option-value options))
					      #:init-form)
					res)))
			 (else
			  (loop (cddr options)
				(cons (cadr options)
				      (cons (car options)
					    res)))))))))))
    
    (procedure->memoizing-macro
      (let ((supers cadr)
	    (slots cddr)
	    (options cdddr))
	(lambda (exp env)
	  (cond ((not (and (list? exp) (>= (length exp) 2)))
		 (goops-error "missing or extra expression"))
		((not (list? (supers exp)))
		 (goops-error "malformed superclass list: ~S" (supers exp)))
		(else
		 (let ((slot-defs (cons #f '())))
		   (do ((slots (slots exp) (cdr slots))
			(defs slot-defs (cdr defs)))
		       ((or (null? slots)
			    (keyword? (car slots)))
			`(make-class
			  ;; evaluate super class variables
			  (list ,@(supers exp))
			  ;; evaluate slot definitions, except the slot name!
			  (list ,@(cdr slot-defs))
			  ;; evaluate class options
			  ,@slots
			  ;; place option last in case someone wants to
			  ;; pass a different value
			  #:environment ',env))
		     (set-cdr!
		      defs
		      (list (if (pair? (car slots))
				`(list ',(slot-definition-name (car slots))
				       ,@(process-slot-options
					  (slot-definition-options
					   (car slots))))
				`(list ',(car slots))))))))))))))

(define (make-class supers slots . options)
  (let ((env (or (get-keyword #:environment options #f)
		 (top-level-env))))
    (let* ((name (get-keyword #:name options (make-unbound)))
	   (supers (if (not (or-map (lambda (class)
				      (memq <object>
					    (class-precedence-list class)))
				    supers))
		       (append supers (list <object>))
		       supers))
	   (metaclass (or (get-keyword #:metaclass options #f)
			  (ensure-metaclass supers env))))

      ;; Verify that all direct slots are different and that we don't inherit
      ;; several time from the same class
      (let ((tmp1 (find-duplicate supers))
	    (tmp2 (find-duplicate (map slot-definition-name slots))))
	(if tmp1
	    (goops-error "make-class: super class ~S is duplicate in class ~S"
			 tmp1 name))
	(if tmp2
	    (goops-error "make-class: slot ~S is duplicate in class ~S"
			 tmp2 name)))

      ;; Everything seems correct, build the class
      (apply make metaclass
	     #:dsupers supers
	     #:slots slots 
	     #:name name
	     #:environment env
	     options))))

;;;
;;; {Generic functions and accessors}
;;;

(define define-generic
  (procedure->macro
    (lambda (exp env)
      (let ((name (cadr exp)))
	(cond ((not (symbol? name))
	       (goops-error "bad generic function name: ~S" name))
	      ((defined? name env)
	       `(define ,name
		  (if (is-a? ,name <generic>)
		      (make <generic> #:name ',name)
		      (ensure-generic ,name ',name))))
	      (else
	       `(define ,name (make <generic> #:name ',name))))))))

(define (make-generic . name)
  (let ((name (and (pair? name) (car name))))
    (make <generic> #:name name)))

(define (ensure-generic old-definition . name)
  (let ((name (and (pair? name) (car name))))
    (cond ((is-a? old-definition <generic>) old-definition)