;; -*-theme-d-*-

;; Copyright (C) 2016 Tommi Höynälänmaa
;; Distributed under GNU General Public License version 3,
;; see file doc/GPL-3.

;; Expected results: translation and running OK


(define-proper-program (tests test402)

  (import (standard-library core)
	  (standard-library string-utilities)
	  (standard-library object-string-conversion)
	  (standard-library console-io))

  (define-class <graphics-context> <object> #t #f #f public ()
    ((i-x <integer> public public)
     (i-y <integer> public public)
     (i-width <integer> public public)
     (i-height <integer> public public)))

  (define-class <widget> <object> #t #f #f public ()
    ((context (:maybe <graphics-context>) public module null)
     (widget-parent (:maybe <widget>) public module null)))

  (define-class <label> <widget> #t #f #f public ()
    ())

  (define-simple-proc logger-print (((str-message <string>)) <none> nonpure)
    (console-display-line str-message))

  (define-simple-method initialize
    (((widget <widget>) (context <graphics-context>)
      (widget-parent (:maybe <widget>)))
     <none> nonpure)
    (logger-print "initialize widget")
    (field-set! widget 'context context)
    (field-set! widget 'widget-parent widget-parent))

  (define-simple-method initialize
    (((label <label>) (context <graphics-context>) (widget-parent <widget>))
     <none> nonpure)
    (logger-print "initialize label")
    ((generic-proc-dispatch-without-result
      initialize
      (<widget> <graphics-context> <widget>)
      ())
     label context widget-parent))

  (define-simple-method object->string (((context <graphics-context>))
					<string>
					pure)
    (string-append "(graphics-context "
		   (integer->string (field-ref context 'i-x))
		   " "
		   (integer->string (field-ref context 'i-y))
		   " "
		   (integer->string (field-ref context 'i-width))
		   " "
		   (integer->string (field-ref context 'i-height))
		   ")"))

  (define-simple-proc main (() <none> nonpure)
    (let* ((widget-parent
	    (let ((widget1 (make <widget>)))
	      (initialize widget1
			  (make <graphics-context> 100 100 400 200)
			  null)
	      widget1))
	   (label
	    (let ((label1 (make <label>)))
	      (initialize label1
			  (make <graphics-context> 100 100 200 50)
			  widget-parent)
	      label1)))
      (console-display-line (field-ref label 'context))
      (console-display-line (field-ref
			     (cast <widget>
				   (field-ref label 'widget-parent))
			     'context)))))

