;; -*-theme-d-*-

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

;; Expected results: translation and running OK
;;  but running requires _b_my-map to be defined in
;;  the runtime environment.

(define-proper-program (tests test496)

  (import (standard-library core-forms))

  (define _console-display
    (unchecked-prim-proc
     theme-prim-console-display (<object>) <none> nonpure))

  (define console-display-string
    (lambda (((str <string>)) <none> nonpure)
      (_console-display str)))

  (define console-newline
    (prim-proc theme-console-newline () <none> nonpure))

  (define integer->string
    (prim-proc number->string (<integer>) <string> pure))

  (define-param-proc-alt list (%arglist)
    (unchecked-prim-proc list ((splice %arglist)) %arglist pure))

  (define-param-proc-alt car (%type1 %type2)
    (unchecked-prim-proc car ((:pair %type1 %type2)) %type1
			 (pure always-returns)))

  (define integer+
    (prim-proc + (<integer> <integer>) <integer> pure))


  (define my-map
    (param-prim-proc _b_my-map
		     (%arglist %result-type)
		     ((:procedure ((splice %arglist)) %result-type pure)
		      (splice (type-loop %argtype %arglist
					 (:uniform-list %argtype))))
		     (:uniform-list %result-type)
		     pure))

  (define-param-logical-type :nonempty-uniform-list (%type)
    (:pair %type (:uniform-list %type)))

  (define main
    (lambda (() <none> nonpure)
      (let* ((lst (list 1 2 3 4 5))
	     (result (my-map (lambda (((i <integer>)) <integer> pure)
			       (integer+ i 1))
			     lst)))
	(console-display-string
	 (integer->string (car (cast (:nonempty-uniform-list <integer>)
				     result))))
	(console-newline)))))

