guile/guile-lightning test.scm

[Marius Vollmer]

CVSROOT:        /cvs
Module name:    guile
Changes by:     Marius Vollmer <address@hidden> 01/03/19 18:01:25

Modified files:
        guile-lightning: test.scm 

Log message:
        More stuff to play with.

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

Patches:
Index: guile/guile-lightning/test.scm
diff -u guile/guile-lightning/test.scm:1.1 guile/guile-lightning/test.scm:1.2
--- guile/guile-lightning/test.scm:1.1  Mon Mar 19 15:52:01 2001
+++ guile/guile-lightning/test.scm      Mon Mar 19 18:01:25 2001
@@ -1,12 +1,63 @@
 (load "lightning.scm")
 (use-modules (lightning))
 
-(define c (assemble '((leaf 1)
-                     (arg n)
-                     (getarg r0 n)
-                     (add ret r0 4)
-                     (ret))))
+(define (fak n)
+  (do ((n n (1- n))
+       (r 1 (* r 2)))
+      ((zero? n) r)))
 
-(disassemble c)
+(define (fak1 n)
+  (define (fak-aux n r)
+    (if (zero? n) r (fak-aux (1- n) (* r 1))))
+  (fak-aux n 1))
 
-(format #t "~A\n" (c 2))
+(define asmfak (assemble
+               '(  (prolog 1)
+                   (arg n)
+                   (getarg v2 n)
+                   (mov v1 (scm 1))
+                 loop
+;                  (beq return v2 (scm 0))
+                   (prepare 1)
+                   (pusharg v2)
+                   (finish (subr "zero_p"))
+                   (retval v0)
+                   (bne return v0 (scm #f))
+                   (prepare 2)
+                   (pusharg v1)
+                   (pusharg v2)
+                   (finish (subr "product"))
+                   (retval v1)
+                   (prepare 2)
+                   (mov v0 (scm 1))
+                   (pusharg v0)
+                   (pusharg v2)
+                   (finish (subr "difference"))
+                   (retval v2)
+                   (b loop)
+                 return
+                   (mov ret v1)
+                   (ret))))
+
+(define fixfak (assemble
+               '(  (prolog 1)
+                   (arg n)
+                   (getarg v2 n)
+                   (mov v1 (scm 1))
+                 loop
+                   (beq return v2 (scm 0))
+                   (rsh r0 v1 2)
+                   (sub r1 v2 (scm 0))
+                   (mul r0 r0 r1)
+                   (add v1 r0 (scm 0))
+                   (sub v2 v2 (scm 1))
+                   (add v2 v2 (scm 0))
+                   (b loop) ; hack
+                 return
+                   (mov ret v1)
+                   (ret))))
+
+(disassemble fixfak)
+
+(format #t "~A\n" (asmfak 50))
+