goops.scm

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

	  ((procedure-with-setter? old-definition)
	   (make <generic-with-setter>
		 #:name name
		 #:default (procedure old-definition)
		 #:setter (setter old-definition)))
	  ((procedure? old-definition)
	   (make <generic> #:name name #:default old-definition))
	  (else (make <generic> #:name name)))))

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

(define (make-setter-name name)
  (string->symbol (string-append "setter:" (symbol->string name))))

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

(define (ensure-accessor proc . name)
  (let ((name (and (pair? name) (car name))))
    (cond ((is-a? proc <generic-with-setter>)
	   (if (is-a? (setter proc) <generic>)
	       proc
	       (upgrade-generic-with-setter proc (setter proc))))
	  ((is-a? proc <generic>)
	   (upgrade-generic-with-setter proc (make-generic name)))
	  ((procedure-with-setter? proc)
	   (make <generic-with-setter>
		 #:name name
		 #:default (procedure proc)
		 #:setter (ensure-generic (setter proc) name)))
	  ((procedure? proc)
	   (ensure-accessor (ensure-generic proc name) name))
	  (else
	   (make-accessor name)))))

(define (upgrade-generic-with-setter generic setter)
  (let ((methods (generic-function-methods generic))
	(gws (make <generic-with-setter>
		   #:name (generic-function-name generic)
		   #:setter setter)))
    ;; Steal old methods
    (for-each (lambda (method)
		(slot-set! method 'generic-function gws))
	      methods)
    (slot-set! gws 'methods methods)
    gws))

;;;
;;; {Methods}
;;;

(define define-method
  (procedure->memoizing-macro
    (lambda (exp env)
      (let ((head (cadr exp)))
	(if (not (pair? head))
	    (goops-error "bad method head: ~S" head)
	    (let ((gf (car head)))
	      (cond ((and (pair? gf)
			  (eq? (car gf) 'setter)
			  (pair? (cdr gf))
			  (symbol? (cadr gf))
			  (null? (cddr gf)))
		     ;; named setter method
		     (let ((name (cadr gf)))
		       (cond ((not (symbol? name))
			      `(add-method! (setter ,name)
					    (method ,(cdadr exp)
						    ,@(cddr exp))))
			     ((defined? name env)
			      `(begin
				 ;; *fixme* Temporary hack for the current
				 ;;         module system
				 (if (not ,name)
				     (define-accessor ,name))
				 (add-method! (setter ,name)
					      (method ,(cdadr exp)
						      ,@(cddr exp)))))
			     (else
			      `(begin
				 (define-accessor ,name)
				 (add-method! (setter ,name)
					      (method ,(cdadr exp)
						      ,@(cddr exp))))))))
		    ((not (symbol? gf))
		     `(add-method! ,gf (method ,(cdadr exp) ,@(cddr exp))))
		    ((defined? gf env)
		     `(begin
			;; *fixme* Temporary hack for the current
			;;         module system
			(if (not ,gf)
			    (define-generic ,gf))
			(add-method! ,gf
				     (method ,(cdadr exp)
					     ,@(cddr exp)))))
		    (else
		     `(begin
			(define-generic ,gf)
			(add-method! ,gf
				     (method ,(cdadr exp)
					     ,@(cddr exp))))))))))))

(define (make-method specializers procedure)
  (make <method>
	#:specializers specializers
	#:procedure procedure))

(define method
  (letrec ((specializers
	    (lambda (ls)
	      (cond ((null? ls) '('()))
		    ((pair? ls) (cons (if (pair? (car ls))
					  (cadar ls)
					  '<top>)
				      (specializers (cdr ls))))
		    (else '(<top>)))))
	   (formals
	    (lambda (ls)
	      (if (pair? ls)
		  (cons (if (pair? (car ls)) (caar ls) (car ls))
			(formals (cdr ls)))
		  ls))))
    (procedure->memoizing-macro
      (lambda (exp env)
	(let ((args (cadr exp))
	      (body (cddr exp)))
	  `(make <method>
		 #:specializers (cons* ,@(specializers args))
		 #:procedure (lambda ,(formals args)
			       ,@(if (null? body)
				     (list *unspecified*)
				     body))))))))

;;;
;;; {add-method!}
;;;

(define (add-method-in-classes! m)
  ;; Add method in all the classes which appears in its specializers list
  (for-each* (lambda (x)
	       (let ((dm (class-direct-methods x)))
		 (if (not (memv m dm))
		     (slot-set! x 'direct-methods (cons m dm)))))
	     (method-specializers m)))

(define (remove-method-in-classes! m)
  ;; Remove method in all the classes which appears in its specializers list
  (for-each* (lambda (x)
	       (slot-set! x
			  'direct-methods
			  (delv! m (class-direct-methods x))))
	     (method-specializers m)))

(define (compute-new-list-of-methods gf new)
  (let ((new-spec (method-specializers new))
	(methods  (generic-function-methods gf)))
    (let loop ((l methods))
      (if (null? l)
	  (cons new methods)
	  (if (equal? (method-specializers (car l)) new-spec)
	      (begin 
		;; This spec. list already exists. Remove old method from dependents
		(remove-method-in-classes! (car l))
		(set-car! l new) 
		methods)
	      (loop (cdr l)))))))

(define (internal-add-method! gf m)
  (slot-set! m  'generic-function gf)
  (slot-set! gf 'methods (compute-new-list-of-methods gf m))
  (let ((specializers (slot-ref m 'specializers)))
    (slot-set! gf 'n-specialized
	       (max (length* specializers)
		    (slot-ref gf 'n-specialized))))
  (%invalidate-method-cache! gf)
  (add-method-in-classes! m)
  *unspecified*)

(define-generic add-method!)

(internal-add-method! add-method!
		      (make <method>
			#:specializers (list <generic> <method>)
			#:procedure internal-add-method!))

(define-method (add-method! (proc <procedure>) (m <method>))
  (if (generic-capability? proc)
      (begin
	(enable-primitive-generic! proc)
	(add-method! proc m))
      (next-method)))

(define-method (add-method! (pg <primitive-generic>) (m <method>))
  (add-method! (primitive-generic-generic pg) m))

(define-method (add-method! obj (m <method>))
  (goops-error "~S is not a valid generic function" obj))

;;;
;;; {Access to meta objects}
;;;

;;;
;;; Methods
;;;
(define-method (method-source (m <method>))
  (let* ((spec (map* class-name (slot-ref m 'specializers)))
	 (proc (procedure-source (slot-ref m 'procedure)))
	 (args (cadr proc))
	 (body (cddr proc)))
    (cons 'method
	  (cons (map* list args spec)
		body))))

;;;
;;; Slots
;;;
(define slot-definition-name car)

(define slot-definition-options cdr)

(define (slot-definition-allocation s)
  (get-keyword #:allocation (cdr s) #:instance))

(define (slot-definition-getter s)
  (get-keyword #:getter (cdr s) #f))

(define (slot-definition-setter s)
  (get-keyword #:setter (cdr s) #f))

(define (slot-definition-accessor s)
  (get-keyword #:accessor (cdr s) #f))

(define (slot-definition-init-value s)
  ;; can be #f, so we can't use #f as non-value
  (get-keyword #:init-value (cdr s) (make-unbound)))

(define (slot-definition-init-form s)
  (get-keyword #:init-form (cdr s) (make-unbound)))

(define (slot-definition-init-thunk s)
  (get-keyword #:init-thunk (cdr s) #f))

(define (slot-definition-init-keyword s)
  (get-keyword #:init-keyword (cdr s) #f))

(define (class-slot-definition class slot-name)
  (assq slot-name (class-slots class)))

(define (slot-init-function class slot-name)
  (cadr (assq slot-name (slot-ref class 'getters-n-setters))))


;;;
;;; {Standard methods used by the C runtime}
;;;

;;; Methods to compare objects
;;;

(define-method (object-eqv? x y)    #f)
(define-method (object-equal? x y)  (eqv? x y))

;;;
;;; methods to display/write an object
;;;

;     Code for writing objects must test that the slots they use are
;     bound. Otherwise a slot-unbound method will be called and will 
;     conduct to an infinite loop.

;; Write
(define (display-address o file)
  (display (number->string (object-address o) 16) file))

(define-method (write o file)
  (display "#<instance " file)
  (display-address o file)
  (display #\> file))

(define write-object (primitive-generic-generic write))

(define-method (write (o <object>) file)
  (let ((class (class-of o)))
    (if (slot-bound? class 'name)
	(begin
	  (display "#<" file)
	  (display (class-name class) file)
	  (display #\space file)
	  (display-address o file)
	  (display #\> file))
	(next-method))))

(define-method (write (o <foreign-object>) file)
  (let ((class (class-of o)))
    (if (slot-bound? class 'name)
	(begin
	  (display "#<foreign-object " file)
	  (display (class-name class) file)
	  (display #\space file)
	  (display-address o file)
	  (display #\> file))
	(next-method))))

(define-method (write (class <class>) file)
  (let ((meta (class-of class)))
    (if (and (slot-bound? class 'name)
	     (slot-bound? meta 'name))
	(begin
	  (display "#<" file)
	  (display (class-name meta) file)
	  (display #\space file)
	  (display (class-name class) file)
	  (display #\space file)
	  (display-address class file)
	  (display #\> file))
	(next-method))))

(define-method (write (gf <generic>) file)
  (let ((meta (class-of gf)))
    (if (and (slot-bound? meta 'name)
	     (slot-bound? gf 'methods))
	(begin
	  (display "#<" file)
	  (display (class-name meta) file)
	  (let ((name (generic-function-name gf)))
	    (if name
		(begin
		  (display #\space file)
		  (display name file))))
	  (display " (" file)
	  (display (length (generic-function-methods gf)) file)
	  (display ")>" file))
	(next-method))))

(define-method (write (o <method>) file)
  (let ((meta (class-of o)))
    (if (and (slot-bound? meta 'name)
	     (slot-bound? o 'specializers))
	(begin
	  (display "#<" file)
	  (display (class-name meta) file)
	  (display #\space file)
	  (display (map* (lambda (spec)
			   (if (slot-bound? spec 'name)
			       (slot-ref spec 'name)
			       spec))
			 (method-specializers o))
		   file)
	  (display #\space file)
	  (display-address o file)
	  (display #\> file))
	(next-method))))

;; Display (do the same thing as write by default)
(define-method (display o file) 
  (write-object o file))

;;;
;;; slot access
;;;

(define (class-slot-g-n-s class slot-name)
  (let* ((this-slot (assq slot-name (slot-ref class 'slots)))
	 (g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters))
			  (slot-missing class slot-name)))))