;*=====================================================================*/
;*    serrano/prgm/project/bigloo/recette/vital.scm                    */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Tue Dec  3 17:11:11 2002                          */
;*    Last change :  Wed Dec 10 10:41:13 2003 (serrano)                */
;*    Copyright   :  2002-03 Manuel Serrano                            */
;*    -------------------------------------------------------------    */
;*    Preliminary tests for Bigloo.                                    */
;*=====================================================================*/

;*---------------------------------------------------------------------*/
;*    The module                                                       */
;*---------------------------------------------------------------------*/
(module vital
   (import  (main "main.scm"))
   (include "test.sch")
   (export  (test-vital))
   (static  var))

;*---------------------------------------------------------------------*/
;*    var ...                                                          */
;*---------------------------------------------------------------------*/
(define var var)

;*---------------------------------------------------------------------*/
;*    bar ...                                                          */
;*---------------------------------------------------------------------*/
(define (bar . l)
   l)

(set! bar 'toto)

;*---------------------------------------------------------------------*/
;*    foo ...                                                          */
;*---------------------------------------------------------------------*/
(define (foo x)
   (if (integer? x)
       (begin
	  (set! x #f)
	  (integer? x))
       #t))

;*---------------------------------------------------------------------*/
;*    vital:write ...                                                  */
;*---------------------------------------------------------------------*/
(define (vital:write s)
   (let ((p (open-output-string)))
      (write s p)
      (let* ((s (close-output-port p))
	     (p (open-input-string s)))
	 (let ((res (read p)))
	    (close-input-port p)
	    res))))

;*---------------------------------------------------------------------*/
;*    vital:write2 ...                                                 */
;*---------------------------------------------------------------------*/
(define (vital:write2 s)
   (with-input-from-string (with-output-to-string
			      (lambda ()
				 (write s)))
      (lambda ()
	 (let ((res (read)))
	    res))))

;*---------------------------------------------------------------------*/
;*    vital:write3 ...                                                 */
;*---------------------------------------------------------------------*/
(define (vital:write3 s)
   (with-input-from-string (with-error-to-string
			      (lambda ()
				 (with-output-to-string
				    (lambda ()
				       (display 1 (current-error-port))
				       (write s)))))
      (lambda ()
	 (let ((res (read)))
	    res))))

;*---------------------------------------------------------------------*/
;*    vital:hoist ...                                                  */
;*---------------------------------------------------------------------*/
(define cur_ref (make-cell 0))

(define (vital:hoist)
   (let ((x1 (let ((x2 (cell-ref cur_ref)))
		(begin
		   (cell-set! cur_ref (+fx x2 1))
		   x2)))
	 (x2 (let ((x2 (cell-ref cur_ref)))
		(begin
		   (cell-set! cur_ref (+fx x2 1))
		   x2))))
      (eq? x1 x2)))

;*---------------------------------------------------------------------*/
;*    Un bug dans le soft-typing (un truc qui ne se compilait pas).    */
;*---------------------------------------------------------------------*/
(let ((revtype2
       (labels ((revtype (parent t flag)
                         (let ((rev (lambda (q)
                                       (revtype t q #f))))
                            (if flag (rev 1)))))
          revtype)))
   (revtype2 1 2 #f))

;*---------------------------------------------------------------------*/
;*    producer ...                                                     */
;*---------------------------------------------------------------------*/
(define (producer a b)
   (values (+ a 1) (+ b 1)))
   
;*---------------------------------------------------------------------*/
;*    Top level definition orders                                      */
;*---------------------------------------------------------------------*/
(define order_foo 0)
(define order_foo1 (begin (set! order_foo (+fx order_foo 1)) order_foo))
(define order_foo2 (begin (set! order_foo (+fx order_foo 1)) order_foo))
(begin
   (define order_foo3 (begin (set! order_foo (+fx order_foo 1)) order_foo))
   (define order_foo4 (begin (set! order_foo (+fx order_foo 1)) order_foo)))
(define order_foo5 (begin (set! order_foo (+fx order_foo 1)) order_foo))

(define order_bar 0)
(define order_bar1 1)
(define order_bar2 1)
(define order_bar3 1)
(define order_bar4 1)
(define order_bar5 1)
(define order_bar6 1)
(define order_bar7 1)
(define order_bar8 1)

(begin
   (begin
      (begin
	 (set! order_bar (+fx order_bar 1))
	 (set! order_bar1 order_bar)
	 (set! order_bar (+fx order_bar 1))
	 (set! order_bar2 order_bar))
      (begin
	 (set! order_bar (+fx order_bar 1))
	 (set! order_bar3 order_bar)
	 (set! order_bar (+fx order_bar 1))
	 (set! order_bar4 order_bar))
      (set! order_bar (+fx order_bar 1))
      (set! order_bar5 order_bar)
      (set! order_bar (+fx order_bar 1))
      (set! order_bar6 order_bar))
   (set! order_bar (+fx order_bar 1))
   (set! order_bar7 order_bar)
   (set! order_bar (+fx order_bar 1))
   (set! order_bar8 order_bar))

;*---------------------------------------------------------------------*/
;*    point                                                            */
;*---------------------------------------------------------------------*/
(define-struct point x y)

;*---------------------------------------------------------------------*/
;*    inline/class/generic                                             */
;*---------------------------------------------------------------------*/
(define-inline (inline x) x)
(define-inline (class x) x)
(define-inline (generic x) x)

;*---------------------------------------------------------------------*/
;*    test-args-parse ...                                              */
;*---------------------------------------------------------------------*/
(define (test-args-parse)
   (let ((res 0))
      (define (do-args-parse args)
	 (args-parse args
	    (("-Obench" (help "Benchmarking mode"))
	     (set! res (bit-or res 1))
	     (do-args-parse `("-O5" "-unsafe"
				    "-copt" "-O4"
				    "-static-bigloo"))) 
	    (("-O?opt" (help "-O"))
	     (set! res (bit-or res 2)))
	    (("-unsafe?opt" (help "unsafe"))
	     (set! res (bit-or res 4)))
	    (("-copt" ?opt (help "copt"))
	     (set! res (bit-or res 8)))
	    (("-static-bigloo" (help "foo"))
	     (set! res (bit-or res 16)))
	    ((("-h" "--help") (help "An help message"))
	     (set! res (bit-or res 32)))
	    ((("-v" "--version") ?version (help "The version"))
	     (set! res (bit-or res (string->number version))))))
      (do-args-parse '("-Obench" "-h" "--version" "64"))
      res))

;*---------------------------------------------------------------------*/
;*    test-vital ...                                                   */
;*---------------------------------------------------------------------*/
(define (test-vital)
   (test-module "vital" "vital.scm")
   (test "true" #t (not #f))
   (test "true" #t (not (not 4)))
   (test "true" (not (eq? #t #f)) (not #f))
   (test "false" #f (not #t))
   (test "begin" (begin 4 5) 5)
   (test "eq?" 1 1)
   (test "< 0" -1 -1)
   (test "-" (- 2) -2)
   (test "*" (* 2 -1) -2)
   (test "eq? char" (eq? #\a #\a) #t)
   (test "eq? char" (eq? #\| #\|) #t)
   (test "eq? char" (eq? #\a #\A) #F)
   (test "eq? char" (char->integer #\') 39)
   (test "eq? symbol" (eq? 'a 'a) #t)
   (test "eq? symbol" (eq? 'a 'A) #f)
   (test "eq? symbol" (eq? 'A 'A) #t)
   (test "eq? symbol" (eq? 'a 'b) #f)
   (test "define" bar 'toto)
   (test "application" ((lambda args 2)) 2)
   (test "application" ((lambda args 2) 1 2 3 4) 2)
   (test "set!" (foo 5) #f)
   (test "set!" (let ((v (integer? var))) (set! var 4) (set! var 'toto) v) #f)
   (test "symbol" 'étè (string->symbol "étè"))
   (let ((s "toto\"\\\ntiti"))
      (test "write" (vital:write s) s))
   (let ((s "toto\"\\\ntiti"))
      (test "write" (vital:write2 s) s))
   (test "write" (vital:write3 "foobar") 1)
   (test "flonum" (real? (string->obj (obj->string 0.5))) #t)
   (let* ((append! (lambda (x y)
		      (if (null? x)
			  y
			  (do ((a x b)
			       (b (cdr x) (cdr b)))
			      ((null? b)
			       (set-cdr! a y)
			       x)))))
	  (l1      '(1 2 3))
	  (l2      '(4 5 6)))
      (test "do" (append! l1 l2) '(1 2 3 4 5 6)))
   (test "let" (let ((x (begin 1 2 3))) x) 3)
   (test "hoist" (vital:hoist) #f)
   (let* ((s (make-string 3 #\a))
	  (l (list s s)))
      (test "string->obj" (string->obj (obj->string l)) l))
   (let* ((s    "toto n'est pas content")
	  (sp   "titi non plus")
	  (l    (list s s s sp sp s sp sp 'toto 'toto '#(1 2 3) #\a #\a #t #f))
	  (v    `#(,l ,l ,l () ,(unspecified) 1.13 1.13 #a123
		      (point 1 2) (point 2 1) 0010 0011))
	  (vec  (make-vector 3 v))
	  (rep  (obj->string v)))
      (test "intext" (string->obj rep) v))
   (test "top level forms" (list order_foo1
				 order_foo2
				 order_foo3
				 order_foo4
				 order_foo5)
	 '(1 2 3 4 5))
   (test "top level forms" (list order_bar1
				 order_bar2
				 order_bar3
				 order_bar4
				 order_bar5
				 order_bar6
				 order_bar7
				 order_bar8)
	 '(1 2 3 4 5 6 7 8))
   (test "multive-value-bind" (multiple-value-bind (a b c d)
				 (values 1 2 3 4)
				 (- a b c d))
	 -8)
   (test "multiple-value-bind"
	 (multiple-value-bind (x y) (producer 1 2) (+ x y))
	 5)
   (test "call-with-values" (call-with-values (lambda () (values 1 2 3 4))
					      (lambda (a b c d) (+ a b c d)))
	 10)
   (test "call-with-values" (call-with-values * -) -1)
   (cond-expand
      (bigloo-c
       (let ((b (let ((ptr-align (pragma::long "PTR_ALIGNMENT")))
		   (-fx (bit-lsh 1 (+fx ptr-align 3)) ptr-align))))
	  (test "<< >>"  (let ((n (bit-lsh 1 b))
			       (n-1 (bit-lsh 1 (-fx b 1)))
			       (n-2 (bit-lsh 1 (-fx b 2))))
			    (and (>fx n n-1) (>fx n-1 n-2)))
		#t)))
      (else #unspecified))
   (test "cond-expand" (cond-expand
			  (srfi-0 (* 1 2))
			  (else (+ 3 4)))
	 2)
   (test "cond-expand" (eval '(cond-expand
				 (srfi-0 (* 1 2))
				 (else (+ 3 4))))
	 2)
   (test "cond-expand" (cond-expand
			  (srfi-that-does-not-exists (* 1 2))
			  (else (+ 3 4)))
	 7)
   (test "cond-expand(fail)" (eval '(cond-expand
				       (srfi-that-does-not-exists (* 1 2))
				       (else (+ 3 4))))
	 7)
   (test "cond-expand(and)" (cond-expand
			       ((and bigloo srfi-0) 8)
			       (else -1))
	 8)
   (test "cond-expand(and)" (cond-expand
			       ((and bigloo srfi-0 (not bigloo-eval)) 9)
			       (else -1))
	 9)
   (test "cond-expand(and eval)" (eval '(cond-expand
					   ((and bigloo bigloo-eval srfi-0) 4)
					   (else -1)))
	 4)
   (test "cond-expand(or)" (cond-expand
			      ((or bigloo-eval bigloo) 2)
			      (else -1))
	 2)
   (test "cond-expand(or-eval)" (eval '(cond-expand
					  ((or bigloo-eval bigloo) 5)
					  (else -1)))
	 5)
   (test "cond-expand(or)" (cond-expand
			      ((or bigloo bigloo-eval) 2)
			      (else -1))
	 2)
   (test "cond-expand(or-eval)" (eval '(cond-expand
					  ((or bigloo bigloo-eval) 5)
					  (else -1)))
	 5)
   (test "cond-expand" (cond-expand ((and bigloo bigloo) 1) (else 2)) 1)
   (test "cond-expand" (cond-expand (xxx 1) (else 2)) 2)
   (test "cond-expand" (cond-expand ((and bigloo xxx) 1) (else 2)) 2)
   (test "cond-expand" (cond-expand ((and xxx bigloo) 1) (else 2)) 2)
   (test "manling" (bigloo-demangle (bigloo-mangle "toto")) "toto")
   (test "manling" (bigloo-demangle (bigloo-mangle "toto!")) "toto!")
   (let ((s "toto!&^%_23_2342234___"))
      (test "manling" (bigloo-demangle (bigloo-mangle s)) s))
   (test "mangling" (bigloo-mangled? "BgLtoto") #f)
   (test "mangling" (bigloo-mangled? (bigloo-mangle "BgL_toto")) #t)
   (let* ((obj (list 1 2 3 4))
	  (v   (vector 2 3 obj 5)))
      (set-car! obj v)
      (set-car! (cdr obj) obj)
      (test "cycles" (let ((port (open-output-string)))
			(write-circle obj port)
			(let* ((str (close-output-port port))
			       (port (open-input-string str)))
			   (let ((new-obj (read port)))
			      (close-input-port port)
			      (let ((port (open-output-string)))
				 (write-circle new-obj port)
				 (close-output-port port)))))
	    (let ((port (open-output-string)))
	       (write-circle obj port)
	       (close-output-port port))))
   (test "args-parse" (test-args-parse) (bit-or 31 (bit-or 32 64)))
   (cond-expand
      (bigloo-.net
       #t)
      (else
       (test "process" (do ((i 0 (+ i 1)))
			   ((>= i 5)
			    (let loop ((proc (process-list)))
			       (if (pair? proc)
				   (begin
				      (process-wait (car proc))
				      (loop (process-list)))
				   #t)))
			   (run-process *bigloo-path* "-version"
					output: null:))
	     #t)))
   (test "make-directory.1" (begin
			       (cond
				  ((and (file-exists? "dummydir")
				        (directory? "dummydir"))
				   (delete-directory "dummydir"))
				  ((file-exists? "dummydir")
				   (delete-file "dummydir")))
			       (make-directory "dummydir"))
	 #t)
   (test "make-directory.2" (make-directory "dummydir") #f)
   (test "directory?.1" (and (file-exists? "dummydir")
			     (directory? "dummydir"))
	 #t)
   (test "directory?.2" (or (file-exists?
			     (make-file-path "dummydir" "doesnotexist"))
			    (directory?
			     (make-file-path "dummydir" "doesnotexist")))
	 #f)
   (test "make-directory.3" (make-directory (make-file-path "dummydir" "foo"))
	 #t)
   (test "delete-directory.1" (begin
				 (delete-directory "dummydir")
				 (or (file-exists? "dummydir")
				     (directory? "dummydir")))
	 #t)
   (test "delete-directory.2" (begin
				 (delete-directory
				  (make-file-path "dummydir" "foo"))
				 (delete-directory "dummydir")
				 (or (file-exists? "dummydir")
				     (directory? "dummydir")))
	 #f))


