From c9ba7a619b5d6ae5eabc8295d248f1e448c9eb28 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 5 May 2018 12:30:06 +0200 Subject: [PATCH] mescc: Refactor variable declaration. * module/language/c99/compiler.mes (decl->info): Refactor. --- build-aux/check-mescc.sh | 6 +- doc/UPDATE-0.13 | 87 + module/language/c99/compiler.mes | 2878 ++++++++--------- module/language/c99/info.scm | 8 +- module/mes/M1.mes | 8 +- scaffold/boot/02-identifier.scm | 25 + scaffold/boot/03-big-string.scm | 56 + scaffold/boot/05-big-list.scm | 28 + scaffold/boot/05-list-list.scm | 19 + scaffold/boot/60-let-syntax-expanded.scm | 564 ++++ scaffold/boot/call-cc.scm | 60 + scaffold/boot/memory.scm | 41 + scaffold/boot/numbers.scm | 1 + scaffold/tests/21-char[].c | 4 +- scaffold/tests/23-pointer.c | 2 +- scaffold/tests/46-function-static.c | 4 +- ...{48-global-static.c => 49-global-static.c} | 0 scaffold/tests/54-argv.c | 3 +- scaffold/tests/62-array.c | 55 + scaffold/tests/63-struct-cell.c | 320 +- scaffold/tests/70-printf.c | 7 +- scaffold/tests/71-struct-array.c | 2 + scaffold/tests/7i-struct-struct.c | 4 +- scaffold/tests/90-goto-var.c | 13 + scaffold/tests/91-goto-array.c | 34 + scaffold/tests/t.c | 112 +- 26 files changed, 2561 insertions(+), 1780 deletions(-) create mode 100644 doc/UPDATE-0.13 create mode 100644 scaffold/boot/02-identifier.scm create mode 100644 scaffold/boot/03-big-string.scm create mode 100644 scaffold/boot/05-big-list.scm create mode 100644 scaffold/boot/05-list-list.scm create mode 100644 scaffold/boot/60-let-syntax-expanded.scm create mode 100644 scaffold/boot/call-cc.scm create mode 100644 scaffold/boot/memory.scm create mode 100644 scaffold/boot/numbers.scm rename scaffold/tests/{48-global-static.c => 49-global-static.c} (100%) create mode 100644 scaffold/tests/62-array.c create mode 100644 scaffold/tests/90-goto-var.c create mode 100644 scaffold/tests/91-goto-array.c diff --git a/build-aux/check-mescc.sh b/build-aux/check-mescc.sh index 1de60a9a..dd2d5b62 100755 --- a/build-aux/check-mescc.sh +++ b/build-aux/check-mescc.sh @@ -75,6 +75,7 @@ t 46-function-static 47-function-expression 48-function-destruct +49-global-static 50-assert 51-strcmp 52-itoa @@ -82,6 +83,7 @@ t 54-argv 60-math 61-array +62-array 63-struct-cell 64-make-cell 65-read @@ -205,8 +207,8 @@ tests=" 50_logical_second_arg 51_static 52_unnamed_enum -55_lshift_type 54_goto +55_lshift_type " broken="$broken @@ -219,6 +221,7 @@ broken="$broken 27_sizeof 28_strings +31_args 32_led 34_array_assignment 37_sprintf @@ -230,7 +233,6 @@ broken="$broken 46_grep 49_bracket_evaluation -51_static 52_unnamed_enum 55_lshift_type " diff --git a/doc/UPDATE-0.13 b/doc/UPDATE-0.13 new file mode 100644 index 00000000..00b57844 --- /dev/null +++ b/doc/UPDATE-0.13 @@ -0,0 +1,87 @@ +Subject: wip-bootstrap updated + +I've updated the wip-bootstrap branch[0] for Mes[1] 0.13. It has new +mes-boot and tcc-boot packages. mes-boot is a bootstrap version of +Mes; it only depends on mescc-tools and a previously compiled mes.M1 +seed. Likewise, tcc-boot depends on a precompiled tcc-seed. Also, +tcc-boot uses a heavily patched version of the tcc sources. + +Mes 0.13 is the first release that can bootstrap a fairly functional +tcc-boot. This bootstrapped tcc passes 67/68 C tests that were created +for MesCC. It can compile a version if itself where float, long long +and bitfield are patched out...but linking fails. This amazing +compiler can now be played with by doing something like + +--8<---------------cut here---------------start------------->8--- +git checkout wip-bootstrap +make +./pre-inst-env guix build tcc-boot # may take ~2h +./pre-inst-env guix environment --ad-hoc tcc-boot +mes-tcc --help #duck and run +--8<---------------cut here---------------end--------------->8--- + +The next big effort will be to make this mes-tcc fully functional and +integrate this with GuixSD. To give you a taste of that, +here's latest bug I'm currently looking at (pretty printed comments +are only added when Guile runs MesCC, the problem is in LEA) + +--8<---------------cut here---------------start------------->8--- +$ diff -u ../mes-seed/mes.M1 src/mes.M1 +--- ../mes-seed/mes.M1 2018-05-01 18:49:37.312162270 +0200 ++++ src/mes.M1 2018-05-01 19:49:40.774770406 +0200 +@@ -35805,12 +33091,11 @@ + call32 %strcpy + add____$i8,%esp !0x8 + test___%eax,%eax +- # strcpy(buf + strlen(buf), "/mes/"); +- push___$i32 &_string_reader_read_list_266 ++ push___$i32 &_string_reader_read_list_265 + mov____%ebp,%eax +- add____$i32,%eax %0x-200 ++ add____$i32,%eax %0x-800 + push___%eax +- lea____0x32(%ebp),%eax %0x-200 ++ lea____0x32(%ebp),%eax %0x-800 + push___%eax + call32 %strlen + add____$i8,%esp !0x4 +--8<---------------cut here---------------end--------------->8--- + +We also need to remove some shortcuts that we took, most notably: +mes-seed[3]. This seed consists of 1MB of M1 code. mes.M1 is +produced by compiling mes.c using MesCC, the C compiler written in +(Guile) Scheme that comes with Mes. Although that's really terrible, +it's probably a big step forward: currently GuixSD uses ~250MB of +binary seed: the bootstrap binaries. + +The plan is to replace the mes.M1 seed with mes.M2 and compile this +new mes.M2 seed using the brand new M2-Planet[2]. M2 is basically +simple C with structs, without preprocessor. This will reduce the +seed size by a factor of 10 while making it much more readable. + +An excerpt of the TODO I keep in Mes' BOOTSTRAP document + +--8<---------------cut here---------------start------------->8--- +* TODO +** have tcc-boot's mes-tcc compile a fully functional tcc +*** mescc: fix unknown bug. +*** mescc: support function-static. +*** mescc: support/grok global static. +*** mescc: support unsigned comparison, arithmetic. +*** mescc: support long long (do we need long long to get long long in tcc)? +*** mescc: support bitfield (do we need bitfield to get bitfield in tcc)? +*** mescc: support float (do we need float to get float in tcc)? +** have bootstrapped tcc compile gcc-4.7 +** remove or upstream patches from tcc-boot +** prepare src/mes.c for M2-Planet[2] transpiler +** integrate with GuixSD +** x86_64, arm, the Hurd +--8<---------------cut here---------------end--------------->8--- + +Greetings, +janneke + +[0] http://git.savannah.gnu.org/cgit/guix.git/log/?h=wip-bootstrap +[1] https://gitlab.com/janneke/mes +[2] https://github.com/oriansj/m2-planet +[3] https://gitlab.com/janneke/mes-seed diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index f68b77c3..81be0124 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -105,43 +105,6 @@ (cons (ast-strip-const h) (ast-strip-const t)))) (_ o))) -(define (ast:function? o) - (and (pair? o) (eq? (car o) 'fctn-defn))) - -(define (.name o) - (pmatch o - ((fctn-defn _ (ftn-declr (ident ,name) _) _) name) - ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name) - ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr (ident ,name) _)) _) name) - ((ellipsis) #f) - ((param-decl (decl-spec-list (type-spec (void)))) #f) - ((param-decl _ (param-declr (ident ,name))) name) - ((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name) - ((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name) - ((param-decl _ (param-declr (ptr-declr (pointer (pointer)) (ident ,name)))) name) - ((param-decl _ (param-declr (ptr-declr (pointer (pointer (pointer))) (ident ,name)))) name) - ((param-decl _ (param-declr (ptr-declr (pointer (decl-spec-list) (pointer)) (ident ,name)))) name) - ((param-decl _ (param-declr (ptr-declr (pointer (decl-spec-list)) (array-of (ident ,name))))) name) - ((param-decl _ (param-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,params)))) name) - (_ - (format (current-error-port) "SKIP: .name =~a\n" o)))) - -(define (.type o) - (pmatch o - ((ellipsis) #f) - ((param-decl (decl-spec-list (type-spec (void)))) #f) - ((param-decl (decl-spec-list (type-spec ,type)) _) (decl->ast-type type)) - ((param-decl ,type _) type) - (_ - (format (current-error-port) "SKIP: .type =~a\n" o)))) - -(define (.statements o) - (pmatch o - ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements) - ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements) - ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements) - (_ (error ".statements: not supported: " o)))) - (define (clone o . rest) (cond ((info? o) (let ((types (.types o)) @@ -230,71 +193,130 @@ ((,name ,type ,size ,pointer) size) (_ (error (format #f "field:size: ~s\n" o))))) +(define (struct:size o) + (field:size (cons 'struct (type:description o)))) ;;FIXME + (define (field:type o) (pmatch o ((,name ,type ,size ,pointer) type) (_ (error (format #f "field:type: ~s\n" o))))) -(define (get-type info o) - (let ((t (assoc-ref (.types info) o))) - (pmatch t - ((typedef ,next) (or (get-type info next) o)) - (_ t)))) - -(define (ast-type->type info o) - (if (type? o) o - (pmatch o - ((p-expr ,expr) (ast-type->type info (expr->type info o))) - ((pre-inc ,expr) (ast-type->type info expr)) - ((post-inc ,expr) (ast-type->type info expr)) - ((decl-spec-list ,type-spec) - (ast-type->type info type-spec)) - ((decl-spec-list (type-qual ,qual) (type-spec (fixed-type ,type))) - (ast-type->type info type)) - ((array-ref ,index (p-expr (ident ,array))) - (ast-type->type info `(p-expr (ident ,array)))) - ((struct-ref (ident ,type)) - (or (get-type info type) - (let ((struct (if (pair? type) type `("tag" ,type)))) - (ast-type->type info struct)))) - ((union-ref (ident ,type)) - (or (get-type info type) - (let ((struct (if (pair? type) type `("tag" ,type)))) - (ast-type->type info struct)))) - ((void) (ast-type->type info "void")) - ((type-spec ,type) (ast-type->type info type)) - ((fixed-type ,type) (ast-type->type info type)) - ((float-type ,type) (ast-type->type info type)) - ((typename ,type) (ast-type->type info type)) - ((de-ref ,expr) - (ast-type->type info expr)) - ((d-sel (idend ,field) ,struct) - (let ((type0 (ast-type->type info struct))) - (field-type info type0 field))) - ((i-sel (ident ,field) ,struct) - (let ((type0 (ast-type->type info struct))) - (field-type info type0 field))) - (_ (let ((type (get-type info o))) - (if type type - (begin - (stderr "types: ~s\n" (.types info)) - (error "ast-type->type: not supported: " o)))))))) +(define (ast->type info o) + (define (get-type o) + (let ((t (assoc-ref (.types info) o))) + (pmatch t + ((typedef ,next) (or (get-type next) o)) + (_ t)))) + (pmatch o + (,t (guard (type? t)) t) + ((p-expr ,expr) (ast->type info expr)) + ((pre-inc ,expr) (ast->type info expr)) + ((post-inc ,expr) (ast->type info expr)) + ((ident ,name) (ident->type info name)) + ((char ,value) (get-type "char")) + ((fixed ,value) (get-type "int")) + ((type-spec (typename ,type)) + (ast->type info type)) + ((array-ref ,index ,array) + (ast->type info array)) + ((struct-ref (ident ,type)) + (or (get-type type) + (let ((struct (if (pair? type) type `("tag" ,type)))) + (ast->type info struct)))) + ((union-ref (ident ,type)) + (or (get-type type) + (let ((struct (if (pair? type) type `("tag" ,type)))) + (ast->type info struct)))) + ((struct-def (ident ,name) . _) + (ast->type info `("tag" ,name))) + ((union-def (ident ,name) . _) + (ast->type info `("tag" ,name))) + ((struct-def (field-list . ,fields)) + (let ((fields (append-map (struct-field info) fields))) + (make-type 'struct (apply + (map field:size fields)) 0 fields))) + ((union-def (field-list . ,fields)) + (let ((fields (append-map (struct-field info) fields))) + (make-type 'union (apply + (map field:size fields)) 0 fields))) + ((void) (ast->type info "void")) + ((fixed-type ,type) (ast->type info type)) + ((float-type ,type) (ast->type info type)) + ((typename ,type) (ast->type info type)) + ((de-ref ,expr) + (ast->type info expr)) + ((d-sel (ident ,field) ,struct) + (let ((type0 (ast->type info struct))) + (ast->type info (field-type info type0 field)))) + ((i-sel (ident ,field) ,struct) + (let ((type0 (ast->type info struct))) + (ast->type info (field-type info type0 field)))) + ((ref-to ,expr) (ast->type info expr)) + ((pre-inc ,a) (ast->type info a)) + ((pre-dec ,a) (ast->type info a)) + ((post-inc ,a) (ast->type info a)) + ((post-dec ,a) (ast->type info a)) + ((add ,a ,b) (ast->type info a)) + ((sub ,a ,b) (ast->type info a)) + ((bitwise-and ,a ,b) (ast->type info a)) + ((bitwise-not ,a) (ast->type info a)) + ((bitwise-or ,a ,b) (ast->type info a)) + ((bitwise-xor ,a ,b) (ast->type info a)) + ((lshift ,a ,b) (ast->type info a)) + ((rshift ,a ,b) (ast->type info a)) + ((div ,a ,b) (ast->type info a)) + ((mod ,a ,b) (ast->type info a)) + ((mul ,a ,b) (ast->type info a)) + ((not ,a) (ast->type info a)) + ((neg ,a) (ast->type info a)) + ((eq ,a ,b) (ast->type info a)) + ((ge ,a ,b) (ast->type info a)) + ((gt ,a ,b) (ast->type info a)) + ((ne ,a ,b) (ast->type info a)) + ((le ,a ,b) (ast->type info a)) + ((lt ,a ,b) (ast->type info a)) + ((or ,a ,b) (ast->type info a)) + ((and ,a ,b) (ast->type info a)) + ((cast (type-name ,type) ,expr) ; FIXME: ignore expr? + (ast->type info type)) + ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: ignore expr? + (ast->type info type)) + ((decl-spec-list (type-spec ,type)) + (ast->type info type)) + ((assn-expr ,a ,op ,b) + (ast->type info a)) + ((enum-ref . _) (get-type "int")) + ((sizeof-type . _) (get-type "int")) + ((sizeof-expr . _) (get-type "int")) + ((string _) (get-type "char")) + ((fctn-call (p-expr (ident ,function)) . ,rest) + (or (and=> (assoc-ref (.functions info) function) function:type) + (begin + (stderr "ast->type: no such function: ~s\n" function) + (get-type "int")))) + (_ (let ((type (get-type o))) + (cond ((type? type) type) + ((and (pair? type) (equal? (car type) "tag")) + (stderr "NO STRUCT YET:~s\n" (.types info)) + type) + ((and (pair? o) (equal? (car o) "tag")) + (stderr "NO STRUCT YET:~s\n" (.types info)) + o) + (else + (stderr "types: ~s\n" (.types info)) + (error "ast->type: not supported: " o))))))) (define (ast-type->description info o) - (let* ((type (ast-type->type info o)) - (xtype (if (type? type) type - (ast-type->type info type)))) - (type:description xtype))) + ((compose type:description (cut ast->type info <>) o))) (define (ast-type->size info o) - (let* ((type (ast-type->type info o)) - (xtype (if (type? type) type - (ast-type->type info type)))) - (type:size xtype))) + ;;((compose type:size (cut ast->type info <>)) o) + (let ((type (if (type? o) o + (ast->type info o)))) + (if (not (type? type)) (error "ast-type->size: no such type:" o) + (type:size type)))) (define (field-field info struct field) (let* ((xtype (if (type? struct) struct - (ast-type->type info struct))) + (ast->type info struct))) (fields (type:description xtype))) (let loop ((fields fields)) (if (null? fields) (error (format #f "no such field: ~a in ~s" field struct)) @@ -306,7 +328,7 @@ (define (field-offset info struct field) (let ((xtype (if (type? struct) struct - (ast-type->type info struct)))) + (ast->type info struct)))) (if (eq? (type:type xtype) 'union) 0 (let ((fields (type:description xtype))) (let loop ((fields fields) (offset 0)) @@ -331,7 +353,7 @@ (define (field-size info struct field) (let ((xtype (if (type? struct) struct - (ast-type->type info struct)))) + (ast->type info struct)))) (if (eq? (type:type xtype) 'union) 0 (let ((field (field-field info struct field))) (field:size field))))) @@ -340,28 +362,15 @@ (let ((field (field-field info struct field))) (field:type field))) -(define (ast->type o) +(define (struct->fields o) (pmatch o - ((fixed-type ,type) - type) - ((typename ,type) - type) - ((struct-ref (ident ,type)) - `("tag" ,type)) - (_ (stderr "SKIP: .type=~s\n" o) - "int"))) - -(define (decl->ast-type o) - (pmatch o - ((fixed-type ,type) type) - ((struct-ref (ident (,name))) `("tag" ,name)) - ((struct-ref (ident ,name)) `("tag" ,name)) - ((struct-def (ident ,name) . ,fields) `("tag" ,name)) - ((decl (decl-spec-list (type-spec (struct-ref (ident ,name))))) ;; "scm" - `("tag" ,name)) ;; FIXME - ((typename ,name) name) - (,name name) - (_ (error "decl->ast-type: not supported: " o)))) + (_ (guard (and (type? o) (eq? (type:type o) 'struct))) + (append-map struct->fields (type:description o))) + (_ (guard (and (type? o) (eq? (type:type o) 'union))) + (struct->fields (car (type:description o)))) + ((struct . ,fields) + (append-map struct->fields fields)) + (_ (list o)))) (define (byte->hex.m1 o) (string-drop o 2)) @@ -372,34 +381,42 @@ (let ((s (string-drop o (string-length prefix)))) (list (format #f "'~a'" (string-join (map byte->hex.m1 (cdr (string-split o #\space))) " "))))))) -(define (ident->decl info o) +(define (ident->variable info o) (or (assoc-ref (.locals info) o) (assoc-ref (.globals info) o) + (assoc-ref (.statics info) o) (assoc-ref (.constants info) o) + (assoc-ref (.functions info) o) (begin - (stderr "NO IDENT: ~a\n" o) - (assoc-ref (.functions info) o)))) + (stderr "info=~s\n" info) + (error "ident->variable: undefined variabled:" o)))) (define (ident->type info o) - (let ((type (ident->decl info o))) - (cond ((global? type) (global:type type)) - ((local? type) (local:type type)) - ((assoc-ref (.constants info) o) "int") - (else (stderr "ident->type ~s => ~s\n" o type) - (car type))))) + (let ((var (ident->variable info o))) + (cond ((global? var) (global:type var)) + ((local? var) (local:type var)) + ((assoc-ref (.constants info) o) (assoc-ref (.types info) "int")) + ((pair? var) (car var)) + (else (stderr "ident->type ~s => ~s\n" o var) + #f)))) (define (ident->pointer info o) (let ((local (assoc-ref (.locals info) o))) - (if local (local:pointer local) + (if local (let* ((t ((compose type:pointer local:type) local)) + (v (local:pointer local)) + (p (+ (abs t) (abs v)))) + (if (or (< t 0) (< v 0)) (- p) p)) (let ((global (assoc-ref (.globals info) o))) (if global - (global:pointer (ident->decl info o)) + (let* ((t ((compose type:pointer global:type) global)) + ;;(global:pointer (ident->variable info o)) + (v (global:pointer global)) + (p (+ (abs t) (abs v)))) + (if (or (< t 0) (< v 0)) (- p) p)) 0))))) -(define (ident->type-size info o) - (let* ((type (ident->type info o)) - (xtype (ast-type->type info type))) - (type:size xtype))) +(define (ident->size info o) + ((compose type:size (cut ident->type info <>)) o)) (define (ptr-inc o) (if (< o 0) (1- o) @@ -409,12 +426,18 @@ (if (< o 0) (1+ o) (1- o))) -(define (expr->pointer info o) +(define (pointer->ptr o) (pmatch o ((pointer) 1) + ((pointer ,pointer) (1+ (pointer->ptr pointer))))) + +(define (expr->pointer info o) + (pmatch o + ((pointer . _) (pointer->ptr o)) ((p-expr (char ,value)) 0) ((p-expr (fixed ,value)) 0) - ((p-expr (ident ,name)) (ident->pointer info name)) + ((ident ,name) (ident->pointer info name)) + ((p-expr ,expr) (expr->pointer info expr)) ((de-ref ,expr) (ptr-dec (expr->pointer info expr))) ((assn-expr ,lhs ,op ,rhs) (expr->pointer info lhs)) ((add ,a ,b) (expr->pointer info a)) @@ -428,28 +451,29 @@ ((post-inc ,a) (expr->pointer info a)) ((post-dec ,a) (expr->pointer info a)) ((ref-to ,expr) (ptr-inc (expr->pointer info expr))) - ((array-ref ,index ,array) (ptr-dec (expr->pointer info array))) + ((array-ref ,index ,array) + (ptr-dec (abs (expr->pointer info array)))) ((d-sel (ident ,field) ,struct) - (let ((type (expr->type info struct))) + (let ((type (ast->type info struct))) (field-pointer info type field))) ((i-sel (ident ,field) ,struct) - (let ((type (expr->type info struct))) + (let ((type (ast->type info struct))) (field-pointer info type field))) ((cast (type-name ,type) ,expr) ; FIXME: add expr? - (let* ((type (ast-type->type info type)) + (let* ((type (ast->type info type)) (pointer (type:pointer type))) pointer)) ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: add expr? - (let* ((type (ast-type->type info type)) + (let* ((type (ast->type info type)) (pointer0 (type:pointer type)) (pointer1 (ptr-declr->pointer pointer)) (pointer2 (expr->pointer info expr))) (+ pointer0 pointer1))) ((type-spec ,type) - (or (and=> (ast-type->type info o) type:pointer) + (or (and=> (ast->type info o) type:pointer) (begin (stderr "expr->pointer: not supported: ~a\n" o) 0))) @@ -460,103 +484,37 @@ (begin (stderr "expr->pointer: no such function: ~a\n" function) 0))) + + ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr ,pointer ,init) . ,initzer))) + (let* ((t (expr->pointer info `(type-spec ,type))) + (i (expr->pointer info init)) + (p (expr->pointer info pointer)) + (e (+ (abs t) (abs i) (abs p)))) + (if (or (< t 0) (< i 0)) (- e) e))) + ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr ,init . ,initzer))) + (let* ((t (expr->pointer info `(type-spec ,type))) + (i (expr->pointer info init)) + (p (+ (abs t) (abs i)))) + (if (or (< t 0) (< i 0)) (- p) p))) + ((ptr-declr ,pointer (array-of ,array . ,rest)) + (let* ((p (expr->pointer info pointer)) + (a (expr->pointer info array)) + (t (+ (abs p) (abs a) 2))) + (- t))) + ((ptr-declr ,pointer . ,rest) + (expr->pointer info pointer)) + ((array-of ,array . ,rest) + (let ((a (abs (expr->pointer info array)))) + (- (+ a 1)))) (_ (stderr "expr->pointer: not supported: ~s\n" o) 0))) -(define (expr->type-size info o) - (pmatch o - ((p-expr (char ,value)) 1) - ((p-expr (fixed ,name)) %int-size) - ((p-expr (ident ,name)) (ident->type-size info name)) - - ((array-ref ,index ,array) - (let ((type (expr->type info array))) - (ast-type->size info type))) - - ((d-sel (ident ,field) ,struct) - (let* ((type (expr->type info struct)) - (type (field-type info type field))) - (ast-type->size info type))) - - ((i-sel (ident ,field) ,struct) - (let* ((type (expr->type info struct)) - (type (field-type info type field))) - (ast-type->size info type))) - - ((de-ref ,expr) (expr->type-size info expr)) - ((ref-to ,expr) (expr->type-size info expr)) - ((add ,a ,b) (expr->type-size info a)) - ((div ,a ,b) (expr->type-size info a)) - ((mod ,a ,b) (expr->type-size info a)) - ((mul ,a ,b) (expr->type-size info a)) - ((sub ,a ,b) (expr->type-size info a)) - ((neg ,a) (expr->type-size info a)) - ((pre-inc ,a) (expr->type-size info a)) - ((pre-dec ,a) (expr->type-size info a)) - ((post-inc ,a) (expr->type-size info a)) - ((post-dec ,a) (expr->type-size info a)) - ((cast (type-name ,type) ,expr) ; FIXME: ignore expr? - (let ((type (ast-type->type info type))) - (type:size type))) - ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: ignore expr? - (let ((type (ast-type->type info type))) - (type:size type))) - ((fctn-call (p-expr (ident ,function)) . ,rest) - (or (and=> (and=> (assoc-ref (.functions info) function) function:type) - (lambda (t) - (and (type? t) (type:size t)))) - (begin - (stderr "expr->type-size: no such function: ~a\n" function) - 4))) - (_ (stderr "expr->type-size: not supported: ~s\n" o) 4))) - (define (expr->size info o) (let ((ptr (expr->pointer info o))) (if (or (= ptr -1) (= ptr 0)) - (expr->type-size info o) + (ast-type->size info o) %pointer-size))) -(define (expr->type info o) - (pmatch o - ((p-expr (char ,name)) "char") - ((p-expr (fixed ,value)) "int") - ((p-expr (ident ,name)) (ident->type info name)) - ((array-ref ,index ,array) - (expr->type info array)) - - ((i-sel (ident ,field) ,struct) - (let ((type (expr->type info struct))) - (field-type info type field))) - - ((d-sel (ident ,field) ,struct) - (let ((type (expr->type info struct))) - (field-type info type field))) - - ((de-ref ,expr) (expr->type info expr)) - ((ref-to ,expr) (expr->type info expr)) - ((add ,a ,b) (expr->type info a)) - ((div ,a ,b) (expr->type info a)) - ((mod ,a ,b) (expr->type info a)) - ((mul ,a ,b) (expr->type info a)) - ((sub ,a ,b) (expr->type info a)) - ((neg ,a) (expr->type info a)) - ((pre-inc ,a) (expr->type info a)) - ((pre-dec ,a) (expr->type info a)) - ((post-inc ,a) (expr->type info a)) - ((post-dec ,a) (expr->type info a)) - ((cast (type-name ,type) ,expr) ; FIXME: ignore expr? - type) - ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: ignore expr? - type) - ((fctn-call (p-expr (ident ,function)) . ,rest) - (or (and=> (assoc-ref (.functions info) function) function:type) - (begin - (stderr "expr->type: no such function: ~s\n" function) - "int"))) - (_ ;;(error (format #f "expr->type: not supported: ~s") o) - (stderr "TODO: expr->type: not supported: ~s\n" o) - "int"))) - (define (append-text info text) (clone info #:text (append (.text info) text))) @@ -602,20 +560,15 @@ (wrap-as (i386:push-byte-local-de-de-ref (local:id o))) (error "TODO int-de-de-ref"))))) -(define (make-global-entry key type pointer value) - (cons key (make-global key type pointer value #f))) +(define (make-global-entry key type pointer array value) + (cons key (make-global key type pointer array value #f))) (define (string->global-entry string) - (make-global-entry `(#:string ,string) "string" 0 (append (string->list string) (list #\nul)))) + (let ((value (append (string->list string) (list #\nul)))) + (make-global-entry `(#:string ,string) "char" 0 (length value) value))) -(define (int->global-entry value) - (make-global-entry (number->string value) "int" 0 (int->bv32 value))) - -(define (ident->global-entry name type pointer value) - (make-global-entry name type pointer (if (pair? value) value (int->bv32 value)))) - -(define (make-local-entry name type pointer id) - (cons name (make-local type pointer id))) +(define (make-local-entry name type pointer array id) + (cons name (make-local type pointer array id))) (define* (mescc:trace name #:optional (type "")) (format (current-error-port) " :~a~a\n" name type)) @@ -660,8 +613,13 @@ (define (expr->arg info) (lambda (o) - (let ((info ((expr->accu info) o))) - (append-text info (wrap-as (i386:push-accu)))))) + (pmatch o + ((p-expr (string ,string)) + (let* ((globals ((globals:add-string (.globals info)) string)) + (info (clone info #:globals globals))) + (append-text info ((push-global-address info) `(#:string ,string))))) + (_ (let ((info (expr->accu o info))) + (append-text info (wrap-as (i386:push-accu)))))))) (define (globals:add-string globals) (lambda (o) @@ -669,53 +627,20 @@ (if (assoc-ref globals string) globals (append globals (list (string->global-entry o))))))) -(define (expr->arg info) ;; FIXME: get Mes curried-definitions - (lambda (o) - (let ((text (.text info))) - (pmatch o - - ((p-expr (string ,string)) - (let* ((globals ((globals:add-string (.globals info)) string)) - (info (clone info #:globals globals))) - (append-text info ((push-global-address info) `(#:string ,string))))) - - ((p-expr (ident ,name)) - (append-text info ((push-ident info) name))) - - ((cast (type-name (decl-spec-list (type-spec (fixed-type _))) - (abs-declr (pointer))) - ,cast) - ((expr->arg info) cast)) - - ((cast (type-name (decl-spec-list (type-spec (fixed-type ,type)))) ,cast) - ((expr->arg info) cast)) - - ((de-ref (p-expr (ident ,name))) - (append-text info ((push-ident-de-ref info) name))) - - ((de-ref (de-ref (p-expr (ident ,name)))) - (append-text info ((push-ident-de-de-ref info) name))) - - ((ref-to (p-expr (ident ,name))) - (append-text info ((push-ident-address info) name))) - - (_ (append-text ((expr->accu info) o) - (wrap-as (i386:push-accu)))))))) +(define (local->accu o) + (let* ((ptr (local:pointer o)) + (type (local:type o)) + (size (if (= ptr 0) (type:size type) + 4))) + (cond ((< ptr 0) (wrap-as (i386:local-ptr->accu (local:id o)))) + (else (wrap-as (case size + ((1) (i386:byte-local->accu (local:id o))) + ((2) (i386:word-local->accu (local:id o))) + (else (i386:local->accu (local:id o))))))))) (define (ident->accu info) (lambda (o) - (cond ((assoc-ref (.locals info) o) - => - (lambda (local) - (let* ((ptr (local:pointer local)) - (type (ident->type info o)) - (size (if (= ptr 0) (ast-type->size info type) - 4))) - (cond ((< ptr 0) (wrap-as (i386:local-ptr->accu (local:id local)))) - (else (wrap-as (case size - ((1) (i386:byte-local->accu (local:id local))) - ((2) (i386:word-local->accu (local:id local))) - (else (i386:local->accu (local:id local)))))))))) + (cond ((assoc-ref (.locals info) o) => local->accu) ((assoc-ref (.statics info) o) => (lambda (global) @@ -763,51 +688,90 @@ (define (value->accu v) (wrap-as (i386:value->accu v))) +(define (accu->local+n-text local n) + (let* ((type (local:type local)) + (ptr (local:pointer local)) + (size (if (= ptr -1) ((compose type:size local:type) local) + 4)) + (id (local:id local))) + (wrap-as (case size + ((1) (i386:byte-accu->local+n id n)) + ((2) (i386:word-accu->local+n id n)) + (else (i386:accu->local+n id n)))))) + (define (accu->ident info) (lambda (o) - (let* ((local (assoc-ref (.locals info) o)) - (ptr (ident->pointer info o)) - (size (if (or (= ptr -1) (= ptr 0)) (ident->type-size info o) - 4))) - (if local (if (<= size 4) (wrap-as (i386:accu->local (local:id local))) - (wrap-as (i386:accu*n->local (local:id local) size))) - (if (<= size 4) (wrap-as (i386:accu->label o)) - (wrap-as (i386:accu*n->label o size))))))) + (cond ((assoc-ref (.locals info) o) + => + (lambda (local) (let ((size (->size local))) + (if (<= size 4) (wrap-as (i386:accu->local (local:id local))) + (wrap-as (i386:accu*n->local (local:id local) size)))))) + ((assoc-ref (.statics info) o) + => + (lambda (global) (let ((size (->size global))) + (if (<= size 4) (wrap-as (i386:accu->label global)) + (wrap-as (i386:accu*n->label global size)))))) + ((assoc-ref (filter (negate static-global?) (.globals info)) o) + => + (lambda (global) (let ((size (->size global))) + (if (<= size 4) (wrap-as (i386:accu->label global)) + (wrap-as (i386:accu*n->label global size))))))))) (define (value->ident info) (lambda (o value) - (let ((local (assoc-ref (.locals info) o))) - (if local (wrap-as (i386:value->local (local:id local) value)) - (list (i386:value->label `(#:address ,o) value)))))) + (cond ((assoc-ref (.locals info) o) + => + (lambda (local) (wrap-as (i386:value->local (local:id local) value)))) + ((assoc-ref (.statics info) o) + => + (lambda (global) (list (i386:value->label `(#:address ,global) value)))) + ((assoc-ref (filter (negate static-global?) (.globals info)) o) + => + (lambda (global) (list (i386:value->label `(#:address ,global) value))))))) (define (ident-add info) (lambda (o n) - (let ((local (assoc-ref (.locals info) o))) - (if local (wrap-as (i386:local-add (local:id local) n)) - (list (i386:label-mem-add `(#:address ,o) n)))))) + (cond ((assoc-ref (.locals info) o) + => + (lambda (local) (wrap-as (i386:local-add (local:id local) n)))) + ((assoc-ref (.statics info) o) + => + (lambda (global) (list (i386:label-mem-add `(#:address ,o) n)))) + ((assoc-ref (filter (negate static-global?) (.globals info)) o) + => + (lambda (global) (list (i386:label-mem-add `(#:address ,global) n))))))) (define (expr-add info) (lambda (o n) - (let* ((info ((expr->accu* info) o)) + (let* ((info (expr->accu* o info)) (info (append-text info (wrap-as (i386:accu-mem-add n))))) info))) (define (ident-address-add info) (lambda (o n) - (let ((local (assoc-ref (.locals info) o))) - (if local (wrap-as (append (i386:push-accu) - (i386:local->accu (local:id local)) - (i386:accu-mem-add n) - (i386:pop-accu))) - (list (wrap-as (append (i386:push-accu) - (i386:label->accu `(#:address ,o)) - (i386:accu-mem-add n) - (i386:pop-accu)))))))) + (cond ((assoc-ref (.locals info) o) + => + (lambda (local) (wrap-as (append (i386:push-accu) + (i386:local->accu (local:id local)) + (i386:accu-mem-add n) + (i386:pop-accu))))) + ((assoc-ref (.statics info) o) + => + (lambda (global) (list (wrap-as (append (i386:push-accu) + (i386:label->accu `(#:address ,global)) + (i386:accu-mem-add n) + (i386:pop-accu)))))) + ((assoc-ref (filter (negate static-global?) (.globals info)) o) + => + (lambda (global) (list (wrap-as (append (i386:push-accu) + (i386:label->accu `(#:address ,global)) + (i386:accu-mem-add n) + (i386:pop-accu))))))))) (define (binop->accu info) (lambda (a b c) - (let* ((info ((expr->accu info) a)) - (info ((expr->base info) b))) + (let* ((info (expr->accu a info)) + (info (expr->base b info))) (append-text info (wrap-as c))))) (define (wrap-as o . annotation) @@ -818,8 +782,13 @@ (define (ast->comment o) (if mes? '() - (let ((source (with-output-to-string (lambda () (pretty-print-c99 o))))) - (make-comment (string-join (string-split source #\newline) " "))))) + (begin + (pmatch o + ;; Nyacc 0.80.42: missing (enum-ref (ident "fred")) + ((decl (decl-spec-list (type-spec (enum-ref . _))) . _) + '()) + (_ (let ((source (with-output-to-string (lambda () (pretty-print-c99 o))))) + (make-comment (string-join (string-split source #\newline) " ")))))))) (define (accu*n info n) (append-text info (wrap-as (case n @@ -866,487 +835,469 @@ (define (accu->base-mem*n info n) (append-text info (accu->base-mem*n- info n))) -(define (accu->local+n info local) - (lambda (n) - (let* ((type (local:type local)) - (ptr (local:pointer local)) - (size (if (= ptr -2) (ast-type->size info type) - 4)) - (id (local:id local))) - (append-text info (wrap-as (case size - ((1) (i386:byte-accu->local+n id n)) - ((2) (i386:word-accu->local+n id n)) - (else (i386:accu->local+n id n)))))))) +(define (expr->accu* o info) + (pmatch o -(define (expr->accu* info) - (lambda (o) + ((p-expr (ident ,name)) + (append-text info ((ident-address->accu info) name))) + + ((de-ref ,expr) + (expr->accu expr info)) + + ((d-sel (ident ,field) ,struct) + (let* ((type (ast->type info struct)) + (offset (field-offset info type field)) + (info (expr->accu* struct info))) + (append-text info (wrap-as (i386:accu+value offset))))) + + ((i-sel (ident ,field) (fctn-call (p-expr (ident ,function)) . ,rest)) + (let* ((type (ast->type info `(fctn-call (p-expr (ident ,function)) ,@rest))) + (offset (field-offset info type field)) + (info (expr->accu `(fctn-call (p-expr (ident ,function)) ,@rest) info))) + (append-text info (wrap-as (i386:accu+value offset))))) + + ((i-sel (ident ,field) ,struct) + (let* ((type (ast->type info struct)) + (offset (field-offset info type field)) + (info (expr->accu* struct info))) + (append-text info (append (wrap-as (i386:mem->accu)) + (wrap-as (i386:accu+value offset)))))) + + ((array-ref ,index ,array) + (let* ((info (expr->accu index info)) + (ptr (expr->pointer info array)) + (size (expr->size info o)) + (info (accu*n info size)) + (info (expr->base array info))) + (append-text info (wrap-as (i386:accu+base))))) + + (_ (error "expr->accu*: not supported: " o)))) + +(define (expr->accu o info) + (let ((locals (.locals info)) + (constants (.constants info)) + (text (.text info)) + (globals (.globals info))) (pmatch o + ((expr) info) + + ((comma-expr) info) + + ((comma-expr ,a . ,rest) + (let ((info (expr->accu a info))) + (expr->accu `(comma-expr ,@rest) info))) + + ((p-expr (string ,string)) + (let* ((globals ((globals:add-string globals) string)) + (info (clone info #:globals globals))) + (append-text info (list (i386:label->accu `(#:string ,string)))))) + + ((p-expr (fixed ,value)) + (let ((value (cstring->number value))) + (append-text info (wrap-as (i386:value->accu value))))) + + ((neg (p-expr (fixed ,value))) + (let ((value (- (cstring->number value)))) + (append-text info (wrap-as (i386:value->accu value))))) + + ((p-expr (char ,char)) + (let ((char (char->integer (car (string->list char))))) + (append-text info (wrap-as (i386:value->accu char))))) + + ((p-expr (string . ,strings)) + (append-text info (list (i386:label->accu `(#:string ,(apply string-append strings)))))) ((p-expr (ident ,name)) + (append-text info ((ident->accu info) name))) + + ((initzer ,initzer) + (expr->accu initzer info)) + + ;; offsetoff + ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base))))) + (let* ((type (ast->type info struct)) + (offset (field-offset info type field)) + (base (cstring->number base))) + (append-text info (wrap-as (i386:value->accu (+ base offset)))))) + + ;; &foo + ((ref-to (p-expr (ident ,name))) (append-text info ((ident-address->accu info) name))) - ((de-ref ,expr) - ((expr->accu info) expr)) + ;; &*foo + ((ref-to (de-ref ,expr)) + (expr->accu expr info)) - ((d-sel (ident ,field) ,struct) - (let* ((type (expr->type info struct)) - (offset (field-offset info type field)) - (info ((expr->accu* info) struct))) - (append-text info (wrap-as (i386:accu+value offset))))) + ((ref-to ,expr) + (expr->accu* expr info)) - ((i-sel (ident ,field) (fctn-call (p-expr (ident ,function)) . ,rest)) - (let* ((type (expr->type info `(fctn-call (p-expr (ident ,function)) ,@rest))) - (offset (field-offset info type field)) - (info ((expr->accu info) `(fctn-call (p-expr (ident ,function)) ,@rest)))) - (append-text info (wrap-as (i386:accu+value offset))))) + ((sizeof-expr ,expr) + (append-text info (wrap-as (i386:value->accu (expr->size info expr))))) - ((i-sel (ident ,field) ,struct) - (let* ((type (expr->type info struct)) - (offset (field-offset info type field)) - (info ((expr->accu* info) struct))) - (append-text info (append (wrap-as (i386:mem->accu)) - (wrap-as (i386:accu+value offset)))))) + ((sizeof-type (type-name (decl-spec-list (type-spec (fixed-type ,name))))) + (let* ((type name) + (size (ast-type->size info type))) + (append-text info (wrap-as (i386:value->accu size))))) + + ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,type)))))) + (let* ((type `("tag" ,type)) + (size (ast-type->size info type))) + (append-text info (wrap-as (i386:value->accu size))))) + + ((sizeof-type (type-name (decl-spec-list (type-spec (typename ,type))))) + (let ((size (ast-type->size info type))) + (append-text info (wrap-as (i386:value->accu size))))) + + ((sizeof-type (type-name (decl-spec-list ,type) (abs-declr (pointer)))) + (let ((size 4)) + (append-text info (wrap-as (i386:value->accu size))))) ((array-ref ,index ,array) - (let* ((info ((expr->accu info) index)) - (ptr (expr->pointer info array)) - (size (if (or (= ptr 1) (= ptr -1) (= ptr -2)) (expr->type-size info array) - 4)) - (info (accu*n info size)) - (info ((expr->base info) array))) - (append-text info (wrap-as (i386:accu+base))))) + (let* ((info (expr->accu* o info)) + (size (expr->size info o))) + (append-text info (wrap-as (case size + ((1) (i386:byte-mem->accu)) + ((2) (i386:word-mem->accu)) + ((4) (i386:mem->accu)) + (else '())))))) - (_ (error "expr->accu*: not supported: " o))))) + ((d-sel ,field ,struct) + (let* ((info (expr->accu* o info)) + (info (append-text info (ast->comment o))) + (ptr (expr->pointer info o)) + (size (if (= ptr 0) (ast-type->size info o) + 4))) + (if (or (= -2 ptr) (= -1 ptr)) info + (append-text info (wrap-as (case size + ((1) (i386:byte-mem->accu)) + ((2) (i386:word-mem->accu)) + ((4) (i386:mem->accu)) + (else '()))))))) -(define (expr->accu info) - (lambda (o) - (let ((locals (.locals info)) - (constants (.constants info)) - (text (.text info)) - (globals (.globals info))) - (define (add-local locals name type pointer) - (let* ((id (if (or (null? locals) (not (local-var? (cdar locals)))) 1 - (1+ (local:id (cdar locals))))) - (locals (cons (make-local-entry name type pointer id) locals))) - locals)) - (pmatch o - ((expr) info) + ((i-sel ,field ,struct) + (let* ((info (expr->accu* o info)) + (info (append-text info (ast->comment o))) + (ptr (expr->pointer info o)) + (size (if (= ptr 0) (ast-type->size info o) + 4))) + (if (or (= -2 ptr) (= ptr -1)) info + (append-text info (wrap-as (case size + ((1) (i386:byte-mem->accu)) + ((2) (i386:word-mem->accu)) + ((4) (i386:mem->accu)) + (else '()))))))) - ((comma-expr) info) + ((de-ref ,expr) + (let* ((info (expr->accu expr info)) + (size (expr->size info o))) + (append-text info (wrap-as (case size + ((1) (i386:byte-mem->accu)) + ((2) (i386:word-mem->accu)) + ((4) (i386:mem->accu)) + (else '())))))) - ((comma-expr ,a . ,rest) - (let ((info ((expr->accu info) a))) - ((expr->accu info) `(comma-expr ,@rest)))) + ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)) + (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME + (append-text info (wrap-as (asm->m1 arg0)))) + (let* ((text-length (length text)) + (args-info (let loop ((expressions (reverse expr-list)) (info info)) + (if (null? expressions) info + (loop (cdr expressions) ((expr->arg info) (car expressions)))))) + (n (length expr-list))) + (if (not (assoc-ref locals name)) + (begin + (if (and (not (assoc name (.functions info))) + (not (assoc name globals)) + (not (equal? name (.function info)))) + (stderr "warning: undeclared function: ~a\n" name)) + (append-text args-info (list (i386:call-label name n)))) + (let* ((empty (clone info #:text '())) + (accu (expr->accu `(p-expr (ident ,name)) empty))) + (append-text args-info (append (.text accu) + (list (i386:call-accu n))))))))) - ((p-expr (string ,string)) - (let* ((globals ((globals:add-string globals) string)) - (info (clone info #:globals globals))) - (append-text info (list (i386:label->accu `(#:string ,string)))))) + ((fctn-call ,function (expr-list . ,expr-list)) + (let* ((text-length (length text)) + (args-info (let loop ((expressions (reverse expr-list)) (info info)) + (if (null? expressions) info + (loop (cdr expressions) ((expr->arg info) (car expressions)))))) + (n (length expr-list)) + (empty (clone info #:text '())) + (accu (expr->accu function empty))) + (append-text args-info (append (.text accu) + (list (i386:call-accu n)))))) - ;; FIXME: FROM INFO ...only zero?! - ((p-expr (fixed ,value)) - (let ((value (cstring->number value))) - (append-text info (wrap-as (i386:value->accu value))))) + ((cond-expr . ,cond-expr) + (ast->info `(expr-stmt ,o) info)) - ((p-expr (char ,char)) - (let ((char (char->integer (car (string->list char))))) - (append-text info (wrap-as (i386:value->accu char))))) + ((post-inc ,expr) + (let* ((info (append (expr->accu expr info))) + (info (append-text info (wrap-as (i386:push-accu)))) + (ptr (expr->pointer info expr)) + (size (cond ((= ptr 1) (ast-type->size info expr)) + ((> ptr 1) 4) + (else 1))) + (info ((expr-add info) expr size)) + (info (append-text info (wrap-as (i386:pop-accu))))) + info)) - ((p-expr (string . ,strings)) - (append-text info (list (i386:label->accu `(#:string ,(apply string-append strings)))))) + ((post-dec ,expr) + (let* ((info (append (expr->accu expr info))) + (info (append-text info (wrap-as (i386:push-accu)))) + (ptr (expr->pointer info expr)) + (size (cond ((= ptr 1) (ast-type->size info expr)) + ((> ptr 1) 4) + (else 1))) + (info ((expr-add info) expr (- size))) + (info (append-text info (wrap-as (i386:pop-accu))))) + info)) - ((p-expr (ident ,name)) - (append-text info ((ident->accu info) name))) + ((pre-inc ,expr) + (let* ((ptr (expr->pointer info expr)) + (size (cond ((= ptr 1) (ast-type->size info expr)) + ((> ptr 1) 4) + (else 1))) + (info ((expr-add info) expr size)) + (info (append (expr->accu expr info)))) + info)) - ((initzer ,initzer) - ((expr->accu info) initzer)) - - ;; offsetoff - ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base))))) - (let* ((type (decl->ast-type struct)) - (offset (field-offset info type field)) - (base (cstring->number base))) - (append-text info (wrap-as (i386:value->accu (+ base offset)))))) - - ;; &foo - ((ref-to (p-expr (ident ,name))) - (append-text info ((ident-address->accu info) name))) - - ;; &*foo - ((ref-to (de-ref ,expr)) - ((expr->accu info) expr)) - - ((ref-to ,expr) - ((expr->accu* info) expr)) - - ((sizeof-expr ,expr) - (append-text info (wrap-as (i386:value->accu (expr->size info expr))))) - - ((sizeof-type (type-name (decl-spec-list (type-spec (fixed-type ,name))))) - (let* ((type name) - (size (ast-type->size info type))) - (append-text info (wrap-as (i386:value->accu size))))) - - ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,type)))))) - (let* ((type `("tag" ,type)) - (size (ast-type->size info type))) - (append-text info (wrap-as (i386:value->accu size))))) - - ((sizeof-type (type-name (decl-spec-list (type-spec (typename ,type))))) - (let ((size (ast-type->size info type))) - (append-text info (wrap-as (i386:value->accu size))))) - - ((sizeof-type (type-name (decl-spec-list ,type) (abs-declr (pointer)))) - (let ((size 4)) - (append-text info (wrap-as (i386:value->accu size))))) - - ;; [baz] - ((array-ref ,index ,array) - (let* ((info ((expr->accu* info) o)) - (ptr (expr->pointer info array)) - (size (if (or (= ptr 1) (= ptr -1) (= ptr -2)) (expr->type-size info array) - 4))) - (append-text info (wrap-as (case size - ((1) (i386:byte-mem->accu)) - ((2) (i386:word-mem->accu)) - ((4) (i386:mem->accu)) - (else '())))))) - - ((d-sel ,field ,struct) - (let* ((info ((expr->accu* info) o)) - (info (append-text info (ast->comment o))) - (ptr (expr->pointer info o)) - (size (if (= ptr 0) (expr->type-size info o) - 4))) - (if (or (= -2 ptr) (= -1 ptr)) info - (append-text info (wrap-as (case size - ((1) (i386:byte-mem->accu)) - ((2) (i386:word-mem->accu)) - ((4) (i386:mem->accu)) - (else '()))))))) - - ((i-sel ,field ,struct) - (let* ((info ((expr->accu* info) o)) - (info (append-text info (ast->comment o))) - (ptr (expr->pointer info o)) - (size (if (= ptr 0) (expr->type-size info o) - 4))) - (if (or (= -2 ptr) (= ptr -1)) info - (append-text info (wrap-as (case size - ((1) (i386:byte-mem->accu)) - ((2) (i386:word-mem->accu)) - ((4) (i386:mem->accu)) - (else '()))))))) - - ((de-ref ,expr) - (let* ((info ((expr->accu info) expr)) - (ptr (expr->pointer info expr)) - (size (expr->size info o))) - (append-text info (wrap-as (case size - ((1) (i386:byte-mem->accu)) - ((2) (i386:word-mem->accu)) - ((4) (i386:mem->accu)) - (else '())))))) - - ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)) - (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME - (append-text info (wrap-as (asm->m1 arg0)))) - (let* ((text-length (length text)) - (args-info (let loop ((expressions (reverse expr-list)) (info info)) - (if (null? expressions) info - (loop (cdr expressions) ((expr->arg info) (car expressions)))))) - (n (length expr-list))) - (if (not (assoc-ref locals name)) - (begin - (if (and (not (assoc name (.functions info))) - (not (assoc name globals)) - (not (equal? name (.function info)))) - (stderr "warning: undeclared function: ~a\n" name)) - (append-text args-info (list (i386:call-label name n)))) - (let* ((empty (clone info #:text '())) - (accu ((expr->accu empty) `(p-expr (ident ,name))))) - (append-text args-info (append (.text accu) - (list (i386:call-accu n))))))))) - - ((fctn-call ,function (expr-list . ,expr-list)) - (let* ((text-length (length text)) - (args-info (let loop ((expressions (reverse expr-list)) (info info)) - (if (null? expressions) info - (loop (cdr expressions) ((expr->arg info) (car expressions)))))) - (n (length expr-list)) - (empty (clone info #:text '())) - (accu ((expr->accu empty) function))) - (append-text args-info (append (.text accu) - (list (i386:call-accu n)))))) - - ((cond-expr . ,cond-expr) - ((ast->info info) `(expr-stmt ,o))) - - ((post-inc ,expr) - (let* ((info (append ((expr->accu info) expr))) - (info (append-text info (wrap-as (i386:push-accu)))) - (ptr (expr->pointer info expr)) - (size (cond ((= ptr 1) (expr->type-size info expr)) - ((> ptr 1) 4) - (else 1))) - (info ((expr-add info) expr size)) - (info (append-text info (wrap-as (i386:pop-accu))))) - info)) - - ((post-dec ,expr) - (let* ((info (append ((expr->accu info) expr))) - (info (append-text info (wrap-as (i386:push-accu)))) - (ptr (expr->pointer info expr)) - (size (cond ((= ptr 1) (expr->type-size info expr)) - ((> ptr 1) 4) - (else 1))) - (info ((expr-add info) expr (- size))) - (info (append-text info (wrap-as (i386:pop-accu))))) - info)) - - ((pre-inc ,expr) - (let* ((ptr (expr->pointer info expr)) - (size (cond ((= ptr 1) (expr->type-size info expr)) - ((> ptr 1) 4) - (else 1))) - (info ((expr-add info) expr size)) - (info (append ((expr->accu info) expr)))) - info)) - - ((pre-dec ,expr) - (let* ((ptr (expr->pointer info expr)) - (size (cond ((= ptr 1) (expr->type-size info expr)) - ((> ptr 1) 4) - (else 1))) - (info ((expr-add info) expr (- size))) - (info (append ((expr->accu info) expr)))) - info)) + ((pre-dec ,expr) + (let* ((ptr (expr->pointer info expr)) + (size (cond ((= ptr 1) (ast-type->size info expr)) + ((> ptr 1) 4) + (else 1))) + (info ((expr-add info) expr (- size))) + (info (append (expr->accu expr info)))) + info)) - ((add ,a (p-expr (fixed ,value))) - (let* ((ptr (expr->pointer info a)) - (type0 (expr->type info a)) - (struct? (memq (type:type (ast-type->type info type0)) '(struct union))) - (size (cond ((= ptr 1) (expr->type-size info a)) - ((> ptr 1) 4) - ((and struct? (= ptr -2)) 4) - ((and struct? (= ptr 2)) 4) - (else 1))) - (info ((expr->accu info) a)) - (value (cstring->number value)) - (value (* size value))) - (append-text info (wrap-as (i386:accu+value value))))) + ((add ,a (p-expr (fixed ,value))) + (let* ((ptr (expr->pointer info a)) + (type (ast->type info a)) + (struct? (or (and (pair? type) (equal? (car type) "tag")) + (memq (type:type type) '(struct union)))) + (size (cond ((= ptr 1) (ast-type->size info a)) + ((> ptr 1) 4) + ((and struct? (= ptr -2)) 4) + ((and struct? (= ptr 2)) 4) + (else 1))) + (info (expr->accu a info)) + (value (cstring->number value)) + (value (* size value))) + (append-text info (wrap-as (i386:accu+value value))))) - ((add ,a ,b) - (let* ((ptr (expr->pointer info a)) - (ptr-b (expr->pointer info b)) - (type0 (expr->type info a)) - (struct? (memq (type:type (ast-type->type info type0)) '(struct union))) - (size (cond ((= ptr 1) (expr->type-size info a)) - ((> ptr 1) 4) - ((and struct? (= ptr -2)) 4) - ((and struct? (= ptr 2)) 4) - (else 1)))) - (if (or (= size 1)) ((binop->accu info) a b (i386:accu+base)) - (let* ((info ((expr->accu info) b)) - (info (append-text info (wrap-as (append (i386:value->base size) - (i386:accu*base) - (i386:accu->base))))) - (info ((expr->accu info) a))) - (append-text info (wrap-as (i386:accu+base))))))) + ((add ,a ,b) + (let* ((ptr (expr->pointer info a)) + (ptr-b (expr->pointer info b)) + (type (ast->type info a)) + (struct? (or (and (pair? type) (equal? (car type) "tag")) + (memq (type:type type) '(struct union)))) + (size (cond ((= ptr 1) (ast-type->size info a)) + ((> ptr 1) 4) + ((and struct? (= ptr -2)) 4) + ((and struct? (= ptr 2)) 4) + (else 1)))) + (if (or (= size 1)) ((binop->accu info) a b (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))))))) - ((sub ,a (p-expr (fixed ,value))) - (let* ((ptr (expr->pointer info a)) - (type0 (expr->type info a)) - (struct? (memq (type:type (ast-type->type info type0)) '(struct union))) - (size (cond ((= ptr 1) (expr->type-size info a)) - ((> ptr 1) 4) - ((and struct? (= ptr -2)) 4) - ((and struct? (= ptr 2)) 4) - (else 1))) - (info ((expr->accu info) a)) - (value (cstring->number value)) - (value (* size value))) - (append-text info (wrap-as (i386:accu+value (- value)))))) + ((sub ,a (p-expr (fixed ,value))) + (let* ((ptr (expr->pointer info a)) + (type (ast->type info a)) + (struct? (or (and (pair? type) (equal? (car type) "tag")) + (memq (type:type type) '(struct union)))) + (size (cond ((= ptr 1) (ast-type->size info a)) + ((> ptr 1) 4) + ((and struct? (= ptr -2)) 4) + ((and struct? (= ptr 2)) 4) + (else 1))) + (info (expr->accu a info)) + (value (cstring->number value)) + (value (* size value))) + (append-text info (wrap-as (i386:accu+value (- value)))))) - ((sub ,a ,b) - (let* ((ptr (expr->pointer info a)) - (ptr-b (expr->pointer info b)) - (type0 (expr->type info a)) - (struct? (memq (type:type (ast-type->type info type0)) '(struct union))) - (size (cond ((= ptr 1) (expr->type-size info a)) - ((> ptr 1) 4) - ((and struct? (= ptr -2)) 4) - ((and struct? (= ptr 2)) 4) - (else 1)))) - (if (or (= size 1) (or (= ptr-b -2) (= ptr-b 1))) - (let ((info ((binop->accu info) a b (i386:accu-base)))) - (if (and (not (= ptr-b -2)) (not (= ptr-b 1))) info - (append-text info (wrap-as (append (i386:value->base size) - (i386:accu/base)))))) - (let* ((info ((expr->accu info) b)) - (info (append-text info (wrap-as (append (i386:value->base size) - (i386:accu*base) - (i386:accu->base))))) - (info ((expr->accu info) a))) - (append-text info (wrap-as (i386:accu-base))))))) + ((sub ,a ,b) + (let* ((ptr (expr->pointer info a)) + (ptr-b (expr->pointer info b)) + (type (ast->type info a)) + (struct? (or (and (pair? type) (equal? (car type) "tag")) + (memq (type:type type) '(struct union)))) + (size (cond ((= ptr 1) (ast-type->size info a)) + ((> ptr 1) 4) + ((and struct? (= ptr -2)) 4) + ((and struct? (= ptr 2)) 4) + (else 1)))) + (if (or (= size 1) (or (= ptr-b -2) (= ptr-b 1))) + (let ((info ((binop->accu info) a b (i386:accu-base)))) + (if (and (not (= ptr-b -2)) (not (= ptr-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))))))) - ((bitwise-and ,a ,b) ((binop->accu info) a b (i386:accu-and-base))) - ((bitwise-not ,expr) - (let ((info ((ast->info info) expr))) - (append-text info (wrap-as (i386:accu-not))))) - ((bitwise-or ,a ,b) ((binop->accu info) a b (i386:accu-or-base))) - ((bitwise-xor ,a ,b) ((binop->accu info) a b (i386:accu-xor-base))) - ((lshift ,a ,b) ((binop->accu info) a b (i386:accu<accu info) a b (i386:accu>>base))) - ((div ,a ,b) ((binop->accu info) a b (i386:accu/base))) - ((mod ,a ,b) ((binop->accu info) a b (i386:accu%base))) - ((mul ,a ,b) ((binop->accu info) a b (i386:accu*base))) + ((bitwise-and ,a ,b) ((binop->accu info) a b (i386:accu-and-base))) + ((bitwise-not ,expr) + (let ((info (ast->info expr info))) + (append-text info (wrap-as (i386:accu-not))))) + ((bitwise-or ,a ,b) ((binop->accu info) a b (i386:accu-or-base))) + ((bitwise-xor ,a ,b) ((binop->accu info) a b (i386:accu-xor-base))) + ((lshift ,a ,b) ((binop->accu info) a b (i386:accu<accu info) a b (i386:accu>>base))) + ((div ,a ,b) ((binop->accu info) a b (i386:accu/base))) + ((mod ,a ,b) ((binop->accu info) a b (i386:accu%base))) + ((mul ,a ,b) ((binop->accu info) a b (i386:accu*base))) - ((not ,expr) - (let* ((test-info ((ast->info info) expr))) - (clone info #:text - (append (.text test-info) - (wrap-as (i386:accu-negate))) - #:globals (.globals test-info)))) + ((not ,expr) + (let* ((test-info (ast->info expr info))) + (clone info #:text + (append (.text test-info) + (wrap-as (i386:accu-negate))) + #:globals (.globals test-info)))) - ((neg ,expr) - (let ((info ((expr->base info) expr))) - (append-text info (append (wrap-as (i386:value->accu 0)) - (wrap-as (i386:sub-base)))))) + ((neg ,expr) + (let ((info (expr->base expr info))) + (append-text info (append (wrap-as (i386:value->accu 0)) + (wrap-as (i386:sub-base)))))) - ((eq ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:z->accu)))) - ((ge ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:ge?->accu)))) - ((gt ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:g?->accu) (i386:accu-test)))) + ((eq ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:z->accu)))) + ((ge ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:ge?->accu)))) + ((gt ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:g?->accu) (i386:accu-test)))) - ;; FIXME: set accu *and* flags - ((ne ,a ,b) ((binop->accu info) a b (append (i386:push-accu) - (i386:sub-base) - (i386:nz->accu) - (i386:accu<->stack) - (i386:sub-base) - (i386:xor-zf) - (i386:pop-accu)))) + ;; FIXME: set accu *and* flags + ((ne ,a ,b) ((binop->accu info) a b (append (i386:push-accu) + (i386:sub-base) + (i386:nz->accu) + (i386:accu<->stack) + (i386:sub-base) + (i386:xor-zf) + (i386:pop-accu)))) - ((ne ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:xor-zf)))) - ((le ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:le?->accu)))) - ((lt ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:l?->accu)))) + ((ne ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:xor-zf)))) + ((le ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:le?->accu)))) + ((lt ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:l?->accu)))) - ((or ,a ,b) - (let* ((info ((expr->accu info) a)) - (here (number->string (length (.text info)))) - (skip-b-label (string-append "_" (.function info) "_" here "_or_skip_b")) - (info (append-text info (wrap-as (i386:accu-test)))) - (info (append-text info (wrap-as (i386:jump-nz skip-b-label)))) - (info (append-text info (wrap-as (i386:accu-test)))) - (info ((expr->accu info) b)) - (info (append-text info (wrap-as (i386:accu-test)))) - (info (append-text info (wrap-as `((#:label ,skip-b-label)))))) - info)) + ((or ,a ,b) + (let* ((info (expr->accu a info)) + (here (number->string (length (.text info)))) + (skip-b-label (string-append "_" (.function info) "_" here "_or_skip_b")) + (info (append-text info (wrap-as (i386:accu-test)))) + (info (append-text info (wrap-as (i386:jump-nz skip-b-label)))) + (info (append-text info (wrap-as (i386:accu-test)))) + (info (expr->accu b info)) + (info (append-text info (wrap-as (i386:accu-test)))) + (info (append-text info (wrap-as `((#:label ,skip-b-label)))))) + info)) - ((and ,a ,b) - (let* ((info ((expr->accu info) a)) - (here (number->string (length (.text info)))) - (skip-b-label (string-append "_" (.function info) "_" here "_and_skip_b")) - (info (append-text info (wrap-as (i386:accu-test)))) - (info (append-text info (wrap-as (i386:jump-z skip-b-label)))) - (info (append-text info (wrap-as (i386:accu-test)))) - (info ((expr->accu info) b)) - (info (append-text info (wrap-as (i386:accu-test)))) - (info (append-text info (wrap-as `((#:label ,skip-b-label)))))) - info)) + ((and ,a ,b) + (let* ((info (expr->accu a info)) + (here (number->string (length (.text info)))) + (skip-b-label (string-append "_" (.function info) "_" here "_and_skip_b")) + (info (append-text info (wrap-as (i386:accu-test)))) + (info (append-text info (wrap-as (i386:jump-z skip-b-label)))) + (info (append-text info (wrap-as (i386:accu-test)))) + (info (expr->accu b info)) + (info (append-text info (wrap-as (i386:accu-test)))) + (info (append-text info (wrap-as `((#:label ,skip-b-label)))))) + info)) - ((cast ,type ,expr) - ((expr->accu info) expr)) + ((cast ,type ,expr) + (expr->accu expr info)) - ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b) - (let* ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))) - (type (ident->type info name)) - (ptr (ident->pointer info name)) - (size (if (> ptr 1) 4 1))) - (append-text info ((ident-add info) name size)))) + ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b) + (let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info)) + (type (ident->type info name)) + (ptr (ident->pointer info name)) + (size (if (> ptr 1) 4 1))) + (append-text info ((ident-add info) name size)))) - ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b) - (let* ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))) - (type (ident->type info name)) - (ptr (ident->pointer info name)) - (size (if (> ptr 1) 4 1))) - (append-text info ((ident-add info) name (- size))))) + ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b) + (let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info)) + (type (ident->type info name)) + (ptr (ident->pointer info name)) + (size (if (> ptr 1) 4 1))) + (append-text info ((ident-add info) name (- size))))) - ((assn-expr ,a (op ,op) ,b) - (let* ((info (append-text info (ast->comment o))) - (ptr-a (expr->pointer info a)) - (ptr-b (expr->pointer info b)) - (size-a (expr->size info a)) - (size-b (expr->size info b)) - (info ((expr->accu info) b)) - (info (if (equal? op "=") info - (let* ((ptr (expr->pointer info a)) - (ptr-b (expr->pointer info b)) - (type0 (expr->type info a)) - (struct? (memq (type:type (ast-type->type info type0)) '(struct union))) - (size (cond ((= ptr 1) (expr->type-size info a)) - ((> ptr 1) 4) - ((and struct? (= ptr -2)) 4) - ((and struct? (= ptr 2)) 4) - (else 1))) - (info (if (or (= size 1) (= ptr-b 1)) info - (let ((info (append-text info (wrap-as (i386:value->base size))))) - (append-text info (wrap-as (i386:accu*base)))))) - (info (append-text info (wrap-as (i386:push-accu)))) - (info ((expr->accu info) a)) - (info (append-text info (wrap-as (i386:pop-base)))) - (info (append-text info (cond ((equal? op "+=") (wrap-as (i386:accu+base))) - ((equal? op "-=") (wrap-as (i386:accu-base))) - ((equal? op "*=") (wrap-as (i386:accu*base))) - ((equal? op "/=") (wrap-as (i386:accu/base))) - ((equal? op "%=") (wrap-as (i386:accu%base))) - ((equal? op "&=") (wrap-as (i386:accu-and-base))) - ((equal? op "|=") (wrap-as (i386:accu-or-base))) - ((equal? op "^=") (wrap-as (i386:accu-xor-base))) - ((equal? op ">>=") (wrap-as (i386:accu>>base))) - ((equal? op "<<=") (wrap-as (i386:accu<type info b))))))))) - (when (and (equal? op "=") - (not (= size-a size-b)) - (not (and (or (= size-a 1) (= size-a 2)) - (= size-b 4))) - (not (and (= size-a 2) - (= size-b 4))) - (not (and (= size-a 4) - (or (= size-b 1) (= size-b 2))))) - (stderr "ERROR assign: ~a" (with-output-to-string (lambda () (pretty-print-c99 o)))) - (stderr " size[~a]:~a != size[~a]:~a\n" ptr-a size-a ptr-b size-b)) - (pmatch a - ((p-expr (ident ,name)) - (if (or (<= size-a 4) ;; FIXME: long long = int - (<= size-b 4)) (append-text info ((accu->ident info) name)) - (let ((info ((expr->base* info) a))) - (accu->base-mem*n info size-a)))) - (_ (let ((info ((expr->base* info) a))) - (accu->base-mem*n info (min size-a (max 4 size-b)))))))) ;; FIXME: long long = int + ((assn-expr ,a (op ,op) ,b) + (let* ((info (append-text info (ast->comment o))) + (ptr-a (expr->pointer info a)) + (ptr-b (expr->pointer info b)) + (size-a (expr->size info a)) + (size-b (expr->size info b)) + (info (expr->accu b info)) + (info (if (equal? op "=") info + (let* ((ptr (expr->pointer info a)) + (ptr-b (expr->pointer info b)) + (type (ast->type info a)) + (struct? (or (and (pair? type) (equal? (car type) "tag")) + (memq (type:type type) '(struct union)))) + (size (cond ((= ptr 1) (ast-type->size info a)) + ((> ptr 1) 4) + ((and struct? (= ptr -2)) 4) + ((and struct? (= ptr 2)) 4) + (else 1))) + (info (if (or (= size 1) (= ptr-b 1)) info + (let ((info (append-text info (wrap-as (i386:value->base size))))) + (append-text info (wrap-as (i386:accu*base)))))) + (info (append-text info (wrap-as (i386:push-accu)))) + (info (expr->accu a info)) + (info (append-text info (wrap-as (i386:pop-base)))) + (info (append-text info (cond ((equal? op "+=") (wrap-as (i386:accu+base))) + ((equal? op "-=") (wrap-as (i386:accu-base))) + ((equal? op "*=") (wrap-as (i386:accu*base))) + ((equal? op "/=") (wrap-as (i386:accu/base))) + ((equal? op "%=") (wrap-as (i386:accu%base))) + ((equal? op "&=") (wrap-as (i386:accu-and-base))) + ((equal? op "|=") (wrap-as (i386:accu-or-base))) + ((equal? op "^=") (wrap-as (i386:accu-xor-base))) + ((equal? op ">>=") (wrap-as (i386:accu>>base))) + ((equal? op "<<=") (wrap-as (i386:accu<type info b))))))))) + (when (and (equal? op "=") + (not (= size-a size-b)) + (not (and (or (= size-a 1) (= size-a 2)) + (= size-b 4))) + (not (and (= size-a 2) + (= size-b 4))) + (not (and (= size-a 4) + (or (= size-b 1) (= size-b 2))))) + (stderr "ERROR assign: ~a" (with-output-to-string (lambda () (pretty-print-c99 o)))) + (stderr " size[~a]:~a != size[~a]:~a\n" ptr-a size-a ptr-b size-b)) + (pmatch a + ((p-expr (ident ,name)) + (if (or (<= size-a 4) ;; FIXME: long long = int + (<= size-b 4)) (append-text info ((accu->ident info) name)) + (let ((info (expr->base* a info))) + (accu->base-mem*n info size-a)))) + (_ (let ((info (expr->base* a info))) + (accu->base-mem*n info (min size-a (max 4 size-b)))))))) ;; FIXME: long long = int - (_ (error "expr->accu: not supported: " o)))))) + (_ (error "expr->accu: not supported: " o))))) -(define (expr->base info) - (lambda (o) - (let* ((info (append-text info (wrap-as (i386:push-accu)))) - (info ((expr->accu info) o)) - (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu)))))) - info))) +(define (expr->base o info) + (let* ((info (append-text info (wrap-as (i386:push-accu)))) + (info (expr->accu o info)) + (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu)))))) + info)) -(define (expr->base* info) - (lambda (o) - (let* ((info (append-text info (wrap-as (i386:push-accu)))) - (info ((expr->accu* info) o)) - (info (append-text info (wrap-as (i386:accu->base)))) - (info (append-text info (wrap-as (i386:pop-accu))))) - info))) +(define (expr->base* o info) + (let* ((info (append-text info (wrap-as (i386:push-accu)))) + (info (expr->accu* o info)) + (info (append-text info (wrap-as (i386:accu->base)))) + (info (append-text info (wrap-as (i386:pop-accu))))) + info)) (define (comment? o) (and (pair? o) (pair? (car o)) (eq? (caar o) #:comment))) @@ -1396,7 +1347,7 @@ ((compd-stmt (block-item-list . ,elements)) (let ((clause (or clause (cases+jump info cases)))) (loop `(compd-stmt (block-item-list ,@(cdr elements))) cases - ((ast->info clause) (car elements))))) + (ast->info (car elements) clause)))) (() (let ((clause (or clause (cases+jump info cases)))) (if last? clause @@ -1406,12 +1357,12 @@ (_ (let ((clause (or clause (cases+jump info cases)))) (loop '() cases - ((ast->info clause) o)))))))) + (ast->info o clause)))))))) (define (test-jump-label->info info label) (define (jump type . test) (lambda (o) - (let* ((info ((ast->info info) o)) + (let* ((info (ast->info o info)) (info (append-text info (make-comment "jmp test LABEL"))) (jump-text (wrap-as (type label)))) (append-text info (append (if (null? test) '() (car test)) @@ -1485,8 +1436,8 @@ (define (expr->number info o) (pmatch o - ((p-expr (fixed ,a)) - (cstring->number a)) + ((fixed ,a) (cstring->number a)) + ((p-expr ,expr) (expr->number info expr)) ((neg ,a) (- (expr->number info a))) ((add ,a ,b) @@ -1522,12 +1473,14 @@ ((cast ,type ,expr) (expr->number info expr)) ((cond-expr ,test ,then ,else) (if (p-expr->bool info test) (expr->number info then) (expr->number info else))) + (,string (guard (string? string)) (cstring->number string)) (_ (error (format #f "expr->number: not supported: ~s\n" o))))) (define (p-expr->bool info o) (pmatch o ((eq ,a ,b) (eq? (expr->number info a) (expr->number info b))))) + (define (struct-field info) (lambda (o) (pmatch o @@ -1562,9 +1515,11 @@ (list (list name type (* count size) -2)))) ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (array-of (ident ,name) ,count)))) - (let ((size (ast-type->size info type)) - (count (expr->number info count))) - (list (list name type (* count size) -1)))) + (let* ((type (if (type? type) type + (ast->type info type))) + (size (ast-type->size info type)) + (count (expr->number info count))) + (list (list name type (* count size) -1)))) ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name))))) (list (list name `("tag" ,type) 4 2))) @@ -1604,33 +1559,6 @@ ((pointer (pointer (pointer))) 3) (_ (error "ptr-declr->pointer not supported: " o)))) -(define (init-declr->name o) - (pmatch o - ((ident ,name) name) - ((ptr-declr ,pointer (ident ,name)) name) - ((array-of (ident ,name)) name) - ((array-of (ident ,name) ,index) name) - ((ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,params)) name) - ((ptr-declr (pointer) (array-of (ident ,name))) name) - ((ptr-declr (pointer) (array-of (ident ,name) (p-expr ,size))) name) - (_ (error "init-declr->name not supported: " o)))) - -(define (init-declr->count info o) - (pmatch o - ((array-of (ident ,name) ,count) (expr->number info count)) - (_ #f))) - -(define (init-declr->pointer o) - (pmatch o - ((ident ,name) 0) - ((ptr-declr ,pointer (ident ,name)) (ptr-declr->pointer pointer)) - ((array-of (ident ,name) ,index) -2) - ((array-of (ident ,name)) -2) - ((ftn-declr (scope (ptr-declr ,pointer (ident ,name))) (param-list . ,params)) (ptr-declr->pointer pointer)) - ((ptr-declr (pointer) (array-of (ident ,name))) -2) - ((ptr-declr (pointer) (array-of (ident ,name) (p-expr ,size))) -2) - (_ (error "init-declr->pointer not supported: " o)))) - (define (statements->clauses statements) (let loop ((statements statements) (clauses '())) (if (null? statements) clauses @@ -1674,6 +1602,211 @@ (_ (loop2 (cdr statements) (append c (list s))))))))) (_ (error "statements->clauses: not supported:" s))))))) +(define (ast->info o info) + (let ((functions (.functions info)) + (globals (.globals info)) + (locals (.locals info)) + (constants (.constants info)) + (types (.types info)) + (text (.text info))) + (pmatch o + (((trans-unit . _) . _) (ast-list->info o info)) + ((trans-unit . ,_) (ast-list->info _ info)) + ((fctn-defn . ,_) (fctn-defn->info _ info)) + + ((cpp-stmt (define (name ,name) (repl ,value))) + info) + + ((cast (type-name (decl-spec-list (type-spec (void)))) _) + info) + + ((break) + (let ((label (car (.break info)))) + (append-text info (wrap-as (i386:jump label))))) + + ((continue) + (let ((label (car (.continue info)))) + (append-text info (wrap-as (i386:jump label))))) + + ;; FIXME: expr-stmt wrapper? + (trans-unit info) + ((expr-stmt) info) + + ((compd-stmt (block-item-list . ,_)) (ast-list->info _ info)) + + ((asm-expr ,gnuc (,null ,arg0 . string)) + (append-text info (wrap-as (asm->m1 arg0)))) + + ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))) + (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) + (append-text info (wrap-as (asm->m1 arg0)))) + (let* ((info (append-text info (ast->comment o))) + (info (expr->accu `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)) info))) + (append-text info (wrap-as (i386:accu-zero?)))))) + + ((if ,test ,then) + (let* ((info (append-text info (ast->comment `(if ,test (ellipsis))))) + (here (number->string (length text))) + (label (string-append "_" (.function info) "_" here "_")) + (break-label (string-append label "break")) + (else-label (string-append label "else")) + (info ((test-jump-label->info info break-label) test)) + (info (ast->info then info)) + (info (append-text info (wrap-as (i386:jump break-label)))) + (info (append-text info (wrap-as `((#:label ,break-label)))))) + (clone info + #:locals locals))) + + ((if ,test ,then ,else) + (let* ((info (append-text info (ast->comment `(if ,test (ellipsis) (ellipsis))))) + (here (number->string (length text))) + (label (string-append "_" (.function info) "_" here "_")) + (break-label (string-append label "break")) + (else-label (string-append label "else")) + (info ((test-jump-label->info info else-label) test)) + (info (ast->info then info)) + (info (append-text info (wrap-as (i386:jump break-label)))) + (info (append-text info (wrap-as `((#:label ,else-label))))) + (info (ast->info else info)) + (info (append-text info (wrap-as `((#:label ,break-label)))))) + (clone info + #:locals locals))) + + ;; Hmm? + ((expr-stmt (cond-expr ,test ,then ,else)) + (let* ((info (append-text info (ast->comment `(cond-expr ,test (ellipsis) (ellipsis))))) + (here (number->string (length text))) + (label (string-append "_" (.function info) "_" here "_")) + (else-label (string-append label "else")) + (break-label (string-append label "break")) + (info ((test-jump-label->info info else-label) test)) + (info (ast->info then info)) + (info (append-text info (wrap-as (i386:jump break-label)))) + (info (append-text info (wrap-as `((#:label ,else-label))))) + (info (ast->info else info)) + (info (append-text info (wrap-as `((#:label ,break-label)))))) + info)) + + ((switch ,expr (compd-stmt (block-item-list . ,statements))) + (let* ((info (append-text info (ast->comment `(switch ,expr (compd-stmt (block-item-list (ellipsis))))))) + (here (number->string (length text))) + (label (string-append "_" (.function info) "_" here "_")) + (break-label (string-append label "break")) + (clauses (statements->clauses statements)) + (info (expr->accu expr info)) + (info (clone info #:break (cons break-label (.break info)))) + (info (let loop ((clauses clauses) (i 0) (info info)) + (if (null? clauses) info + (loop (cdr clauses) (1+ i) ((clause->info info i label (null? (cdr clauses))) (car clauses)))))) + (info (append-text info (wrap-as `((#:label ,break-label)))))) + (clone info + #:locals locals + #:break (cdr (.break info))))) + + ((for ,init ,test ,step ,body) + (let* ((info (append-text info (ast->comment `(for ,init ,test ,step (ellipsis))))) + (here (number->string (length text))) + (label (string-append "_" (.function info) "_" here "_")) + (break-label (string-append label "break")) + (loop-label (string-append label "loop")) + (continue-label (string-append label "continue")) + (initial-skip-label (string-append label "initial_skip")) + (info (ast->info init info)) + (info (clone info #:break (cons break-label (.break info)))) + (info (clone info #:continue (cons continue-label (.continue info)))) + (info (append-text info (wrap-as (i386:jump initial-skip-label)))) + (info (append-text info (wrap-as `((#:label ,loop-label))))) + (info (ast->info body info)) + (info (append-text info (wrap-as `((#:label ,continue-label))))) + (info (expr->accu step info)) + (info (append-text info (wrap-as `((#:label ,initial-skip-label))))) + (info ((test-jump-label->info info break-label) test)) + (info (append-text info (wrap-as (i386:jump loop-label)))) + (info (append-text info (wrap-as `((#:label ,break-label)))))) + (clone info + #:locals locals + #:break (cdr (.break info)) + #:continue (cdr (.continue info))))) + + ((while ,test ,body) + (let* ((info (append-text info (ast->comment `(while ,test (ellipsis))))) + (here (number->string (length text))) + (label (string-append "_" (.function info) "_" here "_")) + (break-label (string-append label "break")) + (loop-label (string-append label "loop")) + (continue-label (string-append label "continue")) + (info (append-text info (wrap-as (i386:jump continue-label)))) + (info (clone info #:break (cons break-label (.break info)))) + (info (clone info #:continue (cons continue-label (.continue info)))) + (info (append-text info (wrap-as `((#:label ,loop-label))))) + (info (ast->info body info)) + (info (append-text info (wrap-as `((#:label ,continue-label))))) + (info ((test-jump-label->info info break-label) test)) + (info (append-text info (wrap-as (i386:jump loop-label)))) + (info (append-text info (wrap-as `((#:label ,break-label)))))) + (clone info + #:locals locals + #:break (cdr (.break info)) + #:continue (cdr (.continue info))))) + + ((do-while ,body ,test) + (let* ((info (append-text info (ast->comment `(do-while ,test (ellipsis))))) + (here (number->string (length text))) + (label (string-append "_" (.function info) "_" here "_")) + (break-label (string-append label "break")) + (loop-label (string-append label "loop")) + (continue-label (string-append label "continue")) + (info (clone info #:break (cons break-label (.break info)))) + (info (clone info #:continue (cons continue-label (.continue info)))) + (info (append-text info (wrap-as `((#:label ,loop-label))))) + (info (ast->info body info)) + (info (append-text info (wrap-as `((#:label ,continue-label))))) + (info ((test-jump-label->info info break-label) test)) + (info (append-text info (wrap-as (i386:jump loop-label)))) + (info (append-text info (wrap-as `((#:label ,break-label)))))) + (clone info + #:locals locals + #:break (cdr (.break info)) + #:continue (cdr (.continue info))))) + + ((labeled-stmt (ident ,label) ,statement) + (let ((info (append-text info `(((#:label ,(string-append "_" (.function info) "_label_" label))))))) + (ast->info statement info))) + + ((goto (ident ,label)) + (append-text info (wrap-as (i386:jump (string-append "_" (.function info) "_label_" label))))) + + ((return ,expr) + (let ((info (expr->accu expr info))) + (append-text info (append (wrap-as (i386:ret)))))) + + ((decl . ,decl) + ;;FIXME: ridiculous performance hit with mes + (let ((info (append-text info (ast->comment o)))) + (decl->info info decl))) + ;; ... + ((gt . _) (expr->accu o info)) + ((ge . _) (expr->accu o info)) + ((ne . _) (expr->accu o info)) + ((eq . _) (expr->accu o info)) + ((le . _) (expr->accu o info)) + ((lt . _) (expr->accu o info)) + ((lshift . _) (expr->accu o info)) + ((rshift . _) (expr->accu o info)) + + ;; EXPR + ((expr-stmt ,expression) + (let ((info (expr->accu expression info))) + (append-text info (wrap-as (i386:accu-zero?))))) + + ;; FIXME: why do we get (post-inc ...) here + ;; (array-ref + (_ (let ((info (expr->accu o info))) + (append-text info (wrap-as (i386:accu-zero?)))))))) + +(define (ast-list->info o info) + (fold ast->info info o)) + (define (global->static function) (lambda (o) (cons (car o) (set-field (cdr o) (global:function) function)))) @@ -1684,7 +1817,7 @@ (((decl-spec-list (stor-spec (static)) (type-spec ,type)) (init-declr-list ,init)) (let* ((function (.function info)) (i (clone info #:function #f #:globals '())) - (i ((decl->info i) `(decl (decl-spec-list (type-spec ,type)) (init-declr-list ,init)))) + (i ((decl->info i `(decl (decl-spec-list (type-spec ,type)) (init-declr-list ,init))))) (statics (map (global->static function) (.globals i)))) (clone info #:statics (append statics (.statics info))))) (_ #f)))) @@ -1693,660 +1826,234 @@ (lambda (o) #f)) -(define (decl->info info) - (lambda (o) - (let ((functions (.functions info)) - (globals (.globals info)) - (locals (.locals info)) - (constants (.constants info)) - (types (.types info)) - (text (.text info))) - (define (add-local locals name type pointer) - (let* ((id (if (or (null? locals) (not (local-var? (cdar locals)))) 1 - (1+ (local:id (cdar locals))))) - (locals (cons (make-local-entry name type pointer id) locals))) - locals)) - (define (declare name) - (if (member name functions) info - (let* ((type (function->type info o)) - (function (make-function name type #f))) - (clone info #:functions (cons (cons name function) functions))))) - - (pmatch o - - ;; FIXME: Nyacc sometimes produces extra parens: (ident ()) - ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list))))) - (declare name)) - - ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name)))) - (clone info #:types (cons (cons name (get-type info type)) types))) - - ;; int foo (); - ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list))))) - (declare name)) - - ;; void foo (); - ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list))))) - (declare name)) - - ;; void foo (*); - ((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list)))))) - (declare name)) - - ;; char *strcpy (); - ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list)))))) - (declare name)) - - ;; printf (char const* format, ...) - ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis)))))) - (declare name)) - - ;; tcc_new - ((decl (decl-spec-list ,type) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list)))))) - (declare name)) - - ;; extern type foo () - ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list))))) - (declare name)) - - ;; static - ((decl (decl-spec-list (stor-spec (static)) (type-spec ,type)) (init-declr-list ,init-declr-list)) - (guard (not (.function info))) - ((decl->info info) `(decl (decl-spec-list (type-spec ,type)) (init-declr-list ,init-declr-list)))) - - ;; struct TCCState; - ((decl (decl-spec-list (type-spec (struct-ref (ident ,name))))) - info) - - ;; extern type global; - ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ident ,name)))) - info) - - ((decl (decl-spec-list (stor-spec (static)) ,type) (init-declr-list (init-declr (ident ,name)))) - ((decl->info info) `(decl (decl-spec-list ,type) (init-declr-list (init-declr (ident ,name))))) - info) - - ;; extern foo *bar; - ((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name))))) - info) - - ((decl (decl-spec-list (stor-spec (static)) ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name))))) - ((decl->info info) `(decl (decl-spec-list ,type) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name))))))) - - ;; ST_DATA int ch, tok; -- TCC, why oh why so difficult? - ((decl (decl-spec-list (stor-spec (extern)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest)) - info) - - ;; ST_DATA Section *text_section, *data_section, *bss_section; /* predefined sections */ - ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name))) . ,rest)) - info) - - ;; ST_DATA CType char_pointer_type, func_old_type, int_type, size_type; - ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest)) - info) - - ;; ST_DATA SValue __vstack[1+/*to make bcheck happy*/ VSTACK_SIZE], *vtop; - ;; Yay, let's hear it for the T-for Tiny in TCC!? - ((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (array-of (ident ,name) (add (p-expr (fixed ,a)) (p-expr (fixed ,b))))) (init-declr (ptr-declr (pointer) (ident ,name2))))) - info) - - ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))) - (clone info #:types (cons (cons name (or (get-type info type) `(typedef ("tag" ,type)))) types))) - - ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))) - (clone info #:types (cons (cons name (or (get-type info type) `(typedef ("tag" ,type)))) types))) - - ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name)))) - (clone info #:types (cons (cons name (or (get-type info type) `(typedef ,type))) types))) - - ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename ,type))) (init-declr-list (init-declr (array-of (ident ,name) ,value)))) - (let* ((type (get-type info type)) - (value (expr->number info value)) - (size (* value 4)) - (pointer -1) - (type (make-type 'array size pointer type))) - (clone info #:types (cons (cons name type) types)))) - - ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name))))) - (let* ((pointer (expr->pointer info pointer)) - (type (or (get-type info type) `(typedef ,type))) - (size 4) - (type (make-type 'typedef size pointer type))) - (clone info #:types (cons (cons name type) types)))) - - ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def ,field-list))) (init-declr-list (init-declr (ident ,name)))) - ((decl->info info) `(decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def (ident ,name) ,field-list))) (init-declr-list (init-declr (ident ,name)))))) - - ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def ,field-list))) (init-declr-list (init-declr (ident ,name)))) - ((decl->info info) `(decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def (ident ,name) ,field-list))) (init-declr-list (init-declr (ident ,name)))))) - - ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def (ident ,type) ,field-list))) (init-declr-list (init-declr (ident ,name)))) - (let* ((info ((decl->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) ,field-list)))))) - (types (.types info))) - (clone info #:types (cons (cons name (or (get-type info `("tag" ,type)) `(typedef ,type))) types)))) - - ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def (ident ,type) ,field-list))) (init-declr-list (init-declr (ident ,name)))) - (let* ((info ((decl->info info) `(decl (decl-spec-list (type-spec (union-def (ident ,type) ,field-list)))))) - (types (.types info))) - (clone info #:types (cons (cons name (or (get-type info `("tag" ,type)) `(typedef ,type))) types)))) - - ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name))))) - (let* ((type (get-type info type)) - (type (make-type (type:type type) - (type:size type) - (1+ (type:pointer type)) - (type:description type))) - (type-entry (cons name type))) - (clone info #:types (cons type-entry types)))) - - ;; struct - ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields))))) - (let ((type-entry (struct->type-entry name (append-map (struct-field info) fields)))) - (clone info #:types (cons type-entry types)))) - - ;; union - ((decl (decl-spec-list (type-spec (union-def (ident ,name) (field-list . ,fields))))) - (let ((type-entry (union->type-entry name (append-map (struct-field info) fields)))) - (clone info #:types (cons type-entry types)))) - - ;; enum e i; - ((decl (decl-spec-list (type-spec (enum-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))) - (let ((type "int")) ;; FIXME - (if (.function info) - (clone info #:locals (add-local locals name type 0)) - (clone info #:globals (append globals (list (ident->global-entry name type 0 0))))))) - - ;; struct foo bar[2]; - ;; char arena[20000]; - ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) ,count)))) - (let ((type (ast->type type))) - (if (.function info) - (let* ((local (car (add-local locals name type -1))) - (count (expr->number info count)) - (size (ast-type->size info type)) - (pointer (expr->pointer info `(type-spec ,type))) - (pointer (- -1 pointer)) - (local (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4)))) - (locals (cons local locals)) - (info (clone info #:locals locals))) - info) - (let* ((foo (mescc:trace name " ")) - (globals (.globals info)) - (count (expr->number info count)) - (size (ast-type->size info type)) - (pointer (expr->pointer info `(type-spec ,type))) - (pointer (- -1 pointer)) - (array (make-global-entry name type pointer (string->list (make-string (* count size) #\nul)))) - (globals (append globals (list array)))) - (clone info #:globals globals))))) - - ;; struct foo *bar[2]; - ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name) ,count))))) - (let ((type (ast->type type))) - (if (.function info) - (let* ((local (car (add-local locals name type -1))) - (count (expr->number info count)) - (size 4) - (pointer (expr->pointer info `(type-spec ,type))) - (pointer (- -3 pointer)) - (local (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4)))) - (locals (cons local locals)) - (info (clone info #:locals locals))) - info) - (let* ((foo (mescc:trace name " ")) - (globals (.globals info)) - (count (expr->number info count)) - (size 4) - (pointer (expr->pointer info `(type-spec ,type))) - (pointer (- -3 pointer)) - (global (make-global-entry name type pointer (string->list (make-string (* count size) #\nul)))) - (globals (append globals (list global)))) - (clone info #:globals globals))))) - - ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,size))) (initzer (p-expr (string ,string)))))) - (if (.function info) - (error "TODO: " o) - (let* ((foo (mescc:trace name " ")) - (globals (.globals info)) - ;; (count (cstring->number count)) - ;; (size (ast-type->size info type)) - (array (make-global-entry name type -1 (string->list string))) - (globals (append globals (list array)))) - (clone info #:globals globals)))) - - ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function; - ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,param-list)) (initzer ,initzer)))) - (let* ((locals (add-local locals name type 1)) - (info (clone info #:locals locals)) - (empty (clone info #:text '())) - (accu ((expr->accu empty) initzer))) - (clone info - #:text - (append text - (.text accu) - ((accu->ident info) name) - (wrap-as (append (i386:label->base `(#:address "_start")) - (i386:accu+base)))) - #:locals locals))) - - ;; char *p = g_cells; - ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value)))))) - (let ((info (append-text info (ast->comment o))) - (type (decl->ast-type type))) - (if (.function info) - (let* ((locals (add-local locals name type 1)) - (info (clone info #:locals locals))) - (append-text info (append ((ident->accu info) value) - ((accu->ident info) name)))) - (let ((globals (append globals (list (ident->global-entry name type 1 `(,value #f #f #f)))))) - (clone info #:globals globals))))) - - ;; enum foo { }; - ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields))))) - (let ((type-entry (enum->type-entry name fields)) - (constants (enum-def-list->constants constants fields))) - (clone info - #:types (cons type-entry types) - #:constants (append constants (.constants info))))) - - ;; enum {}; - ((decl (decl-spec-list (type-spec (enum-def (enum-def-list . ,fields))))) - (let ((constants (enum-def-list->constants constants fields))) - (clone info - #:constants (append constants (.constants info))))) - - ((decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields)))) - (init-declr-list (init-declr (ident ,name)))) - (let ((info ((decl->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields)))))))) - ((decl->info info) `(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))))) - - ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (union-def (ident ,type) ,fields))) (init-declr-list (init-declr (ident ,name)))) - (let ((info ((decl->info info) `(decl (decl-spec-list (type-spec (union-def (ident ,type) ,fields))))))) - ((decl->info info) `(decl (decl-spec-list (type-spec (union-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))))) - - ;; struct f = {...}; - ;; LOCALS! - ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers))))) - (if (not (.function info)) (mescc:trace name " ")) - (let* ((info (append-text info (ast->comment o))) - (type (decl->ast-type type)) - (fields (ast-type->description info type)) - (xtype (ast-type->type info type)) - (fields (if (not (eq? (type:type xtype) 'union)) fields - (list-head fields 1))) - (size (ast-type->size info type)) - (initzers (map (initzer->non-const info) initzers))) - (if (.function info) - (let* ((initzer-globals (filter identity (append-map (initzer->globals globals) initzers))) - (global-names (map car globals)) - (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals)) - (globals (append globals initzer-globals)) - (local (car (add-local locals name type -1))) - (local (make-local-entry name type -1 (+ (local:id (cdr local)) (quotient (+ size 3) 4)))) - (locals (cons local locals)) - (info (clone info #:locals locals #:globals globals)) - (empty (clone info #:text '()))) - (let loop ((fields fields) (initzers initzers) (info info)) - (if (null? fields) info - (let ((offset (field-offset info type (field:name (car fields)))) - (size (field:size (car fields))) - (initzer (if (null? initzers) '(p-expr (fixed "0")) (car initzers)))) - (loop (cdr fields) (if (null? initzers) '() (cdr initzers)) - (clone info #:text - (append - (.text info) - ((ident->accu info) name) - (wrap-as (append (i386:accu->base))) - (.text ((expr->accu empty) initzer)) - (wrap-as (case size - ((1) (i386:byte-accu->base-mem+n offset)) - ((2) (i386:word-accu->base-mem+n offset)) - (else (i386:accu->base-mem+n offset))))))))))) - (let* ((initzer-globals (filter identity (append-map (initzer->globals globals) initzers))) - (global-names (map car globals)) - (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals)) - (globals (append globals initzer-globals)) - (global (make-global-entry name type -1 (append-map (initzer->data info) initzers))) - (globals (append globals (list global)))) - (clone info #:globals globals))))) - - ;; DECL - ;; char *bla[] = {"a", "b"}; - ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name))) (initzer (initzer-list . ,initzers))))) - (if (not (.function info)) (mescc:trace name " ")) - (let* ((type (decl->ast-type type)) - (pointer (expr->pointer info `(type-spec ,type))) - (pointer (- -3 pointer)) - (entries (filter identity (append-map (initzer->globals globals) initzers))) - (global-names (map car globals)) - (entries (filter (lambda (g) (and g (not (member (car g) global-names)))) entries)) - (globals (append globals entries)) - (entry-size 4) - (size (* (length entries) entry-size)) - (initzers (map (initzer->non-const info) initzers))) - (if (.function info) - (let* ((count (length initzers)) - (local (car (add-local locals name type -1))) - (local (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (1+ count)))) - (locals (cons local locals)) - (info (clone info #:locals locals)) - (info (clone info #:globals globals)) - (empty (clone info #:text '()))) - (let loop ((index 0) (initzers initzers) (info info)) - (if (null? initzers) info - (let ((offset (* index 4)) - (initzer (car initzers))) - (loop (1+ index) (cdr initzers) - (clone info #:text - (append - (.text info) - ((ident->accu info) name) - (wrap-as (append (i386:accu->base))) - (.text ((expr->accu empty) initzer)) - (wrap-as (i386:accu->base-mem+n offset))))))))) - (let* ((global (make-global-entry name type pointer (append-map (initzer->data info) initzers))) - (globals (append globals (list global)))) - (clone info #:globals globals))))) - - ;; int foo[2] = { ... } - ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) ,count) (initzer (initzer-list . ,initzers))))) - (if (not (.function info)) (mescc:trace name " ")) - (let* ((info (type->info info type)) - (xtype type) - (type (decl->ast-type type)) - (pointer (expr->pointer info `(type-spec ,type))) - (pointer (- -2 pointer)) - (initzer-globals (filter identity (append-map (initzer->globals globals) initzers))) - (global-names (map car globals)) - (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals)) - (initzers ((initzer->non-const info) initzers)) - (info (append-text info (ast->comment o))) - (globals (append globals initzer-globals)) - (info (clone info #:globals globals)) - (type-size (if (<= pointer 0) (ast-type->size info type) - 4)) - (count (expr->number info count)) - (size (* count type-size))) - (if (.function info) - (let* ((local (car (add-local locals name type 1))) - (local (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4)))) - (locals (cons local locals)) - (local (cdr local)) - (info (clone info #:locals locals)) - (info (let loop ((info info) (initzers initzers) (n 0)) - (if (null? initzers) info - (let* ((info ((initzer->accu info) (car initzers))) - (info ((accu->local+n info local) n))) - (loop info (cdr initzers) (+ n type-size))))))) - info) - (let* ((global (make-global-entry name type pointer (append-map (initzer->data info) initzers))) - (globals (append globals (list global)))) - (clone info #:globals globals))))) - - ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr ,init . ,initzer))) - (let* ((info (type->info info type)) - (xtype type) - (type (decl->ast-type type)) - (name (init-declr->name init)) - (foo (if (not (.function info)) (mescc:trace name " "))) - (pointer (init-declr->pointer init)) - (initzer-globals (if (null? initzer) '() - (filter identity (append-map (initzer->globals globals) initzer)))) - (global-names (map car globals)) - (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals)) - (initzer (if (null? initzer) '() ((initzer->non-const info) initzer))) - ;;FIXME: ridiculous performance hit with mes - (info (append-text info (ast->comment o))) - (globals (append globals initzer-globals)) - (info (clone info #:globals globals)) - (struct? (and (zero? pointer) - (or (and (pair? type) (equal? (car type) "tag")) - (memq (type:type (ast-type->type info xtype)) '(struct union))))) - (pointer (if struct? -1 pointer)) - (size (if (<= pointer 0) (ast-type->size info type) - 4)) - (count (init-declr->count info init)) ; array... split me up? - (size (if count (* count size) size))) - (if (.function info) - (let* ((locals (if (or (> pointer 0) (<= size 4)) (add-local locals name type pointer) - (let* ((local (car (add-local locals name type 1))) - (local (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4))))) - (cons local locals)))) - (info (clone info #:locals locals)) - (info (if (null? initzer) info ((initzer->accu info) (car initzer)))) - ;; FIXME array...struct? - (info (if (null? initzer) info (append-text info ((accu->ident info) name))))) - info) - (let* ((global (make-global-entry name type pointer (if (null? initzer) (string->list (make-string size #\nul)) - (append-map (initzer->data info) initzer)))) - (globals (append globals (list global)))) - (clone info #:globals globals))))) - - ((decl (decl-spec-list (type-spec ,type)) (init-declr-list . ,inits)) - (let loop ((inits inits) (info info)) - (if (null? inits) info - (loop (cdr inits) - ((decl->info info) - `(decl (decl-spec-list (type-spec ,type)) (init-declr-list ,(car inits)))))))) - - ((decl (decl-spec-list (stor-spec (static)) (type-spec ,type)) ,init) - ((decl->info info) `(decl (decl-spec-list (type-spec ,type)) ,init))) - - ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name) - (format (current-error-port) "SKIP: typedef=~s\n" o) - info) - - ((decl (@ ,at)) - (format (current-error-port) "SKIP: at=~s\n" o) - info) - - ((decl . _) (error "decl->info: not supported: " o)))))) - -(define (ast->info info) - (lambda (o) - (let ((functions (.functions info)) - (globals (.globals info)) - (locals (.locals info)) - (constants (.constants info)) - (types (.types info)) - (text (.text info))) - (pmatch o - (((trans-unit . _) . _) - ((ast-list->info info) o)) - ((trans-unit . ,elements) - ((ast-list->info info) elements)) - ((fctn-defn . _) ((function->info info) o)) - ((cpp-stmt (define (name ,name) (repl ,value))) - info) - - ((cast (type-name (decl-spec-list (type-spec (void)))) _) - info) - - ((break) - (let ((label (car (.break info)))) - (append-text info (wrap-as (i386:jump label))))) - - ((continue) - (let ((label (car (.continue info)))) - (append-text info (wrap-as (i386:jump label))))) - - ;; FIXME: expr-stmt wrapper? - (trans-unit info) - ((expr-stmt) info) - - ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements)) - - ((asm-expr ,gnuc (,null ,arg0 . string)) - (append-text info (wrap-as (asm->m1 arg0)))) - - ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))) - (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) - (append-text info (wrap-as (asm->m1 arg0)))) - (let* ((info (append-text info (ast->comment o))) - (info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))))) - (append-text info (wrap-as (i386:accu-zero?)))))) - - ((if ,test ,then) - (let* ((info (append-text info (ast->comment `(if ,test (ellipsis))))) - (here (number->string (length text))) - (label (string-append "_" (.function info) "_" here "_")) - (break-label (string-append label "break")) - (else-label (string-append label "else")) - (info ((test-jump-label->info info break-label) test)) - (info ((ast->info info) then)) - (info (append-text info (wrap-as (i386:jump break-label)))) - (info (append-text info (wrap-as `((#:label ,break-label)))))) - (clone info - #:locals locals))) - - ((if ,test ,then ,else) - (let* ((info (append-text info (ast->comment `(if ,test (ellipsis) (ellipsis))))) - (here (number->string (length text))) - (label (string-append "_" (.function info) "_" here "_")) - (break-label (string-append label "break")) - (else-label (string-append label "else")) - (info ((test-jump-label->info info else-label) test)) - (info ((ast->info info) then)) - (info (append-text info (wrap-as (i386:jump break-label)))) - (info (append-text info (wrap-as `((#:label ,else-label))))) - (info ((ast->info info) else)) - (info (append-text info (wrap-as `((#:label ,break-label)))))) - (clone info - #:locals locals))) - - ;; Hmm? - ((expr-stmt (cond-expr ,test ,then ,else)) - (let* ((info (append-text info (ast->comment `(cond-expr ,test (ellipsis) (ellipsis))))) - (here (number->string (length text))) - (label (string-append "_" (.function info) "_" here "_")) - (else-label (string-append label "else")) - (break-label (string-append label "break")) - (info ((test-jump-label->info info else-label) test)) - (info ((ast->info info) then)) - (info (append-text info (wrap-as (i386:jump break-label)))) - (info (append-text info (wrap-as `((#:label ,else-label))))) - (info ((ast->info info) else)) - (info (append-text info (wrap-as `((#:label ,break-label)))))) - info)) - - ((switch ,expr (compd-stmt (block-item-list . ,statements))) - (let* ((info (append-text info (ast->comment `(switch ,expr (compd-stmt (block-item-list (ellipsis))))))) - (here (number->string (length text))) - (label (string-append "_" (.function info) "_" here "_")) - (break-label (string-append label "break")) - (clauses (statements->clauses statements)) - (info ((expr->accu info) expr)) - (info (clone info #:break (cons break-label (.break info)))) - (info (let loop ((clauses clauses) (i 0) (info info)) - (if (null? clauses) info - (loop (cdr clauses) (1+ i) ((clause->info info i label (null? (cdr clauses))) (car clauses)))))) - (info (append-text info (wrap-as `((#:label ,break-label)))))) - (clone info - #:locals locals - #:break (cdr (.break info))))) - - ((for ,init ,test ,step ,body) - (let* ((info (append-text info (ast->comment `(for ,init ,test ,step (ellipsis))))) - (here (number->string (length text))) - (label (string-append "_" (.function info) "_" here "_")) - (break-label (string-append label "break")) - (loop-label (string-append label "loop")) - (continue-label (string-append label "continue")) - (initial-skip-label (string-append label "initial_skip")) - (info ((ast->info info) init)) - (info (clone info #:break (cons break-label (.break info)))) - (info (clone info #:continue (cons continue-label (.continue info)))) - (info (append-text info (wrap-as (i386:jump initial-skip-label)))) - (info (append-text info (wrap-as `((#:label ,loop-label))))) - (info ((ast->info info) body)) - (info (append-text info (wrap-as `((#:label ,continue-label))))) - (info ((expr->accu info) step)) - (info (append-text info (wrap-as `((#:label ,initial-skip-label))))) - (info ((test-jump-label->info info break-label) test)) - (info (append-text info (wrap-as (i386:jump loop-label)))) - (info (append-text info (wrap-as `((#:label ,break-label)))))) - (clone info - #:locals locals - #:break (cdr (.break info)) - #:continue (cdr (.continue info))))) - - ((while ,test ,body) - (let* ((info (append-text info (ast->comment `(while ,test (ellipsis))))) - (here (number->string (length text))) - (label (string-append "_" (.function info) "_" here "_")) - (break-label (string-append label "break")) - (loop-label (string-append label "loop")) - (continue-label (string-append label "continue")) - (info (append-text info (wrap-as (i386:jump continue-label)))) - (info (clone info #:break (cons break-label (.break info)))) - (info (clone info #:continue (cons continue-label (.continue info)))) - (info (append-text info (wrap-as `((#:label ,loop-label))))) - (info ((ast->info info) body)) - (info (append-text info (wrap-as `((#:label ,continue-label))))) - (info ((test-jump-label->info info break-label) test)) - (info (append-text info (wrap-as (i386:jump loop-label)))) - (info (append-text info (wrap-as `((#:label ,break-label)))))) - (clone info - #:locals locals - #:break (cdr (.break info)) - #:continue (cdr (.continue info))))) - - ((do-while ,body ,test) - (let* ((info (append-text info (ast->comment `(do-while ,test (ellipsis))))) - (here (number->string (length text))) - (label (string-append "_" (.function info) "_" here "_")) - (break-label (string-append label "break")) - (loop-label (string-append label "loop")) - (continue-label (string-append label "continue")) - (info (clone info #:break (cons break-label (.break info)))) - (info (clone info #:continue (cons continue-label (.continue info)))) - (info (append-text info (wrap-as `((#:label ,loop-label))))) - (info ((ast->info info) body)) - (info (append-text info (wrap-as `((#:label ,continue-label))))) - (info ((test-jump-label->info info break-label) test)) - (info (append-text info (wrap-as (i386:jump loop-label)))) - (info (append-text info (wrap-as `((#:label ,break-label)))))) - (clone info - #:locals locals - #:break (cdr (.break info)) - #:continue (cdr (.continue info))))) - - ((labeled-stmt (ident ,label) ,statement) - (let ((info (append-text info `(((#:label ,(string-append "_" (.function info) "_label_" label))))))) - ((ast->info info) statement))) - - ((goto (ident ,label)) - (append-text info (wrap-as (i386:jump (string-append "_" (.function info) "_label_" label))))) - - ((return ,expr) - (let ((info ((expr->accu info) expr))) - (append-text info (append (wrap-as (i386:ret)))))) - - ((decl . ,decl) - (or (if (.function info) - ((decl-local->info info) decl) - ((decl-global->info info) decl)) - ((decl->info info) o))) - - ;; ... - ((gt . _) ((expr->accu info) o)) - ((ge . _) ((expr->accu info) o)) - ((ne . _) ((expr->accu info) o)) - ((eq . _) ((expr->accu info) o)) - ((le . _) ((expr->accu info) o)) - ((lt . _) ((expr->accu info) o)) - ((lshift . _) ((expr->accu info) o)) - ((rshift . _) ((expr->accu info) o)) - - ;; EXPR - ((expr-stmt ,expression) - (let ((info ((expr->accu info) expression))) - (append-text info (wrap-as (i386:accu-zero?))))) - - ;; FIXME: why do we get (post-inc ...) here - ;; (array-ref - (_ (let ((info ((expr->accu info) o))) - (append-text info (wrap-as (i386:accu-zero?))))))))) +(define (decl->info info o) + (pmatch o + (((decl-spec-list (type-spec ,type)) (init-declr-list . ,inits)) + (let* ((info (type->info info type)) + (type (ast->type info type)) + (pointer 0)) ; FIXME + (fold (cut init-declr->info type pointer <> <>) info (map cdr inits)))) + (((decl-spec-list (type-spec ,type))) + (type->info info type)) + (((decl-spec-list (stor-spec (typedef)) (type-spec ,type)) (init-declr-list (init-declr (ident ,name)))) + (let* ((info (type->info info type)) + (type (ast->type info type))) + (clone info #:types (acons name type (.types info))))) + (((decl-spec-list (stor-spec (,store)) (type-spec ,type)) (init-declr-list . ,inits)) + (let* ((type (ast->type info type)) + (pointer 0) ; FIXME + (function (.function info)) + (tmp (clone info #:function #f #:globals '())) + (tmp (fold (cut init-declr->info type pointer <> <>) tmp (map cdr inits))) + (statics (map (global->static function) (.globals tmp)))) + (clone info #:statics (append statics (.statics info))))) + (((@ . _)) + (stderr "decl->info: skip: ~s\n" o) + info) + (_ (error "decl->info: not supported:" o)))) + +(define (ast->name o) + (pmatch o + ((ident ,name) name) + ((ptr-declr ,pointer (ident ,name)) name) + ((array-of ,array . ,_) (ast->name array)) + ((ftn-declr (scope (ptr-declr ,pointer (ident ,name)))) name) + ((ptr-declr ,pointer ,decl . ,_) (ast->name decl)) + (_ (error "ast->name not supported: " o)))) + +(define (init-declr->count info o) + (pmatch o + ((array-of (ident ,name) ,count) (expr->number info count)) + (_ #f))) + +(define (init->accu o info) + (pmatch o + ((initzer-list (initzer ,expr)) (expr->accu expr info)) + (((#:string ,string)) + (append-text info (list (i386:label->accu `(#:string ,string))))) + ((,number . _) (guard (number? number)) + (append-text info (wrap-as (i386:value->accu 0)))) + ((,c . ,_) (guard (char? c)) info) + (_ (expr->accu o info)))) + +(define (init-struct-field local field init info) + (let* ((offset (field-offset info (local:type local) (car field))) + (pointer (field:pointer field)) + (size (field:size field)) + (empty (clone info #:text '()))) + (clone info #:text + (append + (.text info) + (local->accu local) + (wrap-as (append (i386:accu->base))) + (wrap-as (append (i386:push-base))) + (.text (expr->accu init empty)) + (wrap-as (append (i386:pop-base))) + (wrap-as (case size + ((1) (i386:byte-accu->base-mem+n offset)) + ((2) (i386:word-accu->base-mem+n offset)) + (else (i386:accu->base-mem+n offset)))))))) + +(define (init-array-entry local index init info) + (let* ((size (or (and (zero? (local:pointer local)) ((compose type:size local:type) local)) + 4)) + (offset (* index size)) + (empty (clone info #:text '()))) + (clone info #:text + (append + (.text info) + (local->accu local) + (wrap-as (append (i386:accu->base))) + (wrap-as (append (i386:push-base))) + (.text (expr->accu init empty)) + (wrap-as (append (i386:pop-base))) + (wrap-as (case size + ((1) (i386:byte-accu->base-mem+n offset)) + ((2) (i386:word-accu->base-mem+n offset)) + (else (i386:accu->base-mem+n offset)))))))) + +(define (init-local local o n info) + (pmatch o + (#f info) + ((initzer ,init) + (init-local local init n info)) + ((initzer-list ,init) + (init-local local init n info)) + ((initzer-list . ,inits) + (let* ((type ((compose type:type local:type) local)) + (struct? (or (and (pair? type) (equal? (car type) "tag")) + (memq type '(struct union))))) + (cond (struct? + (let ((fields ((compose struct->fields local:type) local))) + (fold (cut init-struct-field local <> <> <>) info fields (append inits (map (const '(p-expr (fixed "22"))) (iota (max 0 (- (length fields) (length inits))))))))) + (else (fold (cut init-local local <> <> <>) info inits (iota (length inits))))))) + (((initzer (initzer-list . ,inits))) + (fold (cut init-array-entry local <> <> <>) info (iota (length inits)) inits)) + (() info) + (_ (let ((info (init->accu o info))) + (append-text info (accu->local+n-text local n)))))) + +(define (local->info type pointer array name o init info) + (let* ((locals (.locals info)) + (id (if (or (null? locals) (not (local-var? (cdar locals)))) 1 + (1+ (local:id (cdar locals))))) + (local (make-local-entry name type pointer array id)) + (struct? (and (or (zero? pointer) + (= -1 pointer)) + (or (and (pair? type) + (equal? (car type) "tag")) + (and (type? type) + (memq (type:type type) '(struct union)))))) + (size (or (and (zero? pointer) (type? type) (type:size type)) + (and struct? (and=> (ast->type info type) struct:size)) + 4)) + (local (if (not array) local + (make-local-entry name type pointer array (+ (local:id (cdr local)) -1 (quotient (+ (* array size) 3) 4))))) + (local (if struct? (make-local-entry name type -1 array (+ (local:id (cdr local)) (quotient (+ size 3) 4))) + local)) + (locals (cons local locals)) + (info (clone info #:locals locals)) + (local (cdr local))) + (init-local local init 0 info))) + +(define (global->info type pointer array name o init info) + (let* ((size (cond ((type? type) (type:size type)) + ((not (zero? pointer)) 4) + (else (error "global->info: no such type:" type)))) + (data (cond ((not init) (string->list (make-string size #\nul))) + (array (array-init->data (and array (* array (type:size type))) init info)) + (else (let ((data (init->data init info))) + (append data (string->list (make-string (max 0 (- size (length data))) #\nul))))))) + (global (make-global-entry name type pointer array data))) + (clone info #:globals (append (.globals info) (list global))))) + +(define (array-init-element->data size o info) + (pmatch o + ((initzer (p-expr (string ,string))) + `((#:string ,string))) + ((initzer (p-expr (fixed ,fixed))) + (int->bv32 (expr->number info fixed))) + (_ (init->data o info)) + ;;(_ (error "array-init-element->data: not supported: " o)) + )) + +(define (array-init->data size o info) + (pmatch o + (((initzer (initzer-list . ,inits))) + (map (cut array-init-element->data size <> info) inits)) + + ((initzer (p-expr (string ,string))) + (let ((data (string->list string))) + (if (not size) data + (append data (string->list (make-string (max 0 (- size (length data))) #\nul)))))) + + (((initzer (p-expr (string ,string)))) + (let ((data (string->list string))) + (if (not size) data + (append data (string->list (make-string (max 0 (- size (length data))) #\nul)))))) + + ((initzer (p-expr (fixed ,fixed))) + (int->bv32 (expr->number info fixed))) + + (() (string->list (make-string size #\nul))) + (_ (error "array-init->data: not supported: " o)))) + +(define (init-declr->info type pointer o info) + (pmatch o + (((ident ,name)) + (if (.function info) (local->info type pointer #f name o #f info) + (global->info type pointer #f name o #f info))) + (((ident ,name) (initzer ,init)) + (let* ((strings (init->strings init info)) + (info (if (null? strings) info + (clone info #:globals (append (.globals info) strings)))) + (struct? (and (zero? pointer) + (or (and (pair? type) (equal? (car type) "tag")) + (memq (type:type type) '(struct union))))) + (pointer (if struct? (- (1+ (abs pointer))) pointer))) + (if (.function info) (local->info type pointer #f name o init info) + (global->info type pointer #f name o init info)))) + (((ftn-declr (ident ,name) . ,_)) + (let ((functions (.functions info))) + (if (member name functions) info + (let* ((type (ftn-declr:get-type info `(ftn-declr (ident ,name) ,@_))) + (function (make-function name type #f))) + (clone info #:functions (cons (cons name function) functions)))))) + (((ftn-declr (scope (ptr-declr ,p (ident ,name))) ,param-list) ,init) + + (let ((pointer (+ pointer (pointer->ptr p)))) + (if (.function info) (local->info type pointer #f name o init info) + (global->info type pointer #f name o init info)))) + (((ptr-declr ,p . ,_) . ,init) + (let ((pointer (+ pointer (pointer->ptr p)))) + (init-declr->info type pointer (append _ init) info))) + (((array-of (ident ,name) ,array) . ,init) + (let* ((strings (init->strings init info)) + (info (if (null? strings) info + (clone info #:globals (append (.globals info) strings)))) + (array (expr->number info array)) + (pointer (- (1+ pointer)))) + (if (.function info) (local->info type pointer array name o init info) + (global->info type pointer array name o init info)))) + (((array-of (ident ,name)) . ,init) + (let* ((strings (init->strings init info)) + (info (if (null? strings) info + (clone info #:globals (append (.globals info) strings)))) + (pointer (- (1+ pointer)))) + (if (.function info) (local->info type pointer (length (cadar init)) name o init info) + (global->info type pointer #f name o init info)))) + + ;; FIXME: recursion + (((array-of (array-of (ident ,name) ,array) ,array1) . ,init) + (let* ((strings (init->strings init info)) + (info (if (null? strings) info + (clone info #:globals (append (.globals info) strings)))) + (array (expr->number info array)) + (pointer (- (+ 2 pointer)))) + (if (.function info) (local->info type pointer array name o init info) + (global->info type pointer array name o init info)))) + + (_ (error "init-declr->info: not supported: " o)))) (define (enum-def-list->constants constants fields) (let loop ((fields fields) (i 0) (constants constants)) @@ -2365,85 +2072,104 @@ (1+ i) (append constants (list (ident->constant name i)))))))) -(define (initzer->non-const info) - (lambda (o) - (pmatch o - ((initzer (p-expr (ident ,name))) - (let ((value (assoc-ref (.constants info) name))) - `(initzer (p-expr (fixed ,(number->string value)))))) - (_ o)))) +(define (init->data o info) + (pmatch o + ((p-expr ,expr) (init->data expr info)) + ((fixed ,fixed) (int->bv32 (expr->number info o))) + ((char ,char) (int->bv32 (char->integer (string-ref char 0)))) + ((string ,string) `((#:string ,string))) + ((string . ,strings) `((#:string ,(string-join strings "")))) + ((ident ,name) (let ((var (ident->variable info name))) + `((#:address ,var)))) + ((initzer-list . ,initzers) (append-map (cut init->data <> info) initzers)) + (((initzer (initzer-list . ,inits))) + (init->data `(initzer-list . ,inits) info)) + ((ref-to (p-expr (ident ,name))) + (let ((var (ident->variable info name))) + `((#:address ,var)))) + ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base))))) + (let* ((type (ast->type info struct)) + (offset (field-offset info type field)) + (base (cstring->number base))) + (int->bv32 (+ base offset)))) + ((,char . _) (guard (char? char)) o) + ((,number . _) (guard (number? number)) + (append (map int->bv32 o))) + ((initzer ,init) (init->data init info)) + (_ (error "init->data: not supported: " o)))) -(define (initzer->value info) - (lambda (o) - (pmatch o - ((p-expr (fixed ,value)) (cstring->number value)) - (_ (error "initzer->value: " o))))) - -(define (initzer->data info) - (lambda (o) - (pmatch o - ((initzer (p-expr (char ,char))) (int->bv32 (char->integer (string-ref char 0)))) - ((initzer (p-expr (char ,char))) (list (char->integer (string-ref char 0)))) - ((initzer (p-expr (string ,string))) `((#:string ,string) #f #f #f)) - ((initzer (p-expr (string . ,strings))) `((#:string ,(string-join strings "")) #f #f #f)) - ((initzer (initzer-list . ,initzers)) (append-map (initzer->data info) initzers)) - ((initzer (ref-to (p-expr (ident ,name)))) `(,name #f #f #f)) - ((initzer (ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base)))))) - (let* ((type (decl->ast-type struct)) - (offset (field-offset info type field)) - (base (cstring->number base))) - (int->bv32 (+ base offset)))) - (() (int->bv32 0)) - ((initzer ,p-expr) - (int->bv32 (expr->number info p-expr))) - (_ (error "initzer->data: not supported: " o))))) - -(define (initzer->accu info) - (lambda (o) - (pmatch o - ((initzer-list . ,initzers) (fold (lambda (i info) ((expr->accu info) i)) info initzers)) - ((initzer (initzer-list . ,initzers)) (fold (lambda (i info) ((expr->accu info) i)) info initzers)) - ((initzer ,initzer) ((expr->accu info) o)) - (() (append-text info (wrap-as (i386:value->accu 0)))) - (_ (error "initzer->accu: " o))))) - -(define (expr->global globals) - (lambda (o) +(define (init->strings o info) + (let ((globals (.globals info))) (pmatch o ((p-expr (string ,string)) (let ((g `(#:string ,string))) - (or (assoc g globals) - (string->global-entry string)))) + (if (assoc g globals) '() + (list (string->global-entry string))))) ((p-expr (string . ,strings)) (let* ((string (string-join strings "")) (g `(#:string ,string))) - (or (assoc g globals) - (string->global-entry string)))) - ;;((p-expr (fixed ,value)) (int->global-entry (cstring->number value))) - (_ #f)))) - -(define (initzer->globals globals) - (lambda (o) - (pmatch o - ((initzer (initzer-list . ,initzers)) (append-map (initzer->globals globals) initzers)) - ((initzer ,initzer) (list ((expr->global globals) initzer))) - (_ '(#f))))) + (if (assoc g globals) '() + (list (string->global-entry string))))) + (((initzer (initzer-list . ,init))) + (append-map (cut init->strings <> info) init)) + ((initzer ,init) + (init->strings init info)) + ((initzer-list . ,init) + (append-map (cut init->strings <> info) init)) + (_ '())))) (define (type->info info o) (pmatch o + ((enum-def (ident ,name) (enum-def-list . ,fields)) + (mescc:trace name " ") + (let* ((type-entry (enum->type-entry name fields)) + (constants (enum-def-list->constants (.constants info) fields))) + (clone info + #:types (cons type-entry (.types info)) + #:constants (append constants (.constants info))))) ((struct-def (ident ,name) (field-list . ,fields)) (mescc:trace name " ") (let ((type-entry (struct->type-entry name (append-map (struct-field info) fields)))) (clone info #:types (cons type-entry (.types info))))) - (_ info))) + ((struct-ref . _) + info) + ((union-def (ident ,name) (field-list . ,fields)) + (mescc:trace name " ") + (let ((type-entry (union->type-entry name (append-map (struct-field info) fields)))) + (clone info #:types (cons type-entry (.types info))))) + ((union-ref . _) + info) + (_ + (stderr "type->info: not supported: ~s\n" o) + info))) -(define (.formals o) +;;; fctn-defn +(define (param-decl:get-name o) (pmatch o - ((fctn-defn _ (ftn-declr _ ,formals) _) formals) - ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals) - ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr _ ,formals)) _) formals) - ((fctn-defn _ (ptr-declr (pointer (pointer (pointer))) (ftn-declr _ ,formals)) _) formals) - (_ (error ".formals: " o)))) + ((ellipsis) #f) + ((param-decl (decl-spec-list (type-spec (void)))) #f) + ((param-decl _ (param-declr ,ast)) (ast->name ast)) + (_ (error "param-decl:get-name not supported:" o)))) + +(define (fctn-defn:get-name o) + (pmatch o + ((_ (ftn-declr (ident ,name) _) _) name) + ((_ (ptr-declr (pointer . _) (ftn-declr (ident ,name) _)) _) name) + (_ (error "fctn-defn:get-name not supported:" o)))) + +(define (param-decl:get-type o info) + (pmatch o + ((ellipsis) #f) + ((param-decl (decl-spec-list (type-spec (void)))) #f) + ((param-decl (decl-spec-list (type-spec ,type)) _) (ast->type info type)) + ((param-decl ,type _) (ast->type info type)) + (_ (error "param-decl:get-type not supported:" o)))) + +(define (fctn-defn:get-formals o) + (pmatch o + ((_ (ftn-declr _ ,formals) _) formals) + ((_ (ptr-declr (pointer . _) (ftn-declr _ ,formals)) _) formals) + (_ (error "fctn-defn->formals: not supported:" o)))) (define (formal->text n) (lambda (o i) @@ -2451,112 +2177,96 @@ '() )) -(define (formals->text o) +(define (param-list->text o) (pmatch o ((param-list . ,formals) (let ((n (length formals))) (wrap-as (append (i386:function-preamble) (append-map (formal->text n) formals (iota n)) (i386:function-locals))))) - (_ (error "formals->text: not supported: " o)))) + (_ (error "param-list->text: not supported: " o)))) -(define (formal:ptr o) +(define (param-decl:get-ptr o) (pmatch o + ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name) (array-of _))) + 1) ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name))) 0) - ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) - 2) - ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (ident ,name)))) - 1) - ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _))) - 1) - ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer)) (ident ,name)))) - 2) - ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer (pointer))) (ident ,name)))) - 3) - (_ 0))) + ((param-decl _ (param-declr (ptr-declr ,pointer (array-of _)))) + (1+ (pointer->ptr pointer))) + ((param-decl _ (param-declr (ptr-declr ,pointer . _))) + (pointer->ptr pointer)) + ((param-decl (decl-spec-list (type-spec (void)))) + 0) + (_ (error "param-decl:get-ptr: not supported: " o)))) -(define (formals->locals o) +(define (param-list->locals o info) (pmatch o ((param-list . ,formals) (let ((n (length formals))) - (map make-local-entry (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1)))) - (_ (error "formals->locals: not supported: " o)))) + (map make-local-entry + (map param-decl:get-name formals) + (map (cut param-decl:get-type <> info) formals) + (map param-decl:get-ptr formals) + (map (const #f) (iota n)) + (iota n -2 -1)))) + (_ (error "param-list->locals: not supported:" o)))) - -(define (function->type info o) +(define (fctn-defn:get-type info o) (pmatch o - ((fctn-defn (decl-spec-list (type-spec ,type)) (ptr-declr ,pointer ,rest) ,statement) - (let ((type (ast-type->type info type)) + (((decl-spec-list (type-spec ,type)) (ptr-declr ,pointer . _) ,statement) + (let ((type (ast->type info type)) (pointer (ptr-declr->pointer pointer))) (make-type (type:type type) (type:size type) (+ (type:pointer type) pointer) (type:description type)))) - ((decl (decl-spec-list (type-spec ,type)) (init-declr (ptr-declr ,pointer (ftn-declr . ,rest)))) - (let ((type (ast-type->type info type)) - (pointer (ptr-declr->pointer pointer))) - (make-type (type:type type) - (type:size type) - (+ (type:pointer type) pointer) - (type:description type)))) - ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr ,pointer (ftn-declr . ,rest))))) - (ast-type->type info type)) - ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ftn-declr . ,rest)))) - (ast-type->type info type)) - ((decl (decl-spec-list (stor-spec ,store) (type-spec ,type)) (init-declr-list (init-declr (ptr-declr ,pointer (ftn-declr . ,rest))))) - (ast-type->type info type)) - ((decl (decl-spec-list (stor-spec ,store) (type-spec ,type)) (init-declr-list (init-declr (ftn-declr . ,rest)))) - (ast-type->type info type)) - ((fctn-defn (decl-spec-list (stor-spec . ,store) (type-spec ,type)) (ptr-declr ,pointer (ftn-declr . ,rest)) ,statement) - (ast-type->type info type)) - ((fctn-defn (decl-spec-list (stor-spec . ,store) (type-spec ,type)) . ,rest) - (ast-type->type info type)) - ((decl (decl-spec-list (type-spec ,type)) (init-declr (ftn-declr . ,rest))) - (ast-type->type info type)) - ((fctn-defn (decl-spec-list (type-spec ,type)) . ,rest) - (ast-type->type info type)) - (_ (stderr "TODO: function->type: not supported: ~s\n" o) - (get-type info "info")))) + (((decl-spec-list (type-spec ,type)) . ,rest) + (ast->type info type)) + (((decl-spec-list (stor-spec ,store) (type-spec ,type)) (ftn-declr (ident _) _) _) + (ast->type info type)) + (_ (error "fctn-defn:get-type: not supported:" o)))) -(define (function->info info) - (lambda (o) - (define (assert-return text) - (let ((return (wrap-as (i386:ret)))) - (if (equal? (list-tail text (- (length text) (length return))) return) text - (append text return)))) - (let* ((name (.name o)) - (type (function->type info o)) - (formals (.formals o)) - (text (formals->text formals)) - (locals (formals->locals formals))) - (mescc:trace name) - (let loop ((statements (.statements o)) - (info (clone info #:locals locals #:function (.name o) #:text text))) - (if (null? statements) (let* ((locals (.locals info)) - (local (and (pair? locals) (car locals))) - (count (and=> local (compose local:id cdr))) - (stack (and count (* count 4)))) - (if (and stack (getenv "MESC_DEBUG")) (stderr " stack: ~a\n" stack)) - (clone info - #:function #f - #:globals (append (.statics info) (.globals info)) - #:statics '() - #:functions (append (.functions info) (list (cons name (make-function name type (assert-return (.text info)))))))) - (let* ((statement (car statements))) - (loop (cdr statements) - ((ast->info info) (car statements))))))))) +(define (ftn-declr:get-type info o) + (pmatch o + ((ftn-declr (ident _) . _) #f) + (_ (error "fctn-decrl:get-type: not supported:" o)))) + +(define (fctn-defn:get-statement o) + (pmatch o + ((_ (ftn-declr (ident _) _) ,statement) statement) + ((_ (ptr-declr (pointer . _) (ftn-declr (ident _) . _)) ,statement) statement) + (_ (error "fctn-defn:get-statement: not supported: " o)))) + +(define (fctn-defn->info o info) + (define (assert-return text) + (let ((return (wrap-as (i386:ret)))) + (if (equal? (list-tail text (- (length text) (length return))) return) text + (append text return)))) + (let ((name (fctn-defn:get-name o))) + (mescc:trace name) + (let* ((type (fctn-defn:get-type info o)) + (formals (fctn-defn:get-formals o)) + (text (param-list->text formals)) + (locals (param-list->locals formals info)) + (statement (fctn-defn:get-statement o)) + (info (clone info #:locals locals #:function name #:text text)) + (info (ast->info statement info)) + (locals (.locals info)) + (local (and (pair? locals) (car locals))) + (count (and=> local (compose local:id cdr))) + (stack (and count (* count 4)))) + (if (and stack (getenv "MESC_DEBUG")) (stderr " stack: ~a\n" stack)) + (clone info + #:function #f + #:globals (append (.statics info) (.globals info)) + #:statics '() + #:functions (append (.functions info) (list (cons name (make-function name type (assert-return (.text info)))))))))) ;; exports -(define (ast-list->info info) - (lambda (elements) - (let loop ((elements elements) (info info)) - (if (null? elements) info - (loop (cdr elements) ((ast->info info) (car elements))))))) - -(define* (c99-ast->info ast) - ((ast->info (make #:types i386:type-alist)) ast)) +(define* (c99-ast->info o) + (ast->info o (make #:types i386:type-alist))) (define* (c99-input->ast #:key (defines '()) (includes '())) (stderr "parsing: input\n") @@ -2567,7 +2277,7 @@ (let* ((info (make #:types i386:type-alist)) (ast (c99-input->ast #:defines defines #:includes includes)) (foo (stderr "compiling: input\n")) - (info ((ast->info info) ast)) + (info (ast->info ast info)) (info (clone info #:text '() #:locals '()))) info))) diff --git a/module/language/c99/info.scm b/module/language/c99/info.scm index de6c62ae..69bacbcf 100644 --- a/module/language/c99/info.scm +++ b/module/language/c99/info.scm @@ -57,6 +57,7 @@ global:name global:type global:pointer + global:array global:value global:function global->string @@ -66,6 +67,7 @@ local? local:type local:pointer + local:array local:id @@ -109,11 +111,12 @@ (description type:description)) (define-immutable-record-type - (make-global name type pointer value function) + (make-global name type pointer array value function) global? (name global:name) (type global:type) (pointer global:pointer) + (array global:array) (value global:value) (function global:function)) @@ -122,10 +125,11 @@ (global:name o))) (define-immutable-record-type - (make-local type pointer id) + (make-local type pointer array id) local? (type local:type) (pointer local:pointer) + (array local:array) (id local:id)) (define-immutable-record-type diff --git a/module/mes/M1.mes b/module/mes/M1.mes index 8871ef13..e515d425 100644 --- a/module/mes/M1.mes +++ b/module/mes/M1.mes @@ -129,9 +129,11 @@ (hex2:address address)) ((#:address (#:address ,global)) (guard (global? global)) (hex2:address (global->string global))) - ((#:string ,string) (hex2:address (string->label o))) - ((#:address ,address) (string? address) (hex2:address address)) - ((#:address ,global) (global? global) (error "urg1: global without a name\n")) + ((#:string ,string) + (hex2:address (string->label o))) + ((#:address ,address) (guard (string? address)) (hex2:address address)) + ((#:address ,global) (guard (global? global)) + (hex2:address (global->string global))) ((#:offset ,offset) (hex2:offset offset)) ((#:offset1 ,offset1) (hex2:offset1 offset1)) ((#:immediate ,immediate) (hex2:immediate immediate)) diff --git a/scaffold/boot/02-identifier.scm b/scaffold/boot/02-identifier.scm new file mode 100644 index 00000000..cf78d918 --- /dev/null +++ b/scaffold/boot/02-identifier.scm @@ -0,0 +1,25 @@ +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +'boo +'4a +12345 +-22 ++44 +(list 0) +'... diff --git a/scaffold/boot/03-big-string.scm b/scaffold/boot/03-big-string.scm new file mode 100644 index 00000000..f741c667 --- /dev/null +++ b/scaffold/boot/03-big-string.scm @@ -0,0 +1,56 @@ +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +"Mes is distributed WITHOUT ANY WARRANTY. The following +sections from the GNU General Public License, version 3, should +make that clear. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + +See , for more details. +" diff --git a/scaffold/boot/05-big-list.scm b/scaffold/boot/05-big-list.scm new file mode 100644 index 00000000..a2541376 --- /dev/null +++ b/scaffold/boot/05-big-list.scm @@ -0,0 +1,28 @@ +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(list 00 01 02 03 04 05 06 07 08 09 + 10 11 12 13 14 15 16 17 18 19 + 20 21 22 23 24 25 26 27 28 29 + 30 31 32 33 34 35 36 37 38 39 + 40 41 42 43 44 45 46 47 48 49 + 50 51 52 53 54 55 56 57 58 59 + 60 61 62 63 64 65 66 67 68 69 + 70 71 72 73 74 75 76 77 78 79 + 80 81 82 83 84 85 86 87 88 89 + 90 91 92 93 94 95 96 97 98 99) diff --git a/scaffold/boot/05-list-list.scm b/scaffold/boot/05-list-list.scm new file mode 100644 index 00000000..4cd913f7 --- /dev/null +++ b/scaffold/boot/05-list-list.scm @@ -0,0 +1,19 @@ +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(list 0 1 (list 20 21) 3) diff --git a/scaffold/boot/60-let-syntax-expanded.scm b/scaffold/boot/60-let-syntax-expanded.scm new file mode 100644 index 00000000..7a299252 --- /dev/null +++ b/scaffold/boot/60-let-syntax-expanded.scm @@ -0,0 +1,564 @@ +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +;; boot-00.scm +(define mes %version) + +(define (defined? x) + (assq x (current-module))) + +(define (cond-expand-expander clauses) + (if (defined? (car (car clauses))) + (cdr (car clauses)) + (cond-expand-expander (cdr clauses)))) + +(define-macro (cond-expand . clauses) + (cons 'begin (cond-expand-expander clauses))) +;; end boot-00.scm + +;; boot-01.scm +(define 0) +(define 7) +(define 10) + +(define (pair? x) (eq? (core:type x) )) +(define (not x) (if x #f #t)) + +(define (display x . rest) + (if (null? rest) (core:display x) + (core:display-port x (car rest)))) + +(define (write x . rest) + (if (null? rest) (core:write x) + (core:write-port x (car rest)))) + +(define (list->string lst) + (core:make-cell lst 0)) + +(define (integer->char x) + (core:make-cell 0 x)) + +(define (newline . rest) + (core:display (list->string (list (integer->char 10))))) + +(define (string->list s) + (core:car s)) + +(define (cadr x) (car (cdr x))) + +(define (map1 f lst) + (if (null? lst) (list) + (cons (f (car lst)) (map1 f (cdr lst))))) + +(define map map1) + +(define (cons* . rest) + (if (null? (cdr rest)) (car rest) + (cons (car rest) (core:apply cons* (cdr rest) (current-module))))) + +(define (apply f h . t) + (if (null? t) (core:apply f h (current-module)) + (apply f (apply cons* (cons h t))))) + +(define (append . rest) + (if (null? rest) '() + (if (null? (cdr rest)) (car rest) + (append2 (car rest) (apply append (cdr rest)))))) +;; end boot-01.scm + +;;((lambda (*program*) *program*) (primitive-load 0)) +;;(primitive-load 0) + + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(define-macro (and . x) + (if (null? x) #t + (if (null? (cdr x)) (car x) + (list (quote if) (car x) (cons (quote and) (cdr x)) + #f)))) + +(define-macro (or . x) + (if (null? x) #f + (if (null? (cdr x)) (car x) + (list (list (quote lambda) (list (quote r)) + (list (quote if) (quote r) (quote r) + (cons (quote or) (cdr x)))) + (car x))))) + +(define else #t) +(define-macro (cond . clauses) + (list 'if (pair? clauses) + (list (cons + 'lambda + (cons + '(test) + (list (list 'if 'test + (if (pair? (cdr (car clauses))) + (if (eq? (car (cdr (car clauses))) '=>) + (append2 (cdr (cdr (car clauses))) '(test)) + (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses))))))) + (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses))))))) + (if (pair? (cdr clauses)) + (cons 'cond (cdr clauses))))))) + (car (car clauses))))) + +(define (memq x lst) + (if (null? lst) #f + (if (eq? x (car lst)) lst + (memq x (cdr lst))))) + +;; (cond-expand +;; (guile +;; (define closure identity) +;; (define body identity) +;; (define append2 append) +;; (define (core:apply f a m) (f a)) +;; ) +;; (mes + (define 11) + (define (symbol? x) + (eq? (core:type x) )) + + (define (string->symbol s) + (if (not (pair? (core:car s))) '() + (core:lookup-symbol (core:car s)))) + + (define 10) + (define (string? x) + (eq? (core:type x) )) + + (define 14) + (define (vector? x) + (eq? (core:type x) )) + + ;; (define (body x) + ;; (core:cdr (core:cdr (core:cdr (cdr (assq 'x (current-module))))))) + ;; (define (closure x) + ;; (map car (cdr (core:cdr (core:car (core:cdr (cdr (assq 'x (current-module))))))))) + ;; )) + +(define (cons* . rest) + (if (null? (cdr rest)) (car rest) + (cons (car rest) (core:apply cons* (cdr rest) (current-module))))) + +(define (apply f h . t) + (if (null? t) (core:apply f h (current-module)) + (apply f (apply cons* (cons h t))))) + +(define (append . rest) + (if (null? rest) '() + (if (null? (cdr rest)) (car rest) + (append2 (car rest) (apply append (cdr rest)))))) + +(define-macro (quasiquote x) + ;;(core:display-error "quasiquote:") (core:write-error x) (core:display-error "\n") + (define (loop x) + ;;(core:display-error "loop:") (core:write-error x) (core:display-error "\n") + (if (vector? x) (list 'list->vector (loop (vector->list x))) + (if (not (pair? x)) (cons 'quote (cons x '())) + (if (eq? (car x) 'quasiquote) (loop (loop (cadr x))) + (if (eq? (car x) 'unquote) (cadr x) + (if (and (pair? (car x)) (eq? (caar x) 'unquote-splicing)) + ((lambda (d) + (list 'append (car (cdr (car x))) d)) + (loop (cdr x))) + ((lambda (a d) + (if (pair? d) + (if (eq? (car d) 'quote) + (if (and (pair? a) (eq? (car a) 'quote)) + (list 'quote (cons (cadr a) (cadr d))) + (if (null? (cadr d)) + (list 'list a) + (list 'cons* a d))) + (if (memq (car d) '(list cons*)) + (cons (car d) (cons a (cdr d))) + (list 'cons* a d))) + (list 'cons* a d))) + (loop (car x)) + (loop (cdr x))))))))) + (loop x)) + +(define (caar x) (car (car x))) +(define (cadr x) (car (cdr x))) +(define (cdar x) (cdr (car x))) +(define (cddr x) (cdr (cdr x))) + +(define-macro (simple-let bindings . rest) + (cons (cons 'lambda (cons (map car bindings) rest)) + (map cadr bindings))) + +(define-macro (xsimple-let bindings rest) + `(,`(lambda ,(map car bindings) ,@rest) + ,@(map cadr bindings))) + +(define-macro (xnamed-let name bindings rest) + `(simple-let ((,name *unspecified*)) + (set! ,name (lambda ,(map car bindings) ,@rest)) + (,name ,@(map cadr bindings)))) + +(define-macro (let bindings-or-name . rest) + (if (symbol? bindings-or-name) ;; IF + `(xnamed-let ,bindings-or-name ,(car rest) ,(cdr rest)) + `(xsimple-let ,bindings-or-name ,rest))) + +(define (expand-let* bindings body) + (if (null? bindings) + `((lambda () ,@body)) + `((lambda (,(caar bindings)) + ,(expand-let* (cdr bindings) body)) + ,@(cdar bindings)))) + +(define-macro (let* bindings . body) + (expand-let* bindings body)) + +(define (equal2? a b) + (if (and (null? a) (null? b)) #t + (if (and (pair? a) (pair? b)) + (and (equal2? (car a) (car b)) + (equal2? (cdr a) (cdr b))) + (if (and (string? a) (string? b)) + (eq? (string->symbol a) (string->symbol b)) + (if (and (vector? a) (vector? b)) + (equal2? (vector->list a) (vector->list b)) + (eq? a b)))))) + +(define equal? equal2?) +(define (member x lst) + (if (null? lst) #f + (if (equal2? x (car lst)) lst + (member x (cdr lst))))) + +(define (<= . rest) + (or (apply < rest) + (apply = rest))) + +(define (>= . rest) + (or (apply > rest) + (apply = rest))) + +(define (list? x) + (or (null? x) + (and (pair? x) (list? (cdr x))))) + +;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. +;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +;;; Commentary: + +;;; syntax.mes is loaded after scm.mes. It provides the R5RS hygienic +;;; macros define-syntax, syntax-rules and define-syntax-rule. +;;; syntax-rules is adapted from scheme48-1.1/scheme/alt/syntax.scm + +;;; Code: + +;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING. + +;;; scheme48-1.1/COPYING + +;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees +;; All rights reserved. + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; 3. The name of the authors may not be used to endorse or promote products +;; derived from this software without specific prior written permission. + +;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +(cond-expand + (guile) + (mes + (define-macro (define-syntax macro-name transformer . stuff) + `(define-macro (,macro-name . args) + (,transformer (cons ',macro-name args) + (lambda (x0) x0) + eq?))))) + +;; Rewrite-rule compiler (a.k.a. "extend-syntax") + +;; Example: +;; +;; (define-syntax or +;; (syntax-rules () +;; ((or) #f) +;; ((or e) e) +;; ((or e1 e ...) (let ((temp e1)) +;; (if temp temp (or e ...)))))) + +(cond-expand + (guile) + (mes + (define-syntax syntax-rules + (let () + (define name? symbol?) + + (define (segment-pattern? pattern) + (and (segment-template? pattern) + (or (null? (cddr pattern)) + (syntax-error0 "segment matching not implemented" pattern)))) + + (define (segment-template? pattern) + (and (pair? pattern) + (pair? (cdr pattern)) + (memq (cadr pattern) indicators-for-zero-or-more))) + + (define indicators-for-zero-or-more (list (string->symbol "...") '---)) + + (lambda (exp r c) + + (define %input (r '%input)) ;Gensym these, if you like. + (define %compare (r '%compare)) + (define %rename (r '%rename)) + (define %tail (r '%tail)) + (define %temp (r '%temp)) + + (define rules (cddr exp)) + (define subkeywords (cadr exp)) + + (define (make-transformer rules) + ;;(core:display-error "make-transformer:") (core:write-error rules) (core:display-error "\n") + `(lambda (,%input ,%rename ,%compare) + (let ((,%tail (cdr ,%input))) + (cond ,@(map process-rule rules) + (else + (syntax-error1 + "use of macro doesn't match definition" + ,%input)))))) + + (define (process-rule rule) + ;;(core:display-error "process-rule:") (core:write-error rule) (core:display-error "\n") + (if (and (pair? rule) + (pair? (cdr rule)) + (null? (cddr rule))) + (let ((pattern (cdar rule)) + (template (cadr rule))) + `((and ,@(process-match %tail pattern)) + (let* ,(process-pattern pattern + %tail + (lambda (x) x)) + ,(process-template template + 0 + (meta-variables pattern 0 '()))))) + (syntax-error2 "ill-formed syntax rule" rule))) + + ;; Generate code to test whether input expression matches pattern + + (define (process-match input pattern) + ;;(core:display-error "process-match:") (core:write-error input) (core:display-error "\n") + ;;(core:display-error " pattern:") (core:write-error pattern) (core:display-error "\n") + (cond ((name? pattern) + (if (member pattern subkeywords) + `((,%compare ,input (,%rename ',pattern))) + `())) + ((segment-pattern? pattern) + (process-segment-match input (car pattern))) + ((pair? pattern) + `((let ((,%temp ,input)) + (and (pair? ,%temp) + ,@(process-match `(car ,%temp) (car pattern)) + ,@(process-match `(cdr ,%temp) (cdr pattern)))))) + ((or (null? pattern) (boolean? pattern) (char? pattern)) + `((eq? ,input ',pattern))) + (else + `((equal? ,input ',pattern))))) + + (define (process-segment-match input pattern) + ;;(core:display-error "process-segment-match:") (core:write-error input) (core:display-error "\n") + ;;(core:display-error " pattern:") (core:write-error pattern) (core:display-error "\n") + (let ((conjuncts (process-match '(car l) pattern))) + (if (null? conjuncts) + `((list? ,input)) ;+++ + `((let loop ((l ,input)) + (or (null? l) + (and (pair? l) + ,@conjuncts + (loop (cdr l))))))))) + + ;; Generate code to take apart the input expression + ;; This is pretty bad, but it seems to work (can't say why). + + (define (process-pattern pattern path mapit) + ;;(core:display-error "process-pattern:") (core:write-error pattern) (core:display-error "\n") + ;;(core:display-error " path:") (core:write-error path) (core:display-error "\n") + (cond ((name? pattern) + (if (memq pattern subkeywords) + '() + (list (list pattern (mapit path))))) + ((segment-pattern? pattern) + (process-pattern (car pattern) + %temp + (lambda (x) ;temp is free in x + (mapit (if (eq? %temp x) + path ;+++ + `(map (lambda (,%temp) ,x) + ,path)))))) + ((pair? pattern) + (append (process-pattern (car pattern) `(car ,path) mapit) + (process-pattern (cdr pattern) `(cdr ,path) mapit))) + (else '()))) + + ;; Generate code to compose the output expression according to template + + (define (process-template template rank env) + ;;(core:display-error "process-template:") (core:write-error template) (core:display-error "\n") + (cond ((name? template) + (let ((probe (assq template env))) + (if probe + (if (<= (cdr probe) rank) + template + (syntax-error3 "template rank error (too few ...'s?)" + template)) + `(,%rename ',template)))) + ((segment-template? template) + (let ((vars + (free-meta-variables (car template) (+ rank 1) env '()))) + (if (null? vars) + (silent-syntax-error4 "too many ...'s" template) + (let* ((x (process-template (car template) + (+ rank 1) + env)) + (gen (if (equal? (list x) vars) + x ;+++ + `(map (lambda ,vars ,x) + ,@vars)))) + (if (null? (cddr template)) + gen ;+++ + `(append ,gen ,(process-template (cddr template) + rank env))))))) + ((pair? template) + `(cons ,(process-template (car template) rank env) + ,(process-template (cdr template) rank env))) + (else `(quote ,template)))) + + ;; Return an association list of (var . rank) + + (define (meta-variables pattern rank vars) + ;;(core:display-error "meta-variables:") (core:write-error pattern) (core:display-error "\n") + (cond ((name? pattern) + (if (memq pattern subkeywords) + vars + (cons (cons pattern rank) vars))) + ((segment-pattern? pattern) + (meta-variables (car pattern) (+ rank 1) vars)) + ((pair? pattern) + (meta-variables (car pattern) rank + (meta-variables (cdr pattern) rank vars))) + (else vars))) + + ;; Return a list of meta-variables of given higher rank + + (define (free-meta-variables template rank env free) + ;;(core:display-error "meta-variables:") (core:write-error template) (core:display-error "\n") + (cond ((name? template) + (if (and (not (memq template free)) + (let ((probe (assq template env))) + (and probe (>= (cdr probe) rank)))) + (cons template free) + free)) + ((segment-template? template) + (free-meta-variables (car template) + rank env + (free-meta-variables (cddr template) + rank env free))) + ((pair? template) + (free-meta-variables (car template) + rank env + (free-meta-variables (cdr template) + rank env free))) + (else free))) + + c ;ignored + + ;; Kludge for Scheme48 linker. + ;; `(cons ,(make-transformer rules) + ;; ',(find-free-names-in-syntax-rules subkeywords rules)) + + (make-transformer rules)))))) + +(cond-expand + (guile) + (mes + (define-macro (let-syntax bindings . rest) + `((lambda () + ,@(map (lambda (binding) + `(define-macro (,(car binding) . args) + (,(cadr binding) (cons ',(car binding) args) + (lambda (x0) x0) + eq?))) + bindings) + ,@rest))))) + +(core:display + (let-syntax ((xwhen (syntax-rules () + ((xwhen condition exp ...) + (if (not condition) + (begin exp ...)))))) + (xwhen #f 42))) + + diff --git a/scaffold/boot/call-cc.scm b/scaffold/boot/call-cc.scm new file mode 100644 index 00000000..63482064 --- /dev/null +++ b/scaffold/boot/call-cc.scm @@ -0,0 +1,60 @@ +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +;; ,expand (let loop ((i 10)) (if (eq? i 0) 0 (begin (core:display-error i) (core:display-error "\n") (loop (- i 1))))) +;; (let loop ((i 10)) (if (eq? i 0) 0 (begin (display i) (display "\n") (loop (- i 1))))) + +(define global "global\n") +(define v #(0 1 2)) +(define vv #(#(0 1 2) 0 1 2)) +((lambda (loop) + (set! loop + (lambda (i) + (core:display global) + (core:display (values 'foobar global)) + (core:display v) + (core:display vv) + (core:display "i=") + (core:display i) + (core:display "\n") + (if (eq? i 0) 0 + (begin + ((lambda (cont seen?) + (+ 1 (call-with-current-continuation (lambda (c) (set! cont c) 1))) + (core:display " seen?=") + (core:display seen?) + (core:display "\n") + (if seen? 0 + (begin + (set! seen? #t) + (cont 2)))) + #f #f) + (loop (- i 1)))))) + (loop 10000)) + *unspecified*) + +;; ((lambda (cont seen?) +;; (+ 1 (call-with-current-continuation (lambda (c) (set! cont c) 1))) +;; (core:display "seen?=") +;; (core:display seen?) +;; (core:display "\n") +;; (if seen? 0 +;; (begin +;; (set! seen? #t) +;; (cont 2)))) +;; #f #f) diff --git a/scaffold/boot/memory.scm b/scaffold/boot/memory.scm new file mode 100644 index 00000000..4d6efb09 --- /dev/null +++ b/scaffold/boot/memory.scm @@ -0,0 +1,41 @@ +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +;; ,expand (let loop ((i 10)) (if (eq? i 0) 0 (begin (core:display-error i) (core:display-error "\n") (loop (- i 1))))) +;; (let loop ((i 10)) (if (eq? i 0) 0 (begin (display i) (display "\n") (loop (- i 1))))) + +((lambda (loop) + (set! loop + (lambda (i) + (if (eq? i 0) 0 + (begin + (core:display i) + (core:display "\n") + (loop (- i 1)))))) + (loop 10)) + *unspecified*) + +;; ((lambda (loop) +;; (set! loop +;; (lambda (i) +;; (if (eq? i 0) 0 +;; (begin (display i) +;; (display "\n") +;; (loop (- i 1)))))) +;; (loop 10)) +;; *unspecified*) diff --git a/scaffold/boot/numbers.scm b/scaffold/boot/numbers.scm new file mode 100644 index 00000000..1db52913 --- /dev/null +++ b/scaffold/boot/numbers.scm @@ -0,0 +1 @@ +(cdr '(0 . 1)) diff --git a/scaffold/tests/21-char[].c b/scaffold/tests/21-char[].c index f9573591..19109934 100644 --- a/scaffold/tests/21-char[].c +++ b/scaffold/tests/21-char[].c @@ -23,10 +23,10 @@ int test () { - int f; - int v = 3; char *s = "mes"; if (!s[0]) return 1; + int f; + int v = 3; if (!s[f]) return 1; if (s[3]) return 1; if (s[v]) return 1; diff --git a/scaffold/tests/23-pointer.c b/scaffold/tests/23-pointer.c index a1770cb2..0ae2d78c 100644 --- a/scaffold/tests/23-pointer.c +++ b/scaffold/tests/23-pointer.c @@ -1,6 +1,6 @@ /* -*-comment-start: "//";comment-end:""-*- * Mes --- Maxwell Equations of Software - * Copyright © 2017 Jan (janneke) Nieuwenhuizen + * Copyright © 2017 Jan Nieuwenhuizen * * This file is part of Mes. * diff --git a/scaffold/tests/46-function-static.c b/scaffold/tests/46-function-static.c index 27464cf8..658b167f 100644 --- a/scaffold/tests/46-function-static.c +++ b/scaffold/tests/46-function-static.c @@ -22,7 +22,9 @@ int test () { static int i = 1; - return i--; + static int foo = 0; + foo = 0; + return foo - i--; } static int i = 2; diff --git a/scaffold/tests/48-global-static.c b/scaffold/tests/49-global-static.c similarity index 100% rename from scaffold/tests/48-global-static.c rename to scaffold/tests/49-global-static.c diff --git a/scaffold/tests/54-argv.c b/scaffold/tests/54-argv.c index 84c5516b..9a66268d 100644 --- a/scaffold/tests/54-argv.c +++ b/scaffold/tests/54-argv.c @@ -26,6 +26,7 @@ main (int argc, char *argv[]) { puts ("\n"); puts ("t: argv[0] == \"scaffold/test....\"\n"); + puts ("argv0="); puts (argv[0]); puts ("\n"); if (strncmp (argv[0], "scaffold/test", 5)) return 1; puts ("t: *argv\"\n"); @@ -33,7 +34,7 @@ main (int argc, char *argv[]) puts ("\n"); puts ("t: if (argc > 1 && !strcmp (argv[1], \"--help\")\n"); - if (argc > 1 && !strcmp (argv[1], "--help")) return 1; + if (argc > 1 && !strcmp (argv[1], "--help")) return 2; return 0; } diff --git a/scaffold/tests/62-array.c b/scaffold/tests/62-array.c new file mode 100644 index 00000000..6c9a5405 --- /dev/null +++ b/scaffold/tests/62-array.c @@ -0,0 +1,55 @@ +/* -*-comment-start: "//";comment-end:""-*- + * Mes --- Maxwell Equations of Software + * Copyright © 2018 Jan (janneke) Nieuwenhuizen + * + * This file is part of Mes. + * + * Mes is free software; you can redistribute it and/or modify it + * under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or (at + * your option) any later version. + * + * Mes is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Mes. If not, see . + */ + +#include +int one_two_three[3] = +{ + 1, 2, 3 +}; + +char *foo_bar_baz[3] = +{ + "foo", "bar", "baz" +}; + +char foo_bar_baz_haha[3][4] = +{ + "foo", "bar", "baz" +}; + +char *foo = "foo"; +char *bar = "bar"; +char *baz = "baz"; + +char *foo_bar_baz_mwhuhahaha[3] = +{ + &foo, &bar, &baz +}; + +int +main () +{ + puts ("one:"); puts (itoa (one_two_three[0])); puts ("\n"); + puts ("foo:"); puts (foo_bar_baz[1]); puts ("\n"); + puts ("bar:"); puts (foo_bar_baz_haha[2]); puts ("\n"); + char *p = foo_bar_baz_haha[2]; + puts ("baz:"); puts (p); puts ("\n"); + return strcmp (foo_bar_baz[2], "baz"); +} diff --git a/scaffold/tests/63-struct-cell.c b/scaffold/tests/63-struct-cell.c index f23761ec..82155947 100644 --- a/scaffold/tests/63-struct-cell.c +++ b/scaffold/tests/63-struct-cell.c @@ -20,47 +20,47 @@ #include "30-test.i" -#include +// #include #include -#include +// #include -int -add (int a, int b) -{ - return a + b; -} +// int +// add (int a, int b) +// { +// return a + b; +// } -int -inc (int i) -{ - return i + 1; -} +// int +// inc (int i) +// { +// return i + 1; +// } -struct scm { - int type; - int car; - int cdr; -}; +// struct scm { +// int type; +// int car; +// int cdr; +// }; -int bla = 1234; -char g_arena[84]; -#if __MESC__ -struct scm *g_cells = g_arena; -#else -struct scm *g_cells = (struct scm*)g_arena; -#endif -char *g_chars = g_arena; +// int bla = 1234; +// char g_arena[84]; +// #if __MESC__ +// struct scm *g_cells = g_arena; +// #else +// struct scm *g_cells = (struct scm*)g_arena; +// #endif +// char *g_chars = g_arena; -int foo () {puts ("t: foo\n"); return 0;}; -int bar (int i) {puts ("t: bar\n"); return 0;}; +// int foo () {puts ("t: foo\n"); return 0;}; +// int bar (int i) {puts ("t: bar\n"); return 0;}; struct function { int (*function) (void); int arity; char *name; }; struct function g_fun = {&exit,1,"fun"}; -struct function g_foo = {&foo,0,"foo"}; -struct function g_bar = {&bar,1,"bar"}; +// struct function g_foo = {&foo,0,"foo"}; +// struct function g_bar = {&bar,1,"bar"}; //void *functions[2]; int functions[2]; @@ -68,181 +68,183 @@ int functions[2]; struct function g_functions[2]; int g_function = 0; -enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVECTOR, TBROKEN_HEART}; +// enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVECTOR, TBROKEN_HEART}; -typedef int SCM; -int g_free = 3; -SCM tmp; -SCM tmp_num; +// typedef int SCM; +// int g_free = 3; +// SCM tmp; +// SCM tmp_num; -int ARENA_SIZE = 200; -#define TYPE(x) g_cells[x].type -#define CAR(x) g_cells[x].car -#define CDR(x) g_cells[x].cdr -#define VALUE(x) g_cells[x].cdr +// int ARENA_SIZE = 200; +// #define TYPE(x) g_cells[x].type +// #define CAR(x) g_cells[x].car +// #define CDR(x) g_cells[x].cdr +// #define VALUE(x) g_cells[x].cdr -#define CAAR(x) CAR (CAR (x)) +// #define CAAR(x) CAR (CAR (x)) -struct scm scm_fun = {TFUNCTION,0,0}; -SCM cell_fun; +// struct scm scm_fun = {TFUNCTION,0,0}; +// SCM cell_fun; int test () { - puts ("\n"); - puts ("t: g_cells[0] = g_cells[1]\n"); - TYPE (1) = 1; - CAR (1) = 2; - CDR (1) = 3; - g_cells[0] = g_cells[1]; - if (TYPE (0) != 1) return 1; - if (CAR (0) != 2) return 2; - if (CDR (0) != 3) return 3; + // puts ("\n"); + // puts ("t: g_cells[0] = g_cells[1]\n"); + // TYPE (1) = 1; + // CAR (1) = 2; + // CDR (1) = 3; + // g_cells[0] = g_cells[1]; + // if (TYPE (0) != 1) return 1; + // if (CAR (0) != 2) return 2; + // if (CDR (0) != 3) return 3; - puts ("t: g_cells[i] = g_cells[j]\n"); - int i = 0; - int j = 1; - TYPE (1) = 4; - CAR (1) = 5; - CDR (1) = 6; - g_cells[i] = g_cells[j]; - if (TYPE (0) != 4) return 1; - if (CAR (0) != 5) return 2; - if (CDR (0) != 6) return 3; + // puts ("t: g_cells[i] = g_cells[j]\n"); + // int i = 0; + // int j = 1; + // TYPE (1) = 4; + // CAR (1) = 5; + // CDR (1) = 6; + // g_cells[i] = g_cells[j]; + // if (TYPE (0) != 4) return 1; + // if (CAR (0) != 5) return 2; + // if (CDR (0) != 6) return 3; - puts ("t: g_cells[0+add(0,0] = g_cells[0+inc(0)]\n"); - TYPE (1) = 1; - CAR (1) = 2; - CDR (1) = 3; - g_cells[0+add(0, 0)] = g_cells[0+inc(0)]; - if (TYPE (0) != 1) return 1; - if (CAR (0) != 2) return 2; - if (CDR (0) != 3) return 3; + // puts ("t: g_cells[0+add(0,0] = g_cells[0+inc(0)]\n"); + // TYPE (1) = 1; + // CAR (1) = 2; + // CDR (1) = 3; + // g_cells[0+add(0, 0)] = g_cells[0+inc(0)]; + // if (TYPE (0) != 1) return 1; + // if (CAR (0) != 2) return 2; + // if (CDR (0) != 3) return 3; - g_cells[0].type = TNUMBER; - g_cells[0].car = 0; - g_cells[0].cdr = 0; - g_cells[1].type = TNUMBER; - g_cells[1].car = 0; - g_cells[1].cdr = 0; + // g_cells[0].type = TNUMBER; + // g_cells[0].car = 0; + // g_cells[0].cdr = 0; + // g_cells[1].type = TNUMBER; + // g_cells[1].car = 0; + // g_cells[1].cdr = 0; - puts ("t: TYPE (0) != TYPE (1)\n"); - if (TYPE (0) == TYPE (1)) goto ok; - return 1; - ok: + // puts ("t: TYPE (0) != TYPE (1)\n"); + // if (TYPE (0) == TYPE (1)) goto ok; + // return 1; + // ok: - g_cells[0].car = 1; - g_cells[1].car = 2; + // g_cells[0].car = 1; + // g_cells[1].car = 2; - puts ("t: int c = VALUE (0)\n"); - int c = CAR (0); - if (c != 1) return 1; + // puts ("t: int c = VALUE (0)\n"); + // int c = CAR (0); + // if (c != 1) return 1; - puts ("t: CAAR (0) != 2\n"); - if (CAAR (0) != 2) return 1; + // puts ("t: CAAR (0) != 2\n"); + // if (CAAR (0) != 2) return 1; - puts ("t: 2 != CAAR (0)\n"); - if (2 != CAAR (0)) return 1; + // puts ("t: 2 != CAAR (0)\n"); + // if (2 != CAAR (0)) return 1; - g_cells[3].type = 0x64; - if (g_cells[3].type != 0x64) - return g_cells[3].type; + // g_cells[3].type = 0x64; + // if (g_cells[3].type != 0x64) + // return g_cells[3].type; - TYPE (4) = 4; - if (TYPE (4) != 4) - return 4; + // TYPE (4) = 4; + // if (TYPE (4) != 4) + // return 4; - CDR (3) = 0x22; - CDR (4) = 0x23; - if (CDR (3) != 0x22) - return CDR (3); + // CDR (3) = 0x22; + // CDR (4) = 0x23; + // if (CDR (3) != 0x22) + // return CDR (3); - puts ("t: g_fun.arity != 1;\n"); - if (g_fun.arity != 1) return 1; + // puts ("t: g_fun.arity != 1;\n"); + // if (g_fun.arity != 1) return 1; - puts ("t: g_fun.function != exit;\n"); - if (g_fun.function != &exit) return 1; + // puts ("t: g_fun.function != exit;\n"); + // if (g_fun.function != &exit) return 1; - puts ("t: struct fun = {&exit,1,\"exit\"};\n"); - struct function fun = {&exit,1,"exit"}; + // puts ("t: struct fun = {&exit,1,\"exit\"};\n"); + // struct function fun = {&exit,1,"exit"}; - puts ("t: fun.arity != 1;\n"); - if (fun.arity != 1) return 1; + // puts ("t: fun.arity != 1;\n"); + // if (fun.arity != 1) return 1; - puts ("t: fun.function != exit;\n"); - if (fun.function != &exit) return 1; + // puts ("t: fun.function != exit;\n"); + // if (fun.function != &exit) return 1; - puts ("t: puts (fun.name)\n"); - if (strcmp (fun.name, "exit")) return 1; + // puts ("t: puts (fun.name)\n"); + // if (strcmp (fun.name, "exit")) return 1; - puts ("t: puts (g_fun.name)\n"); - if (strcmp (g_fun.name, "fun")) return 1; + // puts ("t: puts (g_fun.name)\n"); + // if (strcmp (g_fun.name, "fun")) return 1; - puts ("t: g_functions[g_function++] = g_foo;\n"); - g_functions[g_function++] = g_foo; + // puts ("t: g_functions[g_function++] = g_foo;\n"); + // g_functions[g_function++] = g_foo; - puts ("t: pbar->arity == 1\n"); - struct function* barp = &g_bar; - if (barp->arity != 1) return 1; + // puts ("t: pbar->arity == 1\n"); + // struct function* barp = &g_bar; + // if (barp->arity != 1) return 1; - int fn = 0; - puts ("t: g_functions[g_cells[fn].cdr].arity\n"); - if (g_functions[g_cells[fn].cdr].arity) return 1; - if (g_functions[g_cells[fn].cdr].arity != 0) return 1; + // int fn = 0; + // puts ("t: g_functions[g_cells[fn].cdr].arity\n"); + // if (g_functions[g_cells[fn].cdr].arity) return 1; + // if (g_functions[g_cells[fn].cdr].arity != 0) return 1; - int (*functionx) (void) = 0; - functionx = g_functions[0].function; - puts ("t: functionx == foo\n"); - if (functionx != foo) return 11; + // int (*functionx) (void) = 0; + // functionx = g_functions[0].function; + // puts ("t: functionx == foo\n"); + // if (functionx != foo) return 11; - puts ("t: g_functions[0].name\n"); - if (strcmp (g_functions[0].name, "foo")) return 1; + // puts ("t: g_functions[0].name\n"); + // if (strcmp (g_functions[0].name, "foo")) return 1; - puts ("t: (functionx) () == foo\n"); - if ((functionx) () != 0) return 12; + // puts ("t: (functionx) () == foo\n"); + // if ((functionx) () != 0) return 12; - puts ("t: g_functions[].arity\n"); - if (g_functions[0].arity != 0) return 17; + // puts ("t: g_functions[].arity\n"); + // if (g_functions[0].arity != 0) return 17; - fn++; - g_functions[fn] = g_bar; - g_cells[fn].cdr = fn; - if (g_cells[fn].cdr != fn) return 13; + // fn++; + // g_functions[fn] = g_bar; + // g_cells[fn].cdr = fn; + // if (g_cells[fn].cdr != fn) return 13; - puts ("t: g_functions[g_cells[fn].cdr].function\n"); - functionx = g_functions[g_cells[fn].cdr].function; + // puts ("t: g_functions[g_cells[fn].cdr].function\n"); + // functionx = g_functions[g_cells[fn].cdr].function; - puts ("t: g_functions[1].name\n"); - if (strcmp (g_functions[1].name, "bar")) return 1; + // puts ("t: g_functions[1].name\n"); + // if (strcmp (g_functions[1].name, "bar")) return 1; - puts ("t: functionx == bar\n"); - if (functionx != bar) return 15; + // puts ("t: functionx == bar\n"); + // if (functionx != bar) return 15; - puts ("t: (functiony) (1) == bar\n"); - int (*functiony) (int) = 0; - functiony = g_functions[g_cells[fn].cdr].function; - if ((functiony) (1) != 0) return 16; + // puts ("t: (functiony) (1) == bar\n"); + // int (*functiony) (int) = 0; + // functiony = g_functions[g_cells[fn].cdr].function; + // if ((functiony) (1) != 0) return 16; - puts ("t: g_functions[].arity\n"); - if (g_functions[fn].arity != 1) return 18; + // puts ("t: g_functions[].arity\n"); + // if (g_functions[fn].arity != 1) return 18; - // fake name - scm_fun.car = 33; - scm_fun.cdr = g_function; - //g_functions[g_function++] = g_fun; + // // fake name + // scm_fun.car = 33; + // scm_fun.cdr = g_function; + // //g_functions[g_function++] = g_fun; + g_function++; + puts ("fun"); g_functions[g_function] = g_fun; - cell_fun = g_free++; - g_cells[cell_fun] = scm_fun; + // cell_fun = g_free++; + // g_cells[cell_fun] = scm_fun; - puts ("t: TYPE (cell_fun)\n"); - if (TYPE (cell_fun) != TFUNCTION) return 1; + // puts ("t: TYPE (cell_fun)\n"); + // if (TYPE (cell_fun) != TFUNCTION) return 1; - puts ("t: CAR (cell_fun)\n"); - if (CAR (cell_fun) != 33) return 1; + // puts ("t: CAR (cell_fun)\n"); + // if (CAR (cell_fun) != 33) return 1; - puts ("t: CDR (cell_fun)\n"); - if (CDR (cell_fun) != g_function) return 1; + // puts ("t: CDR (cell_fun)\n"); + // if (CDR (cell_fun) != g_function) return 1; return 0; } diff --git a/scaffold/tests/70-printf.c b/scaffold/tests/70-printf.c index 9bd8a8d8..469e17ec 100644 --- a/scaffold/tests/70-printf.c +++ b/scaffold/tests/70-printf.c @@ -1,6 +1,6 @@ /* -*-comment-start: "//";comment-end:""-*- * Mes --- Maxwell Equations of Software - * Copyright © 2017 Jan (janneke) Nieuwenhuizen + * Copyright © 2018 Jan (janneke) Nieuwenhuizen * * This file is part of Mes. * @@ -34,13 +34,14 @@ test () sprintf (buf, "c=%c\n", c); if (strcmp (buf, "c=m\n")) return 1; + if (i != 3) return 15; printf ("i=%d\n", i); sprintf (buf, "i=%d\n", i); - if (strcmp (buf, "i=3\n")) return 1; + if (strcmp (buf, "i=3\n")) return 2; printf ("s=%s\n", s); sprintf (buf, "s=%s\n", s); - if (strcmp (buf, "s=mes\n")) return 1; + if (strcmp (buf, "s=mes\n")) return 3; return 0; } diff --git a/scaffold/tests/71-struct-array.c b/scaffold/tests/71-struct-array.c index 2fbc7daa..86118f84 100644 --- a/scaffold/tests/71-struct-array.c +++ b/scaffold/tests/71-struct-array.c @@ -69,6 +69,8 @@ test () char *strings[] = { "one\n", "two\n", "three\n", NULL }; char **p = strings; while (*p) puts (*p++); + if (strcmp (strings[1], "two\n")) + return 3; strcpy (f.name, "hallo\n"); puts (f.name); diff --git a/scaffold/tests/7i-struct-struct.c b/scaffold/tests/7i-struct-struct.c index 3418be72..6198ee88 100644 --- a/scaffold/tests/7i-struct-struct.c +++ b/scaffold/tests/7i-struct-struct.c @@ -54,9 +54,9 @@ test () struct anon a = {3,4}; a.baz = 4; // FIXME printf ("a.bar=%d\n", a.bar); - if (a.bar != 3) return 1; + if (a.bar != 3) return 3; printf ("a.baz=%d\n", a.baz); - if (a.baz != 4) return 1; + if (a.baz != 4) return 4; return 0; } diff --git a/scaffold/tests/90-goto-var.c b/scaffold/tests/90-goto-var.c new file mode 100644 index 00000000..d89276a4 --- /dev/null +++ b/scaffold/tests/90-goto-var.c @@ -0,0 +1,13 @@ + +int +main () +{ + static void *lbl = &&lbl_b; + + goto *lbl; + lbl_a: + return 1; +lbl_b: + return 0; +} + diff --git a/scaffold/tests/91-goto-array.c b/scaffold/tests/91-goto-array.c new file mode 100644 index 00000000..a6050f44 --- /dev/null +++ b/scaffold/tests/91-goto-array.c @@ -0,0 +1,34 @@ +#include + +int main(void) { + static void *lbls[] = { &&lbl_h, &&lbl_e, &&lbl_l, &&lbl_l, &&lbl_o, &&lbl_quit }; + static void **lbl = lbls; + + goto **lbl; + +lbl_e: + printf("e"); + lbl++; + goto **lbl; + +lbl_o: + printf("o"); + lbl++; + goto **lbl; +lbl_h: + printf("h"); + lbl++; + goto **lbl; + +lbl_l: + printf("l"); + lbl++; + goto **lbl; + +lbl_quit: + puts(""); + return 0; + +} + + diff --git a/scaffold/tests/t.c b/scaffold/tests/t.c index 2c737708..fe6bf40a 100644 --- a/scaffold/tests/t.c +++ b/scaffold/tests/t.c @@ -1,6 +1,6 @@ /* -*-comment-start: "//";comment-end:""-*- * Mes --- Maxwell Equations of Software - * Copyright © 2017 Jan (janneke) Nieuwenhuizen + * Copyright © 2018 Jan (janneke) Nieuwenhuizen * * This file is part of Mes. * @@ -18,30 +18,102 @@ * along with Mes. If not, see . */ -#include "30-test.i" -char g_arena[4] = "XXX"; -char *g_chars = g_arena; +int puts (char const*); +#include +char global_arena[10]; +int global_i = 1; +int global_unitialized; +char* global_string = "foo"; +char global_array[8] = "XXX"; +char *global_chars = global_array; +typedef int SCM; +enum type_t {TCHAR}; +char *env[] = {"foo", "bar", "baz", 0}; +char *list[2] = {"foo\n", "bar\n"}; + +struct foo {int length; char* string;}; +struct foo f = {3, "foo"}; +struct foo g_foes[2]; +int g_foe; + +struct anon {struct {int bar; int baz;};}; + +struct here {int and;} there; int -test () +main (int argc, char* argv[]) { - puts ("X\n"); - if (*g_chars != 'X') return 1; - g_arena[0] = 'A'; - puts ("A\n"); - if (*g_chars != 'A') return 1; + int i; + int j = 1; + int k, l = 1; + if (j != 1) + return 1; + if (l != 1) + return 2; + if (global_i != 1) + return 3; + global_arena[1] = 0; + if (global_i != 1) + return 4; + if (global_unitialized != 0) + return 5; + if (strcmp (global_string, "foo")) + return 6; + char *s = "bar"; + if (strcmp (s, "bar")) + return 7; + if (*global_array != 'X') + return 8; + if (*global_chars != 'X') + return 9; + SCM x = 0; + if (x != 0) + return 9; + if (TCHAR != 0) + return 11; + if (strncmp (argv[0], "scaffold/test", 5)) + return 12; + if (strcmp (env[0], "foo")) + return 13; + if (strcmp (env[2], "baz")) + return 14; + if (env[3]) + return 15; + if (f.length != 3) + return 16; + if (strcmp (f.string, "foo")) + return 17; + struct foo g = {4, "baar"}; + if (g.length != 4) + return 16; + if (strcmp (g.string, "baar")) + return 18; + struct foo f = {3, "foo"}; + g_foes[0] = f; + g_foes[1] = f; + if (g_foe) + return 19; + char *strings[] = { "one\n", "two\n", "three\n", 0 }; + char **p = strings; + while (*p) puts (*p++); + if (strcmp (strings[1], "two\n")) + return 20; + p = list; + struct anon a = {3,4}; + eputs ("bar:"); eputs (itoa (a.bar)); eputs ("\n"); + eputs ("baz:"); eputs (itoa (a.baz)); eputs ("\n"); + if (a.bar != 3) return 1; + if (a.baz != 4) return 2; - puts ("*x A\n"); - char *x = g_arena; - if (*x != 'A') return 1; - - puts ("*x++ A\n"); - if (*x++ != 'A') return 1; - - puts ("t: *x++ != 'C'\n"); - *x++ = 'C'; - if (g_chars[1] != 'C') return 1; + i = 1; + int lst[6] = {-1, 1 - 1, i, 2, 3}; + for (int i = 0; i < 4; i++) + { + puts ("i: "); puts (itoa (lst[i])); puts ("\n"); + if (lst[i+1] != i) + return i; + } return 0; }