* psyntax is not working under chaitin.

src/asm-tests.ss

@@ -90,7 +90,12 @@
     [movl (disp -4 %esp) %eax]
     [ret]))
 
-
+(asm-test 2
+  '([movl 12 (disp -8 %esp)] ;;; 12 = 001100
+    [movl 24 %eax]           ;;; 24 = 011000
+    [andl %eax (disp -8 %esp)]
+    [movl (disp -8 %esp) %eax]
+    [ret]))
 
 (asm-test 3
   '([movl 4 (disp -4 %esp)]

src/libaltcogen.ss

@@ -229,6 +229,14 @@
       [$code->closure     v]
       [$closure-code      v]
       
+      [$make-tcbucket        v]
+      [$tcbucket-key         v]
+      [$tcbucket-val         v]
+      [$tcbucket-next        v]
+      [$set-tcbucket-tconc!  e]
+      [$set-tcbucket-val!    e]
+      [$set-tcbucket-next!   e]
+      
       [$cpref            v]
       [primitive-set!    e]
       [primitive-ref     v]
@@ -731,27 +739,18 @@
       [(primcall op arg*)
        (case op
          [(nop) nop]
-         [(primitive-set!)
+         [(primitive-set! $set-symbol-value! $set-symbol-string!
-          (let ([x (Value (car arg*))] [v (Value (cadr arg*))])
+           $set-symbol-unique-string! $set-symbol-plist!)
-            (mem-assign v x 
+          (let ([off
-               (- disp-symbol-system-value symbol-tag)))]
+                 (case op
-         [($set-symbol-value!)
+                   [(primitive-set!) disp-symbol-system-value]
-          (tbind ([x (Value (car arg*))] 
+                   [($set-symbol-value!) disp-symbol-value]
-                  [v (Value (cadr arg*))])
+                   [($set-symbol-string!) disp-symbol-string]
-            (mem-assign v x 
+                   [($set-symbol-unique-string!) disp-symbol-unique-string]
-               (- disp-symbol-value symbol-tag)))]
+                   [($set-symbol-plist) disp-symbol-plist]
-         [($set-symbol-string!)
+                   [else (err x)])])
-          (tbind ([x (Value (car arg*))] [v (Value (cadr arg*))])
+            (tbind ([x (Value (car arg*))] [v (Value (cadr arg*))])
-            (mem-assign v x 
+              (mem-assign v x (- off symbol-tag))))]
-               (- disp-symbol-string symbol-tag)))] 
-         [($set-symbol-unique-string!)
-          (tbind ([x (Value (car arg*))] [v (Value (cadr arg*))])
-            (mem-assign v x 
-               (- disp-symbol-unique-string symbol-tag)))]
-         [($set-symbol-plist!)
-          (tbind ([x (Value (car arg*))] [v (Value (cadr arg*))])
-            (mem-assign v x 
-               (- disp-symbol-plist symbol-tag)))] 
          [($vector-set! $record-set!)
           (tbind ([x (Value (car arg*))] 
                   [v (Value (caddr arg*))])
@@ -829,17 +828,39 @@
                  (prm 'sll v (K (- 8 fixnum-shift)))))]
          [($unset-interrupted!) ;;; PCB INTERRUPT
           (prm 'mset pcr (K 40) (K 0))]
-         [($set-port-input-index!  $set-port-output-index!
+         [($set-port-input-index!  $set-port-output-index!)
-           $set-port-input-size!   $set-port-output-size!)
           (let ([off (case op
-                       [($set-port-input-index!)   disp-port-input-index]
+                       [($set-port-input-index!)  disp-port-input-index]
-                       [($set-port-input-size!)    disp-port-input-size]
+                       [($set-port-output-index!) disp-port-output-index]
-                       [($set-port-output-index!)  disp-port-output-index]
-                       [($set-port-output-size!)   disp-port-output-size]
                        [else (err x)])])
-            (tbind ([p (Value (car arg*))]
+            (tbind ([x (Value (car arg*))]
                     [v (Value (cadr arg*))])
-               (prm 'mset p (K (- off vector-tag)) v)))]
+               (prm 'mset x (K (- off vector-tag)) v)))]
+         [($set-port-input-size!   $set-port-output-size!)
+          (let-values ([(sz-off idx-off)
+                        (case op
+                          [($set-port-input-size!) 
+                           (values disp-port-input-size
+                                   disp-port-input-index)]
+                          [($set-port-output-size!) 
+                           (values disp-port-output-size
+                                   disp-port-output-index)]
+                          [else (err x)])])
+            (tbind ([x (Value (car arg*))]
+                    [v (Value (cadr arg*))])
+               (seq*
+                 (prm 'mset x (K (- idx-off vector-tag)) (K 0))
+                 (prm 'mset x (K (- sz-off vector-tag)) v))))]
+         [($set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc!)
+          (tbind ([x (Value (car arg*))]
+                  [v (Value (cadr arg*))])
+            (mem-assign v x
+              (- (case op
+                   [($set-tcbucket-tconc!) disp-tcbucket-tconc]
+                   [($set-tcbucket-next!)  disp-tcbucket-next]
+                   [($set-tcbucket-val!)   disp-tcbucket-val]
+                   [else (err 'tcbucket!)])
+                 vector-tag)))]
          [else (error who "invalid effect prim ~s" op)])]
       [(forcall op arg*)
        (make-forcall op (map Value arg*))]
@@ -854,12 +875,10 @@
   (define (tag-test x mask tag)
     (tbind ([x x])
       (if mask
-          (make-primcall '= 
+          (prm '= 
-            (list (make-primcall 'logand 
+             (prm 'logand x (K mask))
-                    (list x (make-constant mask)))
+             (K tag))
-                  (make-constant tag)))
+          (prm '= x (K tag)))))
-          (make-primcall '=
-             (list x (make-constant tag))))))
   (define (sec-tag-test x pmask ptag smask stag)
     (tbind ([t x])
       (make-conditional 
@@ -1418,7 +1437,7 @@
               (apply
                  (lambda (handler buf/i idx/i sz/i buf/o idx/o sz/o)
                    (tbind ([p (prm 'alloc 
-                                (K (align port-size)) 
+                                (K (align port-size))
                                 (K vector-tag))])
                      (seq*
                        (prm 'mset p 
@@ -1490,6 +1509,37 @@
                              (K (- disp-code-data vector-tag))))
                    (K 255))
               (K fixnum-shift)))]
+         [($make-tcbucket)
+          (tbind ([tconc (Value (car arg*))]
+                  [key (Value (cadr arg*))]
+                  [val (Value (caddr arg*))]
+                  [next (Value (cadddr arg*))])
+            (tbind ([x (prm 'alloc
+                            (K (align tcbucket-size))
+                            (K vector-tag))])
+              (seq*
+                (prm 'mset x 
+                     (K (- disp-tcbucket-tconc vector-tag))
+                     tconc)
+                (prm 'mset x 
+                     (K (- disp-tcbucket-key vector-tag))
+                     key)
+                (prm 'mset x 
+                     (K (- disp-tcbucket-val vector-tag))
+                     val)
+                (prm 'mset x 
+                     (K (- disp-tcbucket-next vector-tag))
+                     next)
+                x)))]
+         [($tcbucket-key)
+          (tbind ([x (Value (car arg*))])
+            (prm 'mref x (K (- disp-tcbucket-key vector-tag))))]
+         [($tcbucket-val)
+          (tbind ([x (Value (car arg*))])
+            (prm 'mref x (K (- disp-tcbucket-val vector-tag))))]
+         [($tcbucket-next)
+          (tbind ([x (Value (car arg*))])
+            (prm 'mref x (K (- disp-tcbucket-next vector-tag))))]
          [else (error who "value prim ~a not supported" (unparse x))])]
       [(forcall op arg*)
        (make-forcall op (map Value arg*))]

src/libchezio.ss

@@ -90,6 +90,7 @@
          ($make-port/both handler
                     input-buffer 0 ($string-length input-buffer)
                     output-buffer 0 ($string-length output-buffer))))
+    ;;;
     (primitive-set! 'make-input/output-port
       (lambda (handler input-buffer output-buffer)
         (if (procedure? handler)

src/libintelasm.ss

@@ -586,6 +586,8 @@
        (CODE #x81 (ModRM 3 '/4 dst (IMM32 src ac)))]
       [(and (reg? src) (reg? dst))
        (CODE #x21 (ModRM 3 src dst ac))]
+      [(and (reg? src) (mem? dst))
+       ((CODE/digit #x21 src) dst ac)]
       [(and (mem? src) (reg? dst))
        (CODErd #x23 dst src ac)]
       [else (error who "invalid ~s" instr)])]

src/psyntax-7.1.ss

@@ -613,6 +613,8 @@
   (lambda (symbol)
     (getprop symbol '*sc-expander*)))
 
+
+
 (define put-global-definition-hook
   (lambda (symbol x)
     (if (not x)
@@ -777,9 +779,6 @@
 (define-syntax build-foreign-call
   (syntax-rules ()
     [(_ ae name arg*) `(foreign-call ,name . ,arg*)]))
-;;;X (define-syntax build-$apply
-;;;X   (syntax-rules ()
-;;;X     [(_ ae proc arg*) `($apply ,proc . ,arg*)]))
 
 (define-syntax build-data
   (syntax-rules ()
@@ -801,7 +800,6 @@
         body-exp
         `(letrec ,(map list vars val-exps) ,body-exp))))
 
-
 (define build-body
   (lambda (ae vars val-exps body-exp)
     (build-letrec ae vars val-exps body-exp)))
@@ -1734,7 +1732,8 @@
       (let dobody ((body body))
         (if (null? body)
             '()
-            (let ((first (chi-top (car body) r w ctem rtem meta? ribcage meta-residualize! #f)))
+            (let ((first (chi-top (car body) r w ctem rtem meta? ribcage
+                            meta-residualize! #f)))
               (cons first (dobody (cdr body)))))))))
 
 (define chi-top