mescc: Tinycc support: Support bit-fields.
[mes.git] / module / language / c99 / compiler.mes
index d5b94737271f7985511175c75573b57114f1c06c..0cbc52d2990db2de9a5028898496e696ae803c34 100644 (file)
       (,t (guard (type? t)) t)
       (,p (guard (pointer? p)) p)
       (,a (guard (c-array? a)) a)
+      (,b (guard (bit-field? b)) b)
 
       ((char ,value) (get-type "char" info))
       ((enum-ref . _) (get-type "int" info))
             (cond ((equal? (car f) field) f)
                   ((and (memq (car f) '(struct union)) (type? (cdr f))
                         (find (lambda (x) (equal? (car x) field)) (struct->fields (cdr f)))))
+                  ((eq? (car f) 'bits) (assoc field (cdr f)))
                   (else (loop (cdr fields)))))))))
 
 (define (field-offset info struct field)
                             (let ((fields (struct->fields (cdr f))))
                               (and (find (lambda (x) (equal? (car x) field)) fields)
                                    offset))))
+                      ((and (eq? (car f) 'bits) (assoc-ref (cdr f) field)) offset)
                       (else (loop (cdr fields) (+ offset (field:size f)))))))))))
 
 (define (field-pointer info struct field)
     (_ (guard (and (type? o) (eq? (type:type o) 'union)))
        (append-map struct->fields (type:description o)))
     ((struct . ,type) (list (car (type:description type))))
-    ((struct . ,type) (list (car (type:description type))))
+    ((union . ,type) (list (car (type:description type))))
+    ((bits . ,bits) bits)
     (_ (list o))))
 
 (define (struct->init-fields o)
                   (info (expr->accu* a info)))
              (append-text info (wrap-as (i386:accu+base)))))))
 
-      ((sub ,a ,b)
-       (let* ((rank (expr->rank info a))
-              (rank-b (expr->rank info b))
-              (type (ast->basic-type a info))
-              (struct? (structured-type? type))
-              (size (->size type))
-              (size  (cond ((= rank 1) size)
-                           ((> rank 1) 4)
-                           ((and struct? (= rank 2)) 4)
-                           (else 1))))
-         (if (or (= size 1) (or (= rank-b 2) (= rank-b 1)))
-             (let ((info ((binop->accu* info) a b (i386:accu-base))))
-               (if (and (not (= rank-b 2)) (not (= rank-b 1))) info
-                   (append-text info (wrap-as (append (i386:value->base size)
-                                                      (i386:accu/base))))))
-             (let* ((info (expr->accu* b info))
-                    (info (append-text info (wrap-as (append (i386:value->base size)
-                                                             (i386:accu*base)
-                                                             (i386:accu->base)))))
-                    (info (expr->accu* a info)))
-               (append-text info (wrap-as (i386:accu-base)))))))
-
-      ((pre-dec ,expr)
-         (let* ((rank (expr->rank info expr))
-                (size (cond ((= rank 1) (ast-type->size info expr))
-                            ((> rank 1) 4)
-                            (else 1)))
-                (info ((expr-add info) expr (- size)))
-                (info (append (expr->accu* expr info))))
-           info))
-
-      ((pre-inc ,expr)
-         (let* ((rank (expr->rank info expr))
-                (size (cond ((= rank 1) (ast-type->size info expr))
-                            ((> rank 1) 4)
-                            (else 1)))
-                (info ((expr-add info) expr size))
-                (info (append (expr->accu* expr info))))
-           info))
+    ((sub ,a ,b)
+     (let* ((rank (expr->rank info a))
+            (rank-b (expr->rank info b))
+            (type (ast->basic-type a info))
+            (struct? (structured-type? type))
+            (size (->size type))
+            (size  (cond ((= rank 1) size)
+                         ((> rank 1) 4)
+                         ((and struct? (= rank 2)) 4)
+                         (else 1))))
+       (if (or (= size 1) (or (= rank-b 2) (= rank-b 1)))
+           (let ((info ((binop->accu* info) a b (i386:accu-base))))
+             (if (and (not (= rank-b 2)) (not (= rank-b 1))) info
+                 (append-text info (wrap-as (append (i386:value->base size)
+                                                    (i386:accu/base))))))
+           (let* ((info (expr->accu* b info))
+                  (info (append-text info (wrap-as (append (i386:value->base size)
+                                                           (i386:accu*base)
+                                                           (i386:accu->base)))))
+                  (info (expr->accu* a info)))
+             (append-text info (wrap-as (i386:accu-base)))))))
 
-      ((post-dec ,expr)
-       (let* ((info (expr->accu* expr info))
-              (info (append-text info (wrap-as (i386:push-accu))))
-              (post (clone info #:text '()))
-              (post (append-text post (ast->comment o)))
-              (post (append-text post (wrap-as (i386:pop-base))))
-              (post (append-text post (wrap-as (i386:push-accu))))
-              (post (append-text post (wrap-as (i386:base->accu))))
-              (rank (expr->rank post expr))
-              (size (cond ((= rank 1) (ast-type->size post expr))
-                          ((> rank 1) 4)
-                          (else 1)))
-              (post ((expr-add post) expr (- size)))
-              (post (append-text post (wrap-as (i386:pop-accu)))))
-         (clone info #:post (.text post))))
-
-      ((post-inc ,expr)
-       (let* ((info (expr->accu* expr info))
-              (info (append-text info (wrap-as (i386:push-accu))))
-              (post (clone info #:text '()))
-              (post (append-text post (ast->comment o)))
-              (post (append-text post (wrap-as (i386:pop-base))))
-              (post (append-text post (wrap-as (i386:push-accu))))
-              (post (append-text post (wrap-as (i386:base->accu))))
-              (rank (expr->rank post expr))
-              (size (cond ((= rank 1) (ast-type->size post expr))
-                          ((> rank 1) 4)
-                          (else 1)))
-              (post ((expr-add post) expr size))
-              (post (append-text post (wrap-as (i386:pop-accu)))))
-         (clone info #:post (.text post))))
+    ((pre-dec ,expr)
+     (let* ((rank (expr->rank info expr))
+            (size (cond ((= rank 1) (ast-type->size info expr))
+                        ((> rank 1) 4)
+                        (else 1)))
+            (info ((expr-add info) expr (- size)))
+            (info (append (expr->accu* expr info))))
+       info))
+
+    ((pre-inc ,expr)
+     (let* ((rank (expr->rank info expr))
+            (size (cond ((= rank 1) (ast-type->size info expr))
+                        ((> rank 1) 4)
+                        (else 1)))
+            (info ((expr-add info) expr size))
+            (info (append (expr->accu* expr info))))
+       info))
+
+    ((post-dec ,expr)
+     (let* ((info (expr->accu* expr info))
+            (info (append-text info (wrap-as (i386:push-accu))))
+            (post (clone info #:text '()))
+            (post (append-text post (ast->comment o)))
+            (post (append-text post (wrap-as (i386:pop-base))))
+            (post (append-text post (wrap-as (i386:push-accu))))
+            (post (append-text post (wrap-as (i386:base->accu))))
+            (rank (expr->rank post expr))
+            (size (cond ((= rank 1) (ast-type->size post expr))
+                        ((> rank 1) 4)
+                        (else 1)))
+            (post ((expr-add post) expr (- size)))
+            (post (append-text post (wrap-as (i386:pop-accu)))))
+       (clone info #:post (.text post))))
+
+    ((post-inc ,expr)
+     (let* ((info (expr->accu* expr info))
+            (info (append-text info (wrap-as (i386:push-accu))))
+            (post (clone info #:text '()))
+            (post (append-text post (ast->comment o)))
+            (post (append-text post (wrap-as (i386:pop-base))))
+            (post (append-text post (wrap-as (i386:push-accu))))
+            (post (append-text post (wrap-as (i386:base->accu))))
+            (rank (expr->rank post expr))
+            (size (cond ((= rank 1) (ast-type->size post expr))
+                        ((> rank 1) 4)
+                        (else 1)))
+            (post ((expr-add post) expr size))
+            (post (append-text post (wrap-as (i386:pop-accu)))))
+       (clone info #:post (.text post))))
 
     (_ (error "expr->accu*: not supported: " o))))
 
                       (<= size-b 4)) (append-text info ((accu->ident info) name))
                       (let ((info (expr->base* a info)))
                         (accu->base-mem*n info size))))
-             (_ (let ((info (expr->base* a info)))
+             (_ (let* ((info (expr->base* a info))
+                       (info (if (not (bit-field? type)) info
+                                 (let* ((bit (bit-field:bit type))
+                                        (bits (bit-field:bits type))
+                                        (set-mask (- (ash bits 1) 1))
+                                        (shifted-set-mask (ash set-mask bit))
+                                        (clear-mask (logxor shifted-set-mask #b11111111111111111111111111111111))
+                                        (info (append-text info (wrap-as (i386:push-base))))
+                                        (info (append-text info (wrap-as (i386:push-accu))))
+
+                                        (info (append-text info (wrap-as (i386:base-mem->accu))))
+                                        (info (append-text info (wrap-as (i386:accu-and clear-mask))))
+                                        (info (append-text info (wrap-as (i386:accu->base))))
+
+                                        (info (append-text info (wrap-as (i386:pop-accu))))
+                                        (info (append-text info (wrap-as (i386:accu-and set-mask))))
+                                        (info (append-text info (wrap-as (i386:accu-shl bit))))
+                                        (info (append-text info (wrap-as (i386:accu-or-base))))
+
+                                        (info (append-text info (wrap-as (i386:pop-base)))))
+                                   info))))
                   (accu->base-mem*n info (min size (max 4 size-b)))))))) ;; FIXME: long long = int
 
         (_ (error "expr->accu: not supported: " o))))
       ((comp-decl (decl-spec-list (type-spec (union-def (field-list . ,fields)))))
        (let ((fields (append-map (struct-field info) fields)))
          (list (cons 'union (make-type 'union (apply + (map field:size fields)) fields)))))
+      ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (bit-field (ident ,name) (p-expr (fixed ,bits)))) . ,fields))
+       (let ((type (ast->type type info)))
+         (list (cons 'bits (let loop ((o `((comp-declr (bit-field (ident ,name) (p-expr (fixed ,bits)))) . ,fields)) (bit 0))
+                             (if (null? o) '()
+                                 (let ((field (car o)))
+                                   (pmatch field
+                                     ((comp-declr (bit-field (ident ,name) (p-expr (fixed ,bits))))
+                                      (let ((bits (cstring->number bits)))
+                                        (cons (cons name (make-bit-field type bit bits))
+                                              (loop (cdr o) (+ bit bits)))))
+                                     (_ (error "struct-field: not supported:" field o))))))))))
       ((comp-decl (decl-spec-list ,type) (comp-declr-list . ,decls))
        (append-map (lambda (o)
                      ((struct-field info) `(comp-decl (decl-spec-list ,type) (comp-declr-list ,o))))
         ((c-array? o) (* (c-array:count o) ((compose ->size c-array:type) o)))
         ((local? o) ((compose ->size local:type) o))
         ((global? o) ((compose ->size global:type) o))
+        ((bit-field? o) ((compose ->size bit-field:type) o))
+        ((and (pair? o) (pair? (car o)) (bit-field? (cdar o))) ((compose ->size cdar) o))
         ;; FIXME
         ;; (#t
         ;;  (stderr "o=~s\n" o)