
;; The parts of kernel.rkt are generated by xctocc.
;; kernel.rkt is generated by a target in <builddir>/mred/wxs/Makefile.

(module kernel mzscheme
  (require (all-except mzlib/class object%))

  ;; Pull pieces out of #%mred-kernel dynamically, so that
  ;;  the library compiles with setup-plt in mzscheme.
  
  (define kernel:initialize-primitive-object
    (dynamic-require ''#%mred-kernel 'initialize-primitive-object))
  (define kernel:primitive-class-find-method
    (dynamic-require ''#%mred-kernel 'primitive-class-find-method))
  (define kernel:primitive-class-prepare-struct-type!
    (dynamic-require ''#%mred-kernel 'primitive-class-prepare-struct-type!))

  (define-syntax define-constant
    (lambda (stx)
      (syntax-case stx ()
	[(_ name)
	 (with-syntax ([kernel:name (datum->syntax-object
				     (syntax name)
				     (string->symbol
				      (format 
				       "kernel:~a"
				       (syntax-e (syntax name))))
				     #f)])
	   (syntax
	    (begin
	      (define kernel:name (dynamic-require ''#%mred-kernel 'name))
	      (provide (protect (rename kernel:name name))))))])))

  (define-syntax define-function
    (lambda (stx)
      (syntax-case stx ()
	[(_ name)
	 (syntax (define-constant name))])))

  (define-syntax define-functions
    (lambda (stx)
      (syntax-case stx ()
	[(_ name ...)
	 (syntax (begin (define-function name) ...))])))

  (define-syntax define-a-class
    (let ([defined null])
      (lambda (stx)
	(syntax-case stx ()
	  [(_ name print-name super (intf ...) args id ...)
	   (let ([nm (syntax-e (syntax name))]
		 [sn (syntax-e (syntax super))]
		 [ids (map syntax-e (syntax->list (syntax (id ...))))])
	     ;; find superclass
	     (let ([sup (assoc sn defined)])
	       (unless (or sup (not sn))
		 (raise-syntax-error
		  'class
		  "class not yet defined"
		  stx
		  (syntax super)))
	       ;; add this class to the list:
	       (set! defined (cons (cons nm (append (if sup
							(cdr sup)
							null)
						    ids))
				   defined))
	       (let-values ([(old new)
			     (let loop ([l ids][o null][n null])
			       (cond
				[(null? l) (values o n)]
				[(memq (car l) (cdr sup))
				 (loop (cdr l) (cons (car l) o) n)]
				[else
				 (loop (cdr l) o (cons (car l) n))]))])
		 (with-syntax ([(old ...) (datum->syntax-object #f old #f)]
			       [(new ...) (datum->syntax-object #f new #f)])
		   (syntax
		    (define name (let ([c (dynamic-require ''#%mred-kernel 'name)])
				   (make-primitive-class
				    (lambda (class prop:object preparer dispatcher more-props)
				      (kernel:primitive-class-prepare-struct-type! 
				       c prop:object class preparer dispatcher more-props))
				    kernel:initialize-primitive-object
				    'print-name super (list intf ...) 'args
				    '(old ...)
				    '(new ...)
				    (list
				     (kernel:primitive-class-find-method c 'old)
				     ...)
				    (list
				     (kernel:primitive-class-find-method c 'new)
				     ...)))))))))]))))

  (define-syntax define-class
    (lambda (stx)
      (syntax-case stx ()
	[(_ name super args id ...)
	 (syntax
	  (begin 
	    (define-a-class name name super args id ...)
	    (provide (protect name))))])))

  (define-syntax define-private-class
    (lambda (stx)
      (syntax-case stx ()
	[(_ name intf super args id ...)
	 (syntax
	  (begin 
	    (define-a-class name intf super args id ...)
	    (define intf (class->interface name))
	    (provide (protect intf))))])))
