From: Taylor R Campbell <campbell@mumble.net>
Date: Tue, 15 Jan 2019 03:14:40 +0000 (+0000)
Subject: Umptuple-check that instruction widths sum to multiples of 32 bits.
X-Git-Tag: mit-scheme-pucked-10.1.20~11^2~66^2~87
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e876fa07be0ae68dc862490bbeb43bdc33a430d8;p=mit-scheme.git

Umptuple-check that instruction widths sum to multiples of 32 bits.
---

diff --git a/src/compiler/machines/aarch64/insmac.scm b/src/compiler/machines/aarch64/insmac.scm
index cfb7d4120..f2d6ad05f 100644
--- a/src/compiler/machines/aarch64/insmac.scm
+++ b/src/compiler/machines/aarch64/insmac.scm
@@ -31,16 +31,18 @@ USA.
 (define (parse-instruction form forms early? environment)
   (assert (not early?))
   (receive (expansion bits) (process* form forms environment)
-    bits
+    (assert (or (not bits) (zero? (remainder bits 32))) bits (cons form forms))
     expansion))
 
 (define (process* form forms environment)
   (let recur ((form form) (forms forms))
     (receive (expansion bits) (process form environment)
+      (assert (or (not bits) (zero? (remainder bits 32)) bits form))
       (if (pair? forms)
           (receive (tail bits*) (recur (car forms) (cdr forms))
+            (assert (or (not bits*) (zero? (remainder bits* 32))) bits* forms)
             (values `(,(close-syntax 'APPEND environment) ,expansion ,tail)
-                    (+ bits bits*)))
+                    (and bits bits* (+ bits bits*))))
           (values expansion bits)))))
 
 (define (process form environment)
@@ -58,13 +60,16 @@ USA.
         (consequent (caddr form))
         (alternative (cadddr form)))
     (receive (con-exp con-bits) (process consequent environment)
+      (assert con-bits consequent)
+      (assert (zero? (remainder con-bits 32)) con-bits consequent)
       (receive (alt-exp alt-bits) (process alternative environment)
-        (assert (eqv? con-bits alt-bits))
+        (assert (eqv? con-bits alt-bits) con-bits alt-bits alternative)
         (values `(,(close-syntax 'IF environment) ,condition ,con-exp ,alt-exp)
                 con-bits)))))
 
 (define (process-fixed form environment)
   (receive (expansion bits) (expand-fields (cdr form) environment)
+    (assert (zero? (remainder bits 32)) bits form)
     (values `(,(close-syntax 'LIST environment)
               ,(optimize-group-syntax expansion #f environment))
             bits)))
@@ -88,7 +93,7 @@ USA.
           (hi (cadr range)))
       (receive (expansion bits) (process* (car forms) (cdr forms) environment)
         (assert bits "Variable within variable prohibited!")
-        (assert (zero? (remainder bits 32)) "Wrong number of bits!")
+        (assert (zero? (remainder bits 32)) bits forms)
         `(,expansion ,bits ,lo ,hi)))))
 
 (define (process-macro form environment)
@@ -101,12 +106,14 @@ USA.
          ,expansion)))
      width)))
 
-(define (expand-fields fields environment)
-  (let loop ((fields fields) (elements '()) (bits 0))
+(define (expand-fields all-fields environment)
+  (let loop ((fields all-fields) (elements '()) (bits 0))
     (if (pair? fields)
         (receive (element1 bits1) (expand-field (car fields) environment)
           (loop (cdr fields) (cons element1 elements) (+ bits1 bits)))
-        (values (reverse! elements) bits))))
+        (begin
+          (assert (zero? (remainder bits 32)) bits all-fields)
+          (values elements bits)))))
 
 (define (expand-field field environment)
   (let ((bits (car field))