Welcome to the CHICKEN Scheme pasting service

(use coops)

(module
 m1
 *
 (import chicken scheme)
 (use coops)
 (define-class a1)
 (define-method (foo (o a1))
   (print "1")))

(module
 m2
 *
 (import chicken scheme)
 (use coops)
 (define-class a2)
 (define-method (foo (o a2))
   (print "2")))

(import m1 m2)

(print (foo (make a2)))
(print (foo (make a1)))

;; 2
;; #<unspecified>

;; Error: (foo) no method defined for given argument classes: (#<coops standard-class `a1'>)

(use coops)

(module
 m1
 *
 (import chicken scheme)
 (use coops)
 (define-class a1)
 (define (foo o)
   (print "1")))

(module
 m2
 *
 (import chicken scheme)
 (use coops)
 (import m1)
 (define-class a2)
 (define (foo o)
   (print "2")))

(import m1 m2)

(print (foo (make a2)))

Warning: redefinition of imported value binding: foo
2
#<unspecified>

(use coops)

(module
 m1
 *
 (import chicken scheme)
 (use coops)
 (define-class a1 ()
   ((foo 1)))
 (define .foo (getter-with-setter
	       (lambda (o) (slot-value o 'foo))
	       (lambda (o v) (set! (slot-value o 'foo) v)))))

(module
 m2
 *
 (import chicken scheme)
 (use coops)
 (import m1)
 (define-class a2 ()
   ((foo 2)))
 (define .foo (getter-with-setter
	       (lambda (o) (slot-value o 'foo))
	       (lambda (o v) (set! (slot-value o 'foo) v)))))

(import m1 m2)

(print (.foo (make a2)))

(import mydepend)
(myprovide coops-wrap)

;; A replacement for define-class that does not redefine the same class.
;; With it you can safely reload the file and update only the methods.
(module
 coops-wrap
 (variable-bound?
  defclass)
 (import chicken scheme)
 (use coops) 
 (use srfi-1
      srfi-13
      srfi-69) 
 (begin-for-syntax (import chicken))
 
 (define-syntax variable-bound?
   (ir-macro-transformer
    (lambda (e i c)
      (let [(varname (second e))]
	`(handle-exceptions
	     exn
	   (not (equal? "unbound variable"
			((condition-property-accessor 'exn 'message) exn)))
	   ,varname
	   #t)))))

 (begin-for-syntax
  (define-syntax variable-bound?
    (ir-macro-transformer
     (lambda (e i c)
       (let [(varname (second e))]
	 `(handle-exceptions
	      exn
	    (not (equal? "unbound variable"
			 ((condition-property-accessor 'exn 'message) exn)))
	    ,varname
	    #t))))))

 (begin-for-syntax
  (define-syntax defonce
    (ir-macro-transformer
     (lambda (e i c)
       `(unless (variable-bound? ,(second e))
	  (define ,(second e) ,(third e)))))))
 
 (define-syntax defonce
   (ir-macro-transformer
    (lambda (e i c)
      `(unless (variable-bound? ,(second e))
	 (define ,(second e) ,(third e))))))

 (begin-for-syntax
  (define-syntax dm			; debug message
    (ir-macro-transformer
     (lambda (e i c)
       (if #t
	   `(print ,@(drop e 1))
	   `(begin))))))

 (define-for-syntax (defonce var val)
   `(unless (variable-bound? ,var)
      (define ,var ,val)))

 (cond-expand
  (development
   (print "Defining coops-warp in development mode")
   (export
    -get-class-form
    -set-class-form
    -coops-wrap-get-class
    -coops-wrap-set-class
    *coops-wrap-classes*
    *coops-wrap-class-forms*
    coops-wrap-update-forms-s)
   ;; class symbol -> quoted class definition form
   (defonce *coops-wrap-class-forms* (make-hash-table))

   (define (-get-class-form sym)
     (hash-table-ref/default *coops-wrap-class-forms* sym #f))

   (define (-set-class-form sym form id)
     (hash-table-set! *coops-wrap-class-forms* sym (list form id)))

   (begin-for-syntax
    (defonce *coops-wrap-class-forms-s* (make-hash-table))
    (defonce *coops-wrap-cur-class-id* 0)

    (define (-get-next-class-id parent-ids)
      (let [(new-id (apply max *coops-wrap-cur-class-id* parent-ids))]
	(set! *coops-wrap-cur-class-id* (add1 new-id))
	new-id))
    
    (define (-set-class-form-s sym form id)
      (hash-table-set! *coops-wrap-class-forms-s* sym (list form id)))
    
    (define (-get-class-form-s sym)
      (hash-table-ref/default *coops-wrap-class-forms-s* sym #f)))

   ;; class symbol -> class-object
   (defonce *coops-wrap-classes* (make-hash-table))
   (define (-coops-wrap-get-class sym)
     (hash-table-ref *coops-wrap-classes* sym))

   (define (-coops-wrap-set-class sym value)
     (hash-table-set! *coops-wrap-classes* sym value))

   ;; Shovels stuff from *coops-wrap-class-forms* to *coops-wrap-class-forms-s*.
   ;; This makes the syntax environment aware of defined classes.
   (define-syntax coops-wrap-update-forms-s
     (ir-macro-transformer
      (lambda _
	`(let [(new-forms-s (make-hash-table))]
	   (print "--- update-forms-s ---")
	   (print "*coops-wrap-classes* \t\t" (hash-table-keys *coops-wrap-classes*))
	   (print "*coops-wrap-class-forms* \t" (hash-table-keys *coops-wrap-class-forms*))
	   (print "*coops-wrap-class-forms-s* \t" (hash-table-keys *coops-wrap-class-forms-s*))
	   (for-each
	    (lambda (s)
	      (hash-table-set! new-forms-s s
			       (hash-table-ref *coops-wrap-class-forms* s)))
	    (hash-table-keys *coops-wrap-class-forms*))
	   (set! *coops-wrap-class-forms-s* new-forms-s)
	   (print "old *coops-wrap-cur-class-id*" *coops-wrap-cur-class-id*)
	   (set! *coops-wrap-cur-class-id*
		 (add1 (apply max *coops-wrap-cur-class-id*
			      (append
			       (map second (hash-table-values *coops-wrap-class-forms*))
			       (map second (hash-table-values *coops-wrap-class-forms-s*))))))
	   (print "new *coops-wrap-cur-class-id*" *coops-wrap-cur-class-id*))))))
  (else))

 ;; Expands the writer: reader: accessor: fields.
 (define-for-syntax (expand-orig-accessors i f class-sym)
   ;;(dm "\nAcc " class-sym " " f)
   (cond
    ((null? (drop f 1)) '('()))
    ((not (keyword? (second f))) '('()))
    (else
     (let [(slot-sym (first f))]
       (let loop2 [(fs (drop f 1))
		   (ret '())]
	 (if (null? fs)
	     (begin
	       ;;(dm "Accessors: " (reverse ret)) 
	       (reverse ret))
	     (let [(kw (first fs))
		   (acc-sym (second fs))]
	       (loop2 (drop fs 2)
		      (append (or (and (or (eq? accessor: kw)
					   (eq? writer: kw))
				       `((define-method ((setter ,acc-sym) (o ,class-sym) v)
					   (set! (slot-value o ',slot-sym) v))
					 (export ,acc-sym)))
				  '())
			      (or (and (or (eq? accessor: kw)
					   (eq? reader: kw))
				       `((define-method (,acc-sym (o ,class-sym))
					   (slot-value o ',slot-sym))
					 (export ,acc-sym)))
				  '())
			      ret)))))))))
 
 (define-for-syntax (get-accessors e i c)
   (let* [(class-sym (second e))
	  (const-sym (i (string->symbol
			 (string-append
			  (symbol->string (i class-sym)) "."))))]
     (let* [(slot-syms (or (and (eq? 4 (length e)) (map i (map first (fourth e))))
			   '()))
	    (slot-forms (or (and (eq? 4 (length e)) (fourth e))
			    '()))
	    (accessor-forms
	     (map (lambda (slot-sym f)
		    (let [(acc-sym (i (string->symbol
				       (string-append
					"." (symbol->string slot-sym)))))]
		      (print "s " slot-sym " " acc-sym)
		      `(begin
			 (export ,acc-sym)
			 (define-method (,acc-sym (o ,class-sym))
			   (slot-value o ',(i slot-sym)))
			 (define-method ((setter ,acc-sym) (o ,class-sym) v)
			   (set! (slot-value o ',(i slot-sym)) v))
			 ;; (define ,acc-sym (getter-with-setter
			 ;; 		   (lambda (o) (slot-value o ',(i slot-sym)))
			 ;; 		   (lambda (o v)
			 ;; 		     (set! (slot-value o ',(i slot-sym)) v))))
			 ,@(expand-orig-accessors i f class-sym))))
		  slot-syms
		  slot-forms))
	    (accessor-forms (filter (lambda (o) o) accessor-forms))]
       accessor-forms)))

 (define-for-syntax (get-class e i c define-class?) 
   (let* [(class-sym (second e))
	  (class-name (symbol->string (i class-sym)))
	  (const-sym (i (string->symbol
			 (string-append
			  (or (and (string-prefix? "<" class-name)
				   (string-suffix? ">" class-name)
				   (substring class-name 1 (sub1 (string-length class-name))))
			      class-name)
			  "."))))
	  (strip-accessors
	   (lambda (f)
	     (if (eq? 4 (length f))
		 (append
		  (take f 3)
		  (list (map (lambda (slot-form)
			       (if (< (length slot-form) 3)
				   slot-form
				   (cons (first slot-form)
					 (let [(init (drop-while (lambda (v)
								   (not (eq? v initform:)))
								 slot-form))]
					   (if (null? init)
					       '()
					       (take init 2))))))
			     (fourth f))))
		 f)))]
     `(begin
	;;(begin-for-syntax (print "defining" (quote ,e)))
	(export ,class-sym)
	,(cond-expand
	  (development
	   (if define-class?
	       `(begin
		  ;;(begin-for-syntax (print "New class " (quote ,class-sym)))
		  (define-class ,@(drop (strip-accessors e) 1))
		  (-coops-wrap-set-class ',(i class-sym) ,class-sym))
	       `(begin
		  ;;(begin-for-syntax (print "Fetching def from table " ',class-sym))
		  (define ,class-sym (-coops-wrap-get-class ',(i class-sym))))))
	  (else
	   `(define-class ,@(drop e 1))))
	(export ,const-sym)
	(define ,const-sym (lambda o (apply make ,class-sym o)))
	
	;;(begin-for-syntax (print "defined" (quote ,e))) 
	)))

 (define-for-syntax (defoo e i c define-class?)
   (print (get-accessors e i c))
   `(begin ,(get-class e i c define-class?)
	   ,@(get-accessors e i c)))

 (define-syntax defclass
   ;; Does various things:
   ;;
   ;; - exports the class
   ;;
   ;; - defines and exports foo. constructor
   ;;
   ;; - defines and exports .foo slot accessors
   ;;
   ;; If the class is already defined then does not redefine it.
   ;;
   ;; When feature development is defined:
   ;;
   ;; The quoted form of the defclass call is stored to a
   ;; variable. Defclass is not "called" again if this form has not
   ;; changed.
   (ir-macro-transformer
    (lambda (e i c)
      (dm "")
      (dm "---   "(cond-expand (development "DEV") (else "NON DEV"))
	  " " (i (second e))
	  " module: " (and (##sys#current-module)
			   (##sys#slot (##sys#current-module) 1)))
      (let* [(to-form-sym (lambda (s)
			    (string->symbol
			     (string-append
			      "#"
			      (symbol->string s)
			      "#"))))
	     (parent-ids (lambda (form)
			   (map (compose second -get-class-form-s to-form-sym)
				(or (and (< 1 (length form)) (second form))
				    '())))) 
	     (formsym (i (to-form-sym (i (second e)))))
	     (parent-changed?
	      (lambda ()
		(let* [(form-id (-get-class-form-s formsym))
		       (old-form (first form-id))
		       (old-id (second form-id))
		       (parent-ids (parent-ids old-form))]
		  (dm "Parents " (or (and (< 1 (length old-form)) (second old-form)) '())) 
		  (dm "Old id " old-id " parent ids " parent-ids)
		  (find (lambda (pi) (> pi old-id)) parent-ids))))(class-sym (i (second e)))
	     (def-form (strip-syntax (drop e 1)))]
	(cond-expand
	 (development
	  ;; (dm "syntax form table START")
	  ;; (for-each (lambda (k) (dm k))
	  ;; 	    (hash-table-keys *coops-wrap-class-forms-s*))
	  ;; (dm "syntax form table END")
	   
	  ;;(dm "Bdound" (variable-bound? *coops-wrap-classes*))
	  ;;(dm "forms-s" (hash-table-keys *coops-wrap-class-forms-s*))
	   
	  (if (not (-get-class-form-s formsym))
	      ;; NOTE: Here the wrong thing is done and define-class is
	      ;; used at non-toplevel context. For this hack to work
	      ;; these branches have to be in this order!
	      (let [(class-id (-get-next-class-id (parent-ids (i (drop e 1)))))]
		(dm "New class " class-sym " id: " class-id)
		(-set-class-form-s formsym def-form class-id)
		`(begin
		   (begin-for-syntax (-set-class-form-s ',(i formsym) ',(i def-form) ,class-id))
		   (-set-class-form (quote ,formsym) (quote ,(i def-form)) ,class-id)
		   ,(defoo e i c #t)))
	      (if (equal? (first (-get-class-form-s formsym)) def-form) 
		  (if (parent-changed?)
		      (let [(class-id (-get-next-class-id (parent-ids (i (drop e 1)))))]
			(dm "Redefining class because of parent change, new id " class-id )
			(-set-class-form-s formsym def-form class-id)
			`(begin
			   (-set-class-form (quote ,formsym) (quote ,(i def-form)) ,class-id) 
			   ,(defoo e i c #t)))
		      (begin
			(dm "Not redefining class " class-sym)
			`(begin
			   ;;(begin-for-syntax (print "class " ,(second e)))
			   ,(defoo e i c #f))))
		  (let [(class-id (-get-next-class-id (parent-ids (i (drop e 1)))))]
		    (dm "Redefining class " class-sym " id: " class-id)
		    (dm "old " (-get-class-form-s formsym))
		    (-set-class-form-s formsym def-form class-id)
		    (dm "new " (-get-class-form-s formsym)) 
		    `(begin
		       (begin-for-syntax (-set-class-form-s ',(i formsym) ',(i def-form) ,class-id))
		       (-set-class-form (quote ,formsym) (quote ,(i def-form)) ,class-id) 
		       ,(defoo e i c #t))))))
	 (else 
	  (defoo e i c #t)))))))
 )

(use coops)

(module
 foo
 (get-acc)
 (import chicken scheme)
 (use coops)
 (use srfi-69)
 (define *accs* (make-hash-table))
 (define (get-acc s)
   (or (hash-table-ref/default *accs* s #f)
       (and (hash-table-set! *accs* s (make-generic-procedure a))
	    (hash-table-ref *accs* s)))))

(module
 m1
 (a1 .foo)
 (import chicken scheme)
 (use coops)
 (import foo)
 (define-class a1)
 (define .foo (get-acc 'foo))
 (register-generic-procedure .foo)
 (define-method (.foo (o a1)) 1))

(module
 m2
 (a2 .foo)
 (import chicken scheme)
 (use coops)
 (import foo)
 ;;(import (only m1 foo))
 (define-class a2)
 (define .foo (get-acc 'foo))
 (register-generic-procedure .foo)
 (define-method (.foo (o a2)) 
   2))

(import m1 m2)

(print "2=" (.foo (make a2)))
(print "1=" (.foo (make a1)))

;; 2=2
;; 1=1