* added a few missing instruction sequences where the dest is a

memory location.
* implemented integer sets (based on tree representation).

src/asm-tests.ss

@@ -1,6 +1,9 @@
 #!/usr/bin/env ikarus --script 
+
+(define counter 0)
 (define (asm-test res ls)
-  (printf "Testing:\n")
+  (set! counter (add1 counter))
+  (printf "[~s] Testing:\n" counter)
   (for-each (lambda (x)
               (printf "    ~s\n" x))
             ls)
@@ -103,6 +106,22 @@
     [movl (disp -4 %esp) %eax]
     [ret]))
 
+
+(asm-test 3
+  '([movl 4 (disp -4 %esp)]
+    [movl 8 %eax]
+    [orl %eax (disp -4 %esp)]
+    [movl (disp -4 %esp) %eax]
+    [ret]))
+
+(asm-test 3
+  '([movl 4 (disp -4 %esp)]
+    [movl 8 %ebx]
+    [orl %ebx (disp -4 %esp)]
+    [movl (disp -4 %esp) %eax]
+    [ret]))
+
+
 (asm-test 3
   '([movl -1 (disp -4 %esp)]
     [andl 12 (disp -4 %esp)]
@@ -146,5 +165,27 @@
     [call (disp 26 (obj car))]
     [ret]))
 
+(asm-test 8
+  '([movl (obj 1) (disp -8 %esp)]
+    [movl 3 %ecx]
+    [sall %cl (disp -8 %esp)]
+    [movl (disp -8 %esp) %eax]
+    [ret]))
+
+(asm-test 1
+  '([movl (obj 8) (disp -8 %esp)]
+    [movl 3 %ecx]
+    [sarl %cl (disp -8 %esp)]
+    [movl (disp -8 %esp) %eax]
+    [ret]))
+
+(asm-test 1
+  '([movl (obj 8) (disp -8 %esp)]
+    [movl 3 %ecx]
+    [shrl %cl (disp -8 %esp)]
+    [movl (disp -8 %esp) %eax]
+    [ret]))
+
+
 (printf "Happy Happy Joy Joy\n")
 (exit)

src/libaltcogen.ss

@@ -887,8 +887,6 @@
 ;  (print-code x)
   (Program x))
 
-
-
 (module ListySet 
   (make-empty-set set-member? set-add set-rem set-difference set-union
    empty-set?
@@ -949,13 +947,219 @@
       [(memq (car s1) s2) (union (cdr s1) s2)]
       [else (cons (car s1) (union (cdr s1) s2))])))
 
-;(module IntegerSet
+(module IntegerSet
-;  (make-empty-set set-member? set-add set-rem set-difference
+  (make-empty-set set-member? set-add set-rem set-difference
-;   set-union empty-set? set->list list->set)
+   set-union empty-set? set->list list->set set-map set-for-each
-;
+   set-ormap set-andmap)
-;  )
+  
+  (begin
+    (define-syntax car      (identifier-syntax #%$car))
+    (define-syntax cdr      (identifier-syntax #%$cdr))
+    (define-syntax fxsll    (identifier-syntax #%$fxsll))
+    (define-syntax fxsra    (identifier-syntax #%$fxsra))
+    (define-syntax fxlogor  (identifier-syntax #%$fxlogor))
+    (define-syntax fxlogand (identifier-syntax #%$fxlogand))
+    (define-syntax fxlognot (identifier-syntax #%$fxlognot))
+    (define-syntax fx+      (identifier-syntax #%$fx+))
+    (define-syntax fxzero?  (identifier-syntax #%$fxzero?))
+    (define-syntax fxeven?
+      (syntax-rules ()
+        [(_ x) (#%$fxzero? (#%$fxlogand x 1))])))
 
-(module IntegerSet 
+  (define shift      4)
+  (define mask     #xF)
+  (define (index-of n) (fxsra n shift))
+  (define (mask-of n)  (fxsll 1 (fxlogand n mask)))
+
+  (define (make-empty-set) 0)
+  (define (empty-set? s) (eqv? s 0))
+  
+  (define (set-member? n s) 
+    (let f ([s s] [i (index-of n)] [j (mask-of n)])
+      (cond
+        [(pair? s)
+         (if (fxeven? i)
+             (f (car s) (fxsra i 1) j)
+             (f (cdr s) (fxsra i 1) j))]
+        [(eq? i 0) (eq? j (fxlogand s j))]
+        [else #f])))
+
+  (define (set-add n s)
+    (let f ([s s] [i (index-of n)] [j (mask-of n)])
+      (cond
+        [(pair? s)
+         (if (fxeven? i)
+             (let ([a0 (car s)])
+               (let ([a1 (f a0 (fxsra i 1) j)])
+                 (if (eq? a0 a1) s (cons a1 (cdr s)))))
+             (let ([d0 (cdr s)])
+               (let ([d1 (f d0 (fxsra i 1) j)])
+                 (if (eq? d0 d1) s (cons (car s) d1)))))]
+        [(eq? i 0) (fxlogor s j)]
+        [else
+         (if (fxeven? i) 
+             (cons (f s (fxsra i 1) j) 0)
+             (cons s (f 0 (fxsra i 1) j)))])))
+
+  (define (cons^ a d)
+    (if (and (eq? d 0) (fixnum? a))
+        a
+        (cons a d)))
+
+  (define (set-rem n s)
+    (let f ([s s] [i (index-of n)] [j (mask-of n)])
+      (cond
+        [(pair? s)
+         (if (fxeven? i)
+             (let ([a0 (car s)])
+               (let ([a1 (f a0 (fxsra i 1) j)])
+                 (if (eq? a0 a1) s (cons^ a1 (cdr s)))))
+             (let ([d0 (cdr s)])
+               (let ([d1 (f d0 (fxsra i 1) j)])
+                 (if (eq? d0 d1) s (cons^ (car s) d1)))))]
+        [(eq? i 0) (fxlogand s (fxlognot j))]
+        [else s])))
+ 
+  (define (set-union^ s1 m2)
+    (if (pair? s1)
+        (let ([a0 (car s1)])
+          (let ([a1 (set-union^ a0 m2)])
+            (if (eq? a0 a1) s1 (cons a1 (cdr s1)))))
+        (fxlogor s1 m2)))
+
+  (define (set-union s1 s2)
+    (if (pair? s1)
+        (if (pair? s2)
+            (if (eq? s1 s2)
+                s1
+                (cons (set-union (car s1) (car s2))
+                      (set-union (cdr s1) (cdr s2))))
+            (let ([a0 (car s1)])
+              (let ([a1 (set-union^ a0 s2)])
+                (if (eq? a0 a1) s1 (cons a1 (cdr s1))))))
+        (if (pair? s2)
+            (let ([a0 (car s2)])
+              (let ([a1 (set-union^ a0 s1)])
+                (if (eq? a0 a1) s2 (cons a1 (cdr s2)))))
+            (fxlogor s1 s2))))
+
+  (define (set-difference^ s1 m2)
+    (if (pair? s1)
+        (let ([a0 (car s1)])
+          (let ([a1 (set-difference^ a0 m2)])
+            (if (eq? a0 a1) s1 (cons^ a1 (cdr s1)))))
+        (fxlogand s1 (fxlognot m2))))
+  
+  (define (set-difference^^ m1 s2)
+    (if (pair? s2)
+        (set-difference^^ m1 (car s2))
+        (fxlogand m1 (fxlognot s2))))
+
+  (define (set-difference s1 s2)
+    (if (pair? s1)
+        (if (pair? s2)
+            (if (eq? s1 s2)
+                0
+                (cons^ (set-difference (car s1) (car s2))
+                       (set-difference (cdr s1) (cdr s2))))
+            (let ([a0 (car s1)])
+              (let ([a1 (set-difference^ a0 s2)])
+                (if (eq? a0 a1) s1 (cons^ a1 (cdr s1))))))
+        (if (pair? s2) 
+            (set-difference^^ s1 (car s2)) 
+            (fxlogand s1 (fxlognot s2)))))
+
+  (define (list->set ls)
+    (let f ([ls ls] [s 0])
+      (cond
+        [(null? ls) s]
+        [else (f (cdr ls) (set-add (car ls) s))])))
+
+  (define (set->list s)
+    (let f ([i 0] [j (fxsll 1 shift)] [s s] [ac '()])
+      (cond
+        [(pair? s)
+         (f i (fxsll j 1) (car s)
+            (f (fxlogor i j) (fxsll j 1) (cdr s) ac))]
+        [else
+         (let f ([i i] [m s] [ac ac])
+           (cond
+             [(fxeven? m) 
+              (if (fxzero? m) 
+                  ac
+                  (f (fx+ i 1) (fxsra m 1) ac))]
+             [else 
+              (f (fx+ i 1) (fxsra m 1) (cons i ac))]))])))
+
+
+  (define (set-map proc s)
+    (let f ([i 0] [j (fxsll 1 shift)] [s s] [ac '()])
+      (cond
+        [(pair? s)
+         (f i (fxsll j 1) (car s)
+            (f (fxlogor i j) (fxsll j 1) (cdr s) ac))]
+        [else
+         (let f ([i i] [m s] [ac ac])
+           (cond
+             [(fxeven? m) 
+              (if (fxzero? m) 
+                  ac
+                  (f (fx+ i 1) (fxsra m 1) ac))]
+             [else 
+              (f (fx+ i 1) (fxsra m 1) (cons (proc i) ac))]))])))
+
+  (define (set-for-each proc s)
+    (let f ([i 0] [j (fxsll 1 shift)] [s s])
+      (cond
+        [(pair? s)
+         (f i (fxsll j 1) (car s))
+         (f (fxlogor i j) (fxsll j 1) (cdr s))]
+        [else
+         (let f ([i i] [m s])
+           (cond
+             [(fxeven? m) 
+              (unless (fxzero? m) 
+                (f (fx+ i 1) (fxsra m 1)))]
+             [else 
+              (proc i)
+              (f (fx+ i 1) (fxsra m 1))]))])))
+
+  (define (set-ormap proc s)
+    (let f ([i 0] [j (fxsll 1 shift)] [s s])
+      (cond
+        [(pair? s)
+         (or (f i (fxsll j 1) (car s))
+             (f (fxlogor i j) (fxsll j 1) (cdr s)))]
+        [else
+         (let f ([i i] [m s])
+           (cond
+             [(fxeven? m) 
+              (if (fxzero? m) 
+                  #f
+                  (f (fx+ i 1) (fxsra m 1)))]
+             [else 
+              (or (proc i)
+                  (f (fx+ i 1) (fxsra m 1)))]))])))
+
+  (define (set-andmap proc s)
+    (let f ([i 0] [j (fxsll 1 shift)] [s s])
+      (cond
+        [(pair? s)
+         (and (f i (fxsll j 1) (car s))
+              (f (fxlogor i j) (fxsll j 1) (cdr s)))]
+        [else
+         (let f ([i i] [m s])
+           (cond
+             [(fxeven? m) 
+              (if (fxzero? m) 
+                  #t
+                  (f (fx+ i 1) (fxsra m 1)))]
+             [else 
+              (and (proc i)
+                   (f (fx+ i 1) (fxsra m 1)))]))])))
+#|IntegerSet|#)
+
+(module IntegerSet-list
   (make-empty-set set-member? set-add set-rem set-difference set-union
    empty-set?
    set->list list->set)
@@ -1020,6 +1224,106 @@
       [(memq (car s1) s2) (union (cdr s1) s2)]
       [else (cons (car s1) (union (cdr s1) s2))])))
 
+;;;(module IntegerSet
+;;;  (make-empty-set set-member? set-add set-rem set-difference set-union
+;;;   empty-set? set->list list->set)
+;;;
+;;;  (define-syntax L
+;;;    (lambda (x)
+;;;      (syntax-case x ()
+;;;        [(L expr)
+;;;         (with-syntax ([w 
+;;;                        (datum->syntax-object #'L
+;;;                          '(import IntegerSet-list))])
+;;;           #'(let () w expr))])))
+;;;
+;;;  (define-syntax T
+;;;    (lambda (x)
+;;;      (syntax-case x ()
+;;;        [(L expr)
+;;;         (with-syntax ([w 
+;;;                        (datum->syntax-object #'L
+;;;                          '(import IntegerSet-tree))])
+;;;           #'(let () w expr))])))
+;;;
+;;;  (define-record set (ls tr))
+;;;
+;;;  (define (make-empty-set)
+;;;    (make-set (L (make-empty-set))
+;;;              (T (make-empty-set))))
+;;;
+;;;  (define (set-member? x s)
+;;;    (if (L (set-member? x (set-ls s)))
+;;;        (if (T (set-member? x (set-tr s)))
+;;;            #t
+;;;            (error "mismatch member ~s in ~s" x s))
+;;;        (if (T (set-member? x (set-tr s)))
+;;;            (error "mismatch member ~s in ~s" x s)
+;;;            #f)))
+;;;
+;;;  (define (set-add x s)
+;;;    (verify-set 'set-add 
+;;;       (make-set (L (set-add x (set-ls s))) 
+;;;         (T (set-add x (set-tr s))))))
+;;;
+;;;  (define (set-rem x s)
+;;;    (verify-set 'set-rem 
+;;;      (make-set (L (set-rem x (set-ls s)))
+;;;                (T (set-rem x (set-tr s))))))
+;;;
+;;;  (define (set-difference s1 s2)
+;;;    (verify-set 'set-difference
+;;;      (make-set (L (set-difference (set-ls s1) (set-ls s2)))
+;;;        (T (set-difference (set-tr s1) (set-tr s2))))))
+;;;
+;;;
+;;;  (define (set-union s1 s2)
+;;;    (verify-set 'set-union
+;;;      (make-set (L (set-union (set-ls s1) (set-ls s2)))
+;;;        (T (set-union (set-tr s1) (set-tr s2))))))
+;;;
+;;;  (define (empty-set? s)
+;;;    (if (L (empty-set? (set-ls s)))
+;;;        (if (T (empty-set? (set-tr s)))
+;;;            #t
+;;;            (error "mismatch empty-set in ~s" s))
+;;;        (if (T (empty-set? (set-tr s)))
+;;;            (error "mismatch empty-set in ~s" s)
+;;;            #f)))
+;;;
+;;;  (define (verify-set who s)
+;;;    (let ([ls1 (L (set->list (set-ls s)))]
+;;;          [ls2 (T (set->list (set-tr s)))])
+;;;      (for-each (lambda (i) 
+;;;                  (unless (memq i ls2)
+;;;                    (error who "mismatch ~s ~s ~s" s ls1 ls2)))
+;;;                ls1)
+;;;      (for-each (lambda (i) 
+;;;                  (unless (memq i ls1)
+;;;                    (error who "mismatch ~s ~s ~s" s ls2 ls2)))
+;;;                ls2))
+;;;    s)
+;;;
+;;;  (define (set->list s)
+;;;    (let ([ls1 (L (set->list (set-ls s)))]
+;;;          [ls2 (T (set->list (set-tr s)))])
+;;;      (for-each (lambda (i) 
+;;;                  (unless (memq i ls2)
+;;;                    (error 'set->list "mismatch ~s" s)))
+;;;                ls1)
+;;;      (for-each (lambda (i) 
+;;;                  (unless (memq i ls1)
+;;;                    (error 'set->list "mismatch ~s" s)))
+;;;                ls2)
+;;;      ls1))
+;;;
+;;;  (define (list->set ls)
+;;;    (verify-set 'list->set 
+;;;      (make-set (L (list->set ls)) 
+;;;        (T (list->set ls)))))
+;;;
+;;;  )
+
 (module ListyGraphs 
   (empty-graph add-edge! empty-graph? print-graph node-neighbors
    delete-node!)

src/libintelasm.ss

@@ -124,9 +124,6 @@
            (error 'with-args "too few args")))]))
 
 
-;(define byte
-;  (lambda (x)
-;    (cons 'byte (fxlogand x 255))))
 
 (define-syntax byte
   (syntax-rules ()
@@ -532,6 +529,8 @@
        ((CODE/digit #xC1 '/4) dst (IMM8 src ac))]
       [(and (eq? src '%cl) (reg? dst))
        (CODE #xD3 (ModRM 3 '/4 dst ac))]
+      [(and (eq? src '%cl) (mem? dst))
+       ((CODE/digit #xD3 '/4) dst ac)]
       [else (error who "invalid ~s" instr)])]
    [(shrl src dst)
     (cond
@@ -543,6 +542,8 @@
        (CODE #xD3 (ModRM 3 '/5 dst ac))]
       [(and (imm8? src) (mem? dst))
        ((CODE/digit #xC1 '/5) dst (IMM8 src ac))]
+      [(and (eq? src '%cl) (mem? dst))
+       ((CODE/digit #xD3 '/5) dst ac)]
       [else (error who "invalid ~s" instr)])]
    [(sarl src dst)
     (cond
@@ -554,6 +555,8 @@
        ((CODE/digit #xC1 '/7) dst (IMM8 src ac))] 
       [(and (eq? src '%cl) (reg? dst))
        (CODE #xD3 (ModRM 3 '/7 dst ac))]
+      [(and (eq? src '%cl) (mem? dst))
+       ((CODE/digit #xD3 '/7) dst ac)]
       [else (error who "invalid ~s" instr)])]
    [(andl src dst) 
     (cond
@@ -576,6 +579,8 @@
     (cond
       [(and (imm? src) (mem? dst))
        ((CODE/digit #x81 '/1) dst (IMM32 src ac))]
+      [(and (reg? src) (mem? dst))
+       ((CODE/digit #x09 src) dst ac)]
       [(and (imm8? src) (reg? dst)) 
        (CODE #x83 (ModRM 3 '/1 dst (IMM8 src ac)))]
       [(and (imm? src) (eq? dst '%eax))