goops.scm

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

    (if (not (memq (slot-definition-allocation this-slot)
		   '(#:class #:each-subclass)))
	(slot-missing class slot-name))
    g-n-s))

(define (class-slot-ref class slot)
  (let ((x ((car (class-slot-g-n-s class slot)) #f)))
    (if (unbound? x)
	(slot-unbound class slot)
	x)))

(define (class-slot-set! class slot value)
  ((cadr (class-slot-g-n-s class slot)) #f value))

(define-method (slot-unbound (c <class>) (o <object>) s)
  (goops-error "Slot `~S' is unbound in object ~S" s o))

(define-method (slot-unbound (c <class>) s)
  (goops-error "Slot `~S' is unbound in class ~S" s c))

(define-method (slot-unbound (o <object>))
  (goops-error "Unbound slot in object ~S" o))

(define-method (slot-missing (c <class>) (o <object>) s)
  (goops-error "No slot with name `~S' in object ~S" s o))
  
(define-method (slot-missing (c <class>) s)
  (goops-error "No class slot with name `~S' in class ~S" s c))
  

(define-method (slot-missing (c <class>) (o <object>) s value)
  (slot-missing c o s))

;;; Methods for the possible error we can encounter when calling a gf

(define-method (no-next-method (gf <generic>) args)
  (goops-error "No next method when calling ~S\nwith arguments ~S" gf args))

(define-method (no-applicable-method (gf <generic>) args)
  (goops-error "No applicable method for ~S in call ~S"
	       gf (cons (generic-function-name gf) args)))

(define-method (no-method (gf <generic>) args)
  (goops-error "No method defined for ~S"  gf))

;;;
;;; {Cloning functions (from [e-mail])}
;;;

(define-method (shallow-clone (self <object>))
  (let ((clone (%allocate-instance (class-of self) '()))
	(slots (map slot-definition-name
		    (class-slots (class-of self)))))
    (for-each (lambda (slot)
		(if (slot-bound? self slot)
		    (slot-set! clone slot (slot-ref self slot))))
	      slots)
    clone))

(define-method (deep-clone  (self <object>))
  (let ((clone (%allocate-instance (class-of self) '()))
	(slots (map slot-definition-name
		    (class-slots (class-of self)))))
    (for-each (lambda (slot)
		(if (slot-bound? self slot)
		    (slot-set! clone slot
			       (let ((value (slot-ref self slot)))
				 (if (instance? value)
				     (deep-clone value)
				     value)))))
	      slots)
    clone))

;;;
;;; {Class redefinition utilities}
;;;

;;; (class-redefinition OLD NEW)
;;;

;;; Has correct the following conditions:

;;; Methods
;;; 
;;; 1. New accessor specializers refer to new header
;;; 
;;; Classes
;;; 
;;; 1. New class cpl refers to the new class header
;;; 2. Old class header exists on old super classes direct-subclass lists
;;; 3. New class header exists on new super classes direct-subclass lists

(define-method (class-redefinition (old <class>) (new <class>))
  ;; Work on direct methods:
  ;;		1. Remove accessor methods from the old class 
  ;;		2. Patch the occurences of new in the specializers by old
  ;;		3. Displace the methods from old to new
  (remove-class-accessors! old)					;; -1-
  (let ((methods (class-direct-methods new)))
    (for-each (lambda (m)
     	         (update-direct-method! m new old))	;; -2-
              methods)
    (slot-set! new
	       'direct-methods
	       (append methods (class-direct-methods old))))

  ;; Substitute old for new in new cpl
  (set-car! (slot-ref new 'cpl) old)
  
  ;; Remove the old class from the direct-subclasses list of its super classes
  (for-each (lambda (c) (slot-set! c 'direct-subclasses
				   (delv! old (class-direct-subclasses c))))
	    (class-direct-supers old))

  ;; Replace the new class with the old in the direct-subclasses of the supers
  (for-each (lambda (c)
	      (slot-set! c 'direct-subclasses
			 (cons old (delv! new (class-direct-subclasses c)))))
	    (class-direct-supers new))

  ;; Swap object headers
  (%modify-class old new)

  ;; Now old is NEW!

  ;; Redefine all the subclasses of old to take into account modification
  (for-each 
       (lambda (c)
	 (update-direct-subclass! c new old))
       (class-direct-subclasses new))

  ;; Invalidate class so that subsequent instances slot accesses invoke
  ;; change-object-class
  (slot-set! new 'redefined old)
  (%invalidate-class new) ;must come after slot-set!

  old)

;;;
;;; remove-class-accessors!
;;;

(define-method (remove-class-accessors! (c <class>))
  (for-each (lambda (m)
	      (if (is-a? m <accessor-method>)
		  (remove-method-in-classes! m)))
	    (class-direct-methods c)))

;;;
;;; update-direct-method!
;;;

(define-method (update-direct-method! (m  <method>)
				      (old <class>)
				      (new <class>))
  (let loop ((l (method-specializers m)))
    ;; Note: the <top> in dotted list is never used. 
    ;; So we can work as if we had only proper lists.
    (if (pair? l)       	  
	(begin
	  (if (eqv? (car l) old)  
	      (set-car! l new))
	  (loop (cdr l))))))

;;;
;;; update-direct-subclass!
;;;

(define-method (update-direct-subclass! (c <class>)
					(old <class>)
					(new <class>))
  (class-redefinition c
		      (make-class (class-direct-supers c)
				  (class-direct-slots c)
				  #:name (class-name c)
				  #:environment (slot-ref c 'environment)
				  #:metaclass (class-of c))))

;;;
;;; {Utilities for INITIALIZE methods}
;;;

;;; compute-slot-accessors
;;;
(define (compute-slot-accessors class slots env)
  (for-each
      (lambda (s g-n-s)
	(let ((name            (slot-definition-name     s))
	      (getter-function (slot-definition-getter   s))
	      (setter-function (slot-definition-setter   s))
	      (accessor        (slot-definition-accessor s)))
	  (if getter-function
	      (add-method! getter-function
			   (compute-getter-method class g-n-s)))
	  (if setter-function
	      (add-method! setter-function
			   (compute-setter-method class g-n-s)))
	  (if accessor
	      (begin
		(add-method! accessor
			     (compute-getter-method class g-n-s))
		(add-method! (setter accessor)
			     (compute-setter-method class g-n-s))))))
      slots (slot-ref class 'getters-n-setters)))

(define-method (compute-getter-method (class <class>) slotdef)
  (let ((init-thunk (cadr slotdef))
	(g-n-s (cddr slotdef)))
    (make <accessor-method>
          #:specializers (list class)
	  #:procedure (cond ((pair? g-n-s)
			     (if init-thunk
				 (car g-n-s)
				 (make-generic-bound-check-getter (car g-n-s))
				 ))
			    (init-thunk
			     (standard-get g-n-s))
			    (else
			     (bound-check-get g-n-s)))
	  #:slot-definition slotdef)))

(define-method (compute-setter-method (class <class>) slotdef)
  (let ((g-n-s (cddr slotdef)))
    (make <accessor-method>
          #:specializers (list class <top>)
	  #:procedure (if (pair? g-n-s)
			  (cadr g-n-s)
			  (standard-set g-n-s))
	  #:slot-definition slotdef)))

(define (make-generic-bound-check-getter proc)
  (let ((source (and (closure? proc) (procedure-source proc))))
    (if (and source (null? (cdddr source)))
	(let ((obj (caadr source)))
	  ;; smart closure compilation
	  (local-eval
	   `(lambda (,obj) (,assert-bound ,(caddr source) ,obj))
	   (procedure-environment proc)))
	(lambda (o) (assert-bound (proc o) o)))))

(define n-standard-accessor-methods 10)

(define bound-check-get-methods (make-vector n-standard-accessor-methods #f))
(define standard-get-methods (make-vector n-standard-accessor-methods #f))
(define standard-set-methods (make-vector n-standard-accessor-methods #f))

(define (standard-accessor-method make methods)
  (lambda (index)
    (cond ((>= index n-standard-accessor-methods) (make index))
	  ((vector-ref methods index))
	  (else (let ((m (make index)))
		  (vector-set! methods index m)
		  m)))))

(define (make-bound-check-get index)
  (local-eval `(lambda (o) (@assert-bound-ref o ,index)) (the-environment)))

(define (make-get index)
  (local-eval `(lambda (o) (@slot-ref o ,index)) (the-environment)))

(define (make-set index)
  (local-eval `(lambda (o v) (@slot-set! o ,index v)) (the-environment)))

(define bound-check-get
  (standard-accessor-method make-bound-check-get bound-check-get-methods))
(define standard-get (standard-accessor-method make-get standard-get-methods))
(define standard-set (standard-accessor-method make-set standard-set-methods))

;;; compute-getters-n-setters
;;; 
(define (compute-getters-n-setters class slots env)

  (define (compute-slot-init-function s)
    (or (slot-definition-init-thunk s)
	(let ((init (slot-definition-init-value s)))
	  (and (not (unbound? init))
	       (lambda () init)))))

  (define (verify-accessors slot l)
    (if (pair? l)
	(let ((get (car l)) 
	      (set (cadr l)))
	  (if (not (and (closure? get)
			(= (car (procedure-property get 'arity)) 1)))
	      (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
			   slot class get))
	  (if (not (and (closure? set)
			(= (car (procedure-property set 'arity)) 2)))
	    (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
			 slot class set)))))

  (map (lambda (s)
	 (let* ((g-n-s (compute-get-n-set class s))
		(name  (slot-definition-name s)))
	   ; For each slot we have '(name init-function getter setter)
	   ; If slot, we have the simplest form '(name init-function . index)
	   (verify-accessors name g-n-s)
	   (cons name
		 (cons (compute-slot-init-function s)
		       g-n-s))))
       slots))

;;; compute-cpl
;;;
;;; Correct behaviour:
;;;
;;; (define-class food ())
;;; (define-class fruit (food))
;;; (define-class spice (food))
;;; (define-class apple (fruit))
;;; (define-class cinnamon (spice))
;;; (define-class pie (apple cinnamon))
;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
;;;
;;; (define-class d ())
;;; (define-class e ())
;;; (define-class f ())
;;; (define-class b (d e))
;;; (define-class c (e f))
;;; (define-class a (b c))
;;; => cpl (a) = a b d c e f object top
;;;

(define-method (compute-cpl (class <class>))
  (compute-std-cpl class class-direct-supers))

;; Support

(define (only-non-null lst)
  (filter (lambda (l) (not (null? l))) lst))

(define (compute-std-cpl c get-direct-supers)
  (let ((c-direct-supers (get-direct-supers c)))
    (merge-lists (list c)
                 (only-non-null (append (map class-precedence-list
					     c-direct-supers)
                                        (list c-direct-supers))))))

(define (merge-lists reversed-partial-result inputs)
  (cond
   ((every null? inputs)
    (reverse! reversed-partial-result))
   (else
    (let* ((candidate (lambda (c)
                        (and (not (any (lambda (l)
                                         (memq c (cdr l)))
                                       inputs))
                             c)))
           (candidate-car (lambda (l)
                            (and (not (null? l))
                                 (candidate (car l)))))
           (next (any candidate-car inputs)))
      (if (not next)
          (goops-error "merge-lists: Inconsistent precedence graph"))
      (let ((remove-next (lambda (l)
                           (if (eq? (car l) next)
                               (cdr l)
                             l))))
        (merge-lists (cons next reversed-partial-result)
                     (only-non-null (map remove-next inputs))))))))

;; Modified from TinyClos:
;;
;; A simple topological sort.
;;
;; It's in this file so that both TinyClos and Objects can use it.
;;
;; This is a fairly modified version of code I originally got from Anurag
;; Mendhekar <[e-mail]>.
;;

(define (compute-clos-cpl c get-direct-supers)
  (top-sort ((build-transitive-closure get-direct-supers) c)
	    ((build-constraints get-direct-supers) c)
	    (std-tie-breaker get-direct-supers)))


(define (top-sort elements constraints tie-breaker)
  (let loop ((elements    elements)
	     (constraints constraints)
	     (result      '()))
    (if (null? elements)
	result