guile/guile-lightning test.scm

[Marius Vollmer]

CVSROOT:        /cvs
Module name:    guile
Changes by:     Marius Vollmer <address@hidden> 01/04/01 09:12:23

Modified files:
        guile-lightning: test.scm 

Log message:
        * test.scm: Started new generation of tests, using the new calling
        convention.
        * test-old.scm: Renamed from test.scm.

CVSWeb URLs:
http://subversions.gnu.org/cgi-bin/cvsweb/guile/guile-lightning/test.scm.diff?r1=1.4&r2=1.5

Patches:
Index: guile/guile-lightning/test.scm
diff -u guile/guile-lightning/test.scm:1.4 guile/guile-lightning/test.scm:1.5
--- guile/guile-lightning/test.scm:1.4  Sat Mar 24 20:32:17 2001
+++ guile/guile-lightning/test.scm      Sun Apr  1 09:12:23 2001
@@ -1,123 +1,22 @@
 (use-modules (ice-9 time))
 (use-modules (lightning))
 
-(dynamic-call "init_fib" (dynamic-link "./x.so"))
-
-(define (fib n)
-  (if (< n 2)
-      1
-      (+ (fib (- n 1)) (fib (- n 2)))))
-
-(define-asm-macro (arg-prolog . args)
-  (let ((n (length args)))
-    (cons `(prolog ,n)
-         (map (lambda (name) `(arg ,name))
-              args))))
-
-(define-asm-macro (scm-blt-constfix label a fix tmp1)
-  (let ((l0 (gensym "ll"))
-       (l1 (gensym "ll")))
-    `(  (bmc ,l0 ,a (scm 0))
-        (blt ,label ,a ,fix)
-        (b ,l1)
-      ,l0
-        (prepare 2)
-       (mov ,tmp1 ,fix)
-       (pusharg ,tmp1)
-       (pusharg ,a)
-       (finish (subr "scm_less_p"))
-       (retval ,tmp1)
-       (bne ,label ,tmp1 (scm #f))
-      ,l1)))
-
-(define-asm-macro (scm-add-constfix res a fix)
-  (let ((l0 (gensym "ll"))
-       (l1 (gensym "ll"))
-       (fix-sans-tag (logand #xffffffff (* 4 (cadr fix))))) ;; XXX
-  `(  (bmc ,l0 ,a (scm 0))
-      (mov ,res ,a)
-      (boadd ,l0 ,res ,fix-sans-tag)
-      (b ,l1)
-    ,l0
-      (prepare 2)
-      (mov ,res ,fix)
-      (pusharg ,res)
-      (pusharg ,a)
-      (finish (subr "scm_sum"))
-      (retval ,res)
-    ,l1)))
-
-(define-asm-macro (scm-add res a b)
-  (let ((l0 (gensym "ll"))
-       (l1 (gensym "ll")))
-    `(  (bmc ,l0 ,a (scm 0))
-       (bmc ,l0 ,b (scm 0))
-       (sub ,res ,a (scm 0))
-       (boadd ,l0 ,res ,b)
-       (b ,l1)
-      ,l0
-        (prepare 2)
-       (pusharg ,b)
-       (pusharg ,a)
-       (finish (subr "scm_sum"))
-       (retval ,res)
-      ,l1)))
-
-(define asm-fib (assemble `(fib
-                             (arg-prolog n)
-                             (getarg v0 n)
-                             (scm-blt-constfix l0 v0 (scm 2) r0)
-                             (scm-add-constfix r0 v0 (scm -2))
-                             (prepare 1)
-                             (pusharg r0)
-                             (finish (label fib))
-                             (retval v2)
-                             (scm-add-constfix r0 v0 (scm -1))
-                             (prepare 1)
-                             (pusharg r0)
-                             (finish (label fib))
-                             (retval v1)
-                             (scm-add ret v1 v2)
-                             (b l1)
-                           l0
-                             (mov ret (scm 1))
-                           l1
-                             (ret))))
-
-(define asm-fixfib (assemble `(fib
-                                (prolog 1)
-                                (arg n)
-                                (getarg v0 n)
-                                (bge l0 v0 (scm 2))
-                                (mov ret (scm 1))
-                                (ret)
-                              l0
-                                (sub r0 v0 (scm 2))
-                                (add r0 r0 (scm 0))
-                                (prepare 1)
-                                (pusharg r0)
-                                (finish (label fib))
-                                (retval v2)
-                                (sub r0 v0 (scm 1))
-                                (add r0 r0 (scm 0))
-                                (prepare 1)
-                                (pusharg r0)
-                                (finish (label fib))
-                                (retval v1)
-                                (sub ret v2 (scm 0))
-                                (add ret ret v1)
-                                (ret))))
-
-(define asm-inc (assemble `(  (prolog 1)
-                             (arg n)
-                             (getarg r1 n)
-                             (scm-add-constfix ret r1 (scm 1))
-                             (ret))))
-
-(define asm-dec (assemble `(  (prolog 1)
-                             (arg n)
-                             (getarg r1 n)
-                             (scm-add-constfix ret r1 (scm -1))
-                             (ret))))
-
-;(disassemble asm-fib)
+(define numargs (make-closure
+                (assemble '(  (pop r2)
+                              (add sp sp r1)
+                              (add ret r1 (scm 0))
+                              (mov r1 4)
+                              (jmp r2)))
+                #f))
+
+(define lvalues (make-closure
+                (assemble '(  (pop r2)
+                              (beq l0 r1 0)
+                              (ld r0 sp)
+                              (b l1)
+                            l0
+                               (mov r0 (scm ,(if #f #f)))
+                             l1
+                              (add sp sp r1)
+                              (jmp r2)))
+                #f))