From 70e4aec861320dd8dca257e91c8ffaef2bc20c37 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 29 Jan 2017 15:22:39 +0100 Subject: [PATCH] mescc: Run mini-mes. * .gitignore: Ignore tiny-mes and tiny .mo's. * doc/examples/tiny-mes.c: Simplify. * doc/examples/mini-mes.c: Use simplifications from tiny-mes. * doc/examples/t.c (read_test, struct_test): New functions. (test): Add tests for arena, g_cells globals. * module/mes/elf-util.mes (dec->hex): New function. (lambda/label->list): Add text-address parameter. Update callers. * module/language/c99/compiler.mes (make, info, clone): Add init field. (.init): New function. (ident->accu): Add exceptions for globals. * module/mes/elf-util.scm: Export it. * module/mes/libc-i386.mes (i386:accu->base-ref, i386:byte-accu->base-ref, i386:accu->base-ref+n, i386:accu->global-ref, i386:global-ref->accu, i386:global-ref->base, i386:global-add, i386:global->accu):, i386:local-ref->accu, i386:local-ptr->accu, i386:local-ptr->base): New functions. * module/mes/libc-i386.scm: Export them. --- .gitignore | 3 + HACKING | 9 + module/language/c99/compiler.mes | 1786 +++++++++++++++++++----------- module/mes/elf-util.mes | 42 +- module/mes/elf-util.scm | 7 +- module/mes/elf.mes | 16 +- module/mes/libc-i386.mes | 200 +++- module/mes/libc-i386.scm | 34 +- scaffold/mini-mes.c | 485 ++++---- scaffold/t.c | 260 ++++- scaffold/tiny-mes.c | 175 +-- 11 files changed, 1889 insertions(+), 1128 deletions(-) diff --git a/.gitignore b/.gitignore index 4feb2397..5bc1b3e6 100644 --- a/.gitignore +++ b/.gitignore @@ -15,6 +15,9 @@ /mes /micro-mes /mini-mes +/tiny-mes +/module/mes/hack-32.mo +/module/mes/read-0-32.mo /module/mes/read-0.mo /out ? diff --git a/HACKING b/HACKING index 261cb9fa..38cf92dd 100644 --- a/HACKING +++ b/HACKING @@ -107,3 +107,12 @@ sc: http://sph.mn/content/3d3 *** [[http://www.scheme-reports.org/][Scheme Reports]] *** [[ftp://publications.ai.mit.edu/ai-publications/pdf/AIM-349.pdf][Scheme - Report on Scheme]] *** [[ftp://publications.ai.mit.edu/ai-publications/pdf/AIM-452.pdf][RRS - Revised Report on Scheme]] + +** tiny schemes +http://forum.osdev.org/viewtopic.php?f=15&t=19937 + +http://www.stripedgazelle.org/joey/dreamos.html +http://armpit.sourceforge.net/ +http://common-lisp.net/project/movitz/movitz.html + + janneke: https://github.com/namin/inc looks interesting [15:18] diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index c7c91fc2..0b7b5dbc 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -25,6 +25,8 @@ ;;; Code: +;;(define barf #f) + (cond-expand (guile-2 (set-port-encoding! (current-output-port) "ISO-8859-1")) @@ -62,7 +64,7 @@ (define (write-any x) (write-char (cond ((char? x) x) - ((and (number? x) (< (+ x 256) 0)) (format (current-error-port) "***BROKEN*** x=~a\n" x) (integer->char #xaa)) + ((and (number? x) (< (+ x 256) 0)) (format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa)) ((number? x) (integer->char (if (>= x 0) x (+ x 256)))) ((procedure? x) (stderr "write-any: proc: ~a\n" x) @@ -81,7 +83,14 @@ ((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name) ((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name) (_ - (format (current-error-port) "SKIP .name =~a\n" o)))) + (format (current-error-port) "SKIP: .name =~a\n" o)))) + +(define (.type o) + (pmatch o + ((param-decl (decl-spec-list (type-spec ,type)) _) (decl->type type)) + ((param-decl ,type _) type) + (_ + (format (current-error-port) "SKIP: .type =~a\n" o)))) (define (.statements o) (pmatch o @@ -93,17 +102,19 @@ (define ') (define ') (define ') +(define ') (define ') (define ') (define ') -(define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (function #f) (text '())) +(define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (init '()) (locals '()) (function #f) (text '())) (pmatch o ( (list (cons types) (cons constants) (cons functions) (cons globals) + (cons init) (cons locals) (cons function) (cons text))))) @@ -124,6 +135,10 @@ (pmatch o (( . ,alist) (assq-ref alist )))) +(define (.init o) + (pmatch o + (( . ,alist) (assq-ref alist )))) + (define (.locals o) (pmatch o (( . ,alist) (assq-ref alist )))) @@ -145,6 +160,7 @@ (constants (.constants o)) (functions (.functions o)) (globals (.globals o)) + (init (.init o)) (locals (.locals o)) (function (.function o)) (text (.text o))) @@ -154,70 +170,100 @@ (constants constants) (functions functions) (globals globals) + (init init) (locals locals) (function function) (text text)) - (make #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:function function #:text text)))))) + (make #:types types #:constants constants #:functions functions #:globals globals #:init init #:locals locals #:function function #:text text)))))) -(define (push-global-ref globals) +(define (push-global-address globals) (lambda (o) - (lambda (f g t d) - (i386:push-global-ref (+ (data-offset o g) d))))) + (lambda (f g ta t d) + (i386:push-global-address (+ (data-offset o g) d))))) (define (push-global globals) (lambda (o) - (lambda (f g t d) + (lambda (f g ta t d) (i386:push-global (+ (data-offset o g) d))))) (define push-global-de-ref push-global) -(define (push-ident globals locals) - (lambda (o) - (let ((local (assoc-ref locals o))) - (if local (i386:push-local local) - ((push-global globals) o))))) ;; FIXME: char*/int +(define (string->global string) + (make-global string "string" 0 (append (string->list string) (list #\nul)))) -(define (push-ident-ref globals locals) - (lambda (o) - (let ((local (assoc-ref locals o))) - (if local (i386:push-local-ref local) - ((push-global-ref globals) o))))) +(define (ident->global name type pointer value) + (make-global name type pointer (int->bv32 value))) -(define (push-ident-de-ref globals locals) +(define (make-local name type pointer id) + (cons name (list type pointer id))) +(define local:type car) +(define local:pointer cadr) +(define local:id caddr) + +(define (push-ident info) (lambda (o) - (let ((local (assoc-ref locals o))) - (if local (i386:push-local-de-ref local) - ((push-global-de-ref globals) o))))) + (let ((local (assoc-ref (.locals info) o))) + (if local (i386:push-local (local:id local)) + ((push-global (.globals info)) o))))) ;; FIXME: char*/int + +(define (push-ident-address info) + (lambda (o) + (let ((local (assoc-ref (.locals info) o))) + (if local (i386:push-local-address (local:id local)) + ((push-global-address (.globals info)) o))))) + +(define (push-ident-de-ref info) + (lambda (o) + (let ((local (assoc-ref (.locals info) o))) + (if local (i386:push-local-de-ref (local:id local)) + ((push-global-de-ref (.globals info)) o))))) (define (expr->arg info) ;; FIXME: get Mes curried-definitions (lambda (o) (pmatch o ((p-expr (fixed ,value)) (cstring->number value)) ((neg (p-expr (fixed ,value))) (- (cstring->number value))) - ((p-expr (string ,string)) ((push-global-ref (.globals info)) string)) + ((p-expr (string ,string)) ((push-global-address info) string)) ((p-expr (ident ,name)) - ((push-ident (.globals info) (.locals info)) name)) + ((push-ident info) name)) - ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name))) - (let ((value (cstring->number value)) + ;; g_cells[0] + ((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))) + (let ((index (cstring->number index)) (size 4)) ;; FIXME: type: int (append - ((ident->base info) name) + ((ident->base info) array) (list - (lambda (f g t d) + (lambda (f g ta t d) (append - (i386:value->accu (* size value)) ;; FIXME: type: int + (i386:value->accu (* size index)) ;; FIXME: type: int (i386:base-mem->accu) ;; FIXME: type: int (i386:push-accu) ;; hmm )))))) + ;; g_cells[i] + ((array-ref (p-expr (ident ,index)) (p-expr (ident ,array))) + (let ((index (cstring->number index)) + (size 4)) ;; FIXME: type: int + (append + ((ident->base info) array) + ((ident->accu info) array) + (list (lambda (f g ta t d) + ;;(i386:byte-base-mem->accu) + (i386:base-mem->accu) + )) + (list + (lambda (f g ta t d) + (append + (i386:push-accu))))))) + ((de-ref (p-expr (ident ,name))) - (lambda (f g t d) - ((push-ident-de-ref (.globals info) (.locals info)) name))) + (lambda (f g ta t d) + ((push-ident-de-ref info) name))) ((ref-to (p-expr (ident ,name))) - (lambda (f g t d) - ((push-ident-ref (.globals info) (.locals info)) name))) + (lambda (f g ta t d) + ((push-ident-address info) name))) ;; f (car (x)) ((fctn-call . ,call) @@ -225,7 +271,7 @@ (info ((ast->info empty) o))) (append (.text info) (list - (lambda (f g t d) + (lambda (f g ta t d) (i386:push-accu)))))) ;; f (CAR (x)) @@ -233,7 +279,7 @@ (let* ((empty (clone info #:text '())) (expr ((expr->accu empty) `(d-sel ,@d-sel)))) (append (.text expr) - (list (lambda (f g t d) + (list (lambda (f g ta t d) (i386:push-accu)))))) ;; f (0 + x) @@ -245,205 +291,487 @@ ,cast) ((expr->arg info) cast)) (_ - (format (current-error-port) "SKIP expr->arg=~s\n" o) + (format (current-error-port) "SKIP: expr->arg=~s\n" o) + barf 0)))) +;; FIXME: see ident->base (define (ident->accu info) (lambda (o) - (let ((local (assoc-ref (.locals info) o))) + (let ((local (assoc-ref (.locals info) o)) + (global (assoc-ref (.globals info) o)) + (constant (assoc-ref (.constants info) o))) + ;; (stderr "ident->accu: local[~a]: ~a\n" o (and local (local:id local))) + ;; (stderr "ident->accu: global[~a]: ~a\n" o global) + ;; (stderr "globals: ~a\n" (.globals info)) + ;; (if (and (not global) (not (local:id local))) + ;; (stderr "globals: ~a\n" (map car (.globals info)))) (if local - (list (lambda (f g t d) - (if (equal? o "c1") - (i386:byte-local->accu local) ;; FIXME - (i386:local->accu local)))) - (list (lambda (f g t d) - (i386:global->accu (+ (data-offset o g) d)))))))) + (let ((ptr (local:pointer local))) + (stderr "ident->accu PTR[~a]: ~a\n" o ptr) + (cond ((equal? o "c1") + (list (lambda (f g ta t d) + (i386:byte-local->accu (local:id local))))) ;; FIXME type + ((equal? o "functionx") + (list (lambda (f g ta t d) + (i386:local->accu (local:id local))))) ;; FIXME type + (else + (case ptr + ((-1) (list (lambda (f g ta t d) + (i386:local-ptr->accu (local:id local))))) + (else (list (lambda (f g ta t d) + (i386:local->accu (local:id local))))))))) + (if global + (let ((ptr (ident->pointer info o))) + (stderr "ident->accu PTR[~a]: ~a\n" o ptr) + (case ptr + ((-1) (list (lambda (f g ta t d) + (i386:global->accu (+ (data-offset o g) d))))) + (else (list (lambda (f g ta t d) + (i386:global-address->accu (+ (data-offset o g) d))))))) + (if constant + (list (lambda (f g ta t d) + (i386:value->accu constant))) + (list (lambda (f g ta t d) + (i386:global->accu (+ ta (function-offset o f))))))))))) + +(define (value->accu v) + (list (lambda (f g ta t d) + (i386:value->accu v)))) (define (accu->ident info) (lambda (o) (let ((local (assoc-ref (.locals info) o))) (if local - (list (lambda (f g t d) - (i386:accu->local local))) - (list (lambda (f g t d) + (list (lambda (f g ta t d) + (i386:accu->local (local:id local)))) + (list (lambda (f g ta t d) (i386:accu->global (+ (data-offset o g) d)))))))) -(define (base->ident-ref info) +(define (base->ident info) (lambda (o) (let ((local (assoc-ref (.locals info) o))) (if local - (list (lambda (f g t d) + (list (lambda (f g ta t d) + (i386:base->local (local:id local)))) + (list (lambda (f g ta t d) + (i386:base->global (+ (data-offset o g) d)))))))) + +(define (base->ident-address info) + (lambda (o) + (let ((local (assoc-ref (.locals info) o))) + (if local + (list (lambda (f g ta t d) (append - (i386:local->accu local) - (i386:byte-base->accu-ref)))) - TODO:base->ident-ref-global)))) + (i386:local->accu (local:id local)) + (i386:byte-base->accu-address)))) + TODO:base->ident-address-global)))) (define (value->ident info) (lambda (o value) (let ((local (assoc-ref (.locals info) o))) (if local - (list (lambda (f g t d) - (i386:value->local local value))) - (list (lambda (f g t d) + (list (lambda (f g ta t d) + (i386:value->local (local:id local) value))) + (list (lambda (f g ta t d) (i386:value->global (+ (data-offset o g) d) value))))))) -(define (ident-address->accu info) - (lambda (o) +(define (ident-add info) + (lambda (o n) (let ((local (assoc-ref (.locals info) o))) (if local - (list (lambda (f g t d) - (i386:local-address->accu local))) - (list (lambda (f g t d) - (i386:global->accu (+ (data-offset o g) d)))))))) + (list (lambda (f g ta t d) + (i386:local-add (local:id local) n))) + (list (lambda (f g ta t d) + (i386:global-add (+ (data-offset o g) d) n))))))) +;; FIXME: see ident->accu (define (ident->base info) (lambda (o) (let ((local (assoc-ref (.locals info) o))) + (stderr "ident->base: local[~a]: ~a\n" o (and local (local:id local))) (if local - (list (lambda (f g t d) - (i386:local->base local))) - (list (lambda (f g t d) - (i386:global->base (+ (data-offset o g) d)))))))) - -(define (ident-ref->base info) - (lambda (o) - (let ((local (assoc-ref (.locals info) o))) - (if local - (list (lambda (f g t d) - (i386:local-ref->base local))) - TODO:ident-ref->base)))) + (list (lambda (f g ta t d) + (i386:local->base (local:id local)))) + (let ((global (assoc-ref (.globals info) o) )) + (if global + (let ((ptr (ident->pointer info o))) + (stderr "ident->accu PTR[~a]: ~a\n" o ptr) + (case ptr + ((-1) (list (lambda (f g ta t d) + (i386:global->base (+ (data-offset o g) d))))) + (else (list (lambda (f g ta t d) + (i386:global-address->base (+ (data-offset o g) d))))))) + (let ((constant (assoc-ref (.constants info) o))) + (if constant + (list (lambda (f g ta t d) + (i386:value->base constant))) + (list (lambda (f g ta t d) + (i386:global->base (+ ta (function-offset o f))))))))))))) (define (expr->accu info) (lambda (o) - (pmatch o - ((p-expr (fixed ,value)) (cstring->number value)) - ((p-expr (ident ,name)) (car ((ident->accu info) name))) - ((fctn-call . _) ((ast->info info) `(expr-stmt ,o))) - ((not (fctn-call . _)) ((ast->info info) o)) - ((sub . _) ((ast->info info) o)) ;; FIXME: expr-stmt - ((neg (p-expr (fixed ,value))) (- (cstring->number value))) + (let ((text (.text info)) + (locals (.locals info))) + ;;(stderr "expr->accu o=~a\n" o) + (pmatch o + ((p-expr (fixed ,value)) + (clone info #:text (append text (value->accu (cstring->number value))))) + ((p-expr (ident ,name)) + (clone info #:text (append text ((ident->accu info) name)))) + ((fctn-call . _) ((ast->info info) `(expr-stmt ,o))) + ((not (fctn-call . _)) ((ast->info info) o)) + ((neg (p-expr (fixed ,value))) + (clone info #:text (append text (value->accu (- (cstring->number value)))))) + + ((initzer ,initzer) ((expr->accu info) initzer)) + ((ref-to (p-expr (ident ,name))) + (clone info #:text + (append (.text info) + ((ident->accu info) name)))) - ;; g_cells[10].type - ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))) - (let* ((struct-type "scm") ;; FIXME - (struct (assoc-ref (.types info) struct-type)) - (size (length struct)) - (field-size 4) ;; FIXME:4, not fixed - (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b)))))))) - (index (cstring->number index)) - (text (.text info))) + ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,name)))))) + (let* (;;(type (assoc-ref (.types info) (list "struct" name))) + (type (list "struct" name)) + (fields (or (type->description info type) '())) + (size (type->size info type))) + (stderr "SIZEOF: type=~s => ~s\n" type size) + (clone info #:text + (append text + (list (lambda (f g ta t d) + (append + (i386:value->accu size)))))))) + + ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,array))) + (let ((value (cstring->number value))) + (clone info #:text + (append text + ((ident->base info) array) + (list (lambda (f g ta t d) + (append + (i386:value->accu value) + ;;(i386:byte-base-mem->accu) ;; FIXME: int/char + (i386:base-mem->accu) + ))))))) + + ;; f.field + ((d-sel (ident ,field) (p-expr (ident ,array))) + (let* ((type (ident->type info array)) + (fields (type->description info type)) + (field-size 4) ;; FIXME:4, not fixed + (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) + (text (.text info))) + (clone info #:text + (append text + ((ident->accu info) array) + (list (lambda (f g ta t d) + (i386:mem+n->accu offset))))))) + + ;; g_cells[10].type + ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))) + (let* ((type (ident->type info array)) + (fields (or (type->description info type) '())) + (size (type->size info type)) + (count (length fields)) + (field-size 4) ;; FIXME:4, not fixed + (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) + (index (cstring->number index)) + (text (.text info))) + (clone info #:text + (append text + (list (lambda (f g ta t d) + (append + (i386:value->base index) + (i386:base->accu) + (if (> count 1) (i386:accu+accu) '()) + (if (= count 3) (i386:accu+base) '()) + (i386:accu-shl 2)))) + ((ident->base info) array) + (list (lambda (f g ta t d) + (i386:base-mem+n->accu offset))))))) + + ;; g_cells[x].type + ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))) + (let* ((type (ident->type info array)) + (fields (or (type->description info type) '())) + (size (type->size info type)) + (count (length fields)) + (field-size 4) ;; FIXME:4, not fixed + (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) + (text (.text info))) + (clone info #:text + (append text + ((ident->base info) index) + (list (lambda (f g ta t d) + (append + (i386:base->accu) + (if (> count 1) (i386:accu+accu) '()) + (if (= count 3) (i386:accu+base) '()) + (i386:accu-shl 2)))) + ((ident->base info) array) + (list (lambda (f g ta t d) + (i386:base-mem+n->accu offset))))))) + + ;; g_functions[g_cells[fn].cdr].arity + ;; INDEX0: g_cells[fn].cdr + + ;;; index: (d-sel (ident ,cdr) (array-ref (p-expr (ident ,fn)) (p-expr (ident ,g_cells)))) + ;;((d-sel (ident ,arity) (array-ref (d-sel (ident ,cdr) (array-ref (p-expr (ident ,fn)) (p-expr (ident ,g_cells)))) (p-expr (ident ,g_functions))))) + ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array)))) + (let* ((empty (clone info #:text '())) + (index ((expr->accu empty) index)) + (type (ident->type info array)) + (fields (or (type->description info type) '())) + (size (type->size info type)) + (count (length fields)) + (field-size 4) ;; FIXME:4, not fixed + (rest (or (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))) + barf + '())) + (offset (* field-size (1- (length rest)))) + (text (.text info))) + ;;(stderr "COUNT=~a\n" count) + (clone info #:text + (append text + (.text index) + (list (lambda (f g ta t d) + (append + (i386:accu->base) + (if (> count 1) (i386:accu+accu) '()) + (if (= count 3) (i386:accu+base) '()) + (i386:accu-shl 2)))) + ((ident->base info) array) + (list (lambda (f g ta t d) + (i386:base-mem+n->accu offset))))))) + + ;;; FIXME: FROM INFO ...only zero?! + ((p-expr (fixed ,value)) + (let ((value (cstring->number value))) + (clone info #:text + (append text + (list (lambda (f g ta t d) + (i386:value->accu value))))))) + + ((p-expr (char ,value)) + (let ((value (char->integer (car (string->list value))))) + (clone info #:text + (append text + (list (lambda (f g ta t d) + (i386:value->accu value))))))) + + ((p-expr (ident ,name)) (clone info #:text (append text - (list (lambda (f g t d) - (append - (i386:value->base index) - (i386:base->accu) - (if (> size 1) (i386:accu+accu) '()) - (if (= size 3) (i386:accu+base) '()) - (i386:accu-shl 2)))) - ((ident->base info) array) - (list (lambda (f g t d) - (i386:accu+base))))))) + ((ident->accu info) name)))) - ;; g_cells[x].type - ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))) - (let* ((struct-type "scm") ;; FIXME - (struct (assoc-ref (.types info) struct-type)) - (size (length struct)) - (field-size 4) ;; FIXME:4, not fixed - (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b)))))))) - (text (.text info))) + ((de-ref (p-expr (ident ,name))) + (stderr "de-ref: ~a\n" name) (clone info #:text (append text - ((ident->base info) index) - (list (lambda (f g t d) + ((ident->accu info) name) + (list (lambda (f g ta t d) (append - (i386:base->accu) - (if (> size 1) (i386:accu+accu) '()) - (if (= size 3) (i386:accu+base) '()) - (i386:accu-shl 2)))) - ((ident->base info) array) - (list (lambda (f g t d) - (i386:base-mem+n->accu offset) - ;;(i386:accu+base) - )))))) + (cond ((equal? name "functionx") (i386:mem->accu)) + (else (i386:byte-mem->accu))))))))) ;; FIXME: type - (_ - (format (current-error-port) "SKIP expr->accu=~s\n" o) - info) - ))) + ;; GRR --> info again??!? + ((fctn-call . ,call) + ((ast->info info) `(expr-stmt ,o))) + + ((cond-expr . ,cond-expr) + ((ast->info info) `(expr-stmt ,o))) + + ;; FIXME + ;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o))) + ((post-inc (p-expr (ident ,name))) + (clone info #:text + (append text + ((ident->accu info) name) + ((ident-add info) name 1)))) + + ;; GRR --> info again??!? + ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o))) + ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o))) + ((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o))) + ((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o))) + + ((add (p-expr (ident ,name)) ,b) + (let* ((empty (clone info #:text '())) + (base ((expr->base empty) b))) + (clone info #:text + (append text + (.text base) + ((ident->accu info) name) + (list (lambda (f g ta t d) + (i386:accu+base))))))) + + ((add ,a ,b) + (let* ((empty (clone info #:text '())) + (accu ((expr->base empty) a)) + (base ((expr->base empty) b))) + (clone info #:text + (append text + (.text accu) + (.text base) + (list (lambda (f g ta t d) + (i386:accu+base))))))) + + ((sub ,a ,b) + (let* ((empty (clone info #:text '())) + (accu ((expr->base empty) a)) + (base ((expr->base empty) b))) + (clone info #:text + (append text + (.text accu) + (.text base) + (list (lambda (f g ta t d) + (i386:accu-base))))))) + + ((lshift ,a (p-expr (fixed ,value))) + (let* ((empty (clone info #:text '())) + (accu ((expr->base empty) a)) + (value (cstring->number value))) + (clone info #:text + (append text + (.text accu) + (list (lambda (f g ta t d) + (i386:accu-shl value))))))) + + ((div ,a ,b) + (let* ((empty (clone info #:text '())) + (accu ((expr->accu empty) a)) + (base ((expr->base empty) b))) + (clone info #:text + (append text + (.text accu) + (.text base) + (list (lambda (f g ta t d) + (i386:accu/base))))))) + + ;;((cast (type-name (decl-spec-list (type-spec (typename "SCM"))) (abs-declr (declr-fctn (declr-scope (abs-declr (pointer))) (param-list (param-decl (decl-spec-list (type-spec (typename "SCM")))))))) (d-sel (ident "function") (array-ref (d-sel (ident "cdr") (array-ref (p-expr (ident "fn")) (p-expr (ident "g_cells")))) (p-expr (ident "functions")))))) + ((cast ,cast ,o) + ((expr->accu info) o)) + + (_ + (format (current-error-port) "SKIP: expr->accu=~s\n" o) + barf + info))))) + +(define (expr->base info) + (lambda (o) + (let ((info ((expr->accu info) o))) + (clone info + #:text (append + (list (lambda (f g ta t d) + (i386:push-accu))) + (.text info) + (list (lambda (f g ta t d) + (append + (i386:accu->base) + (i386:pop-accu))))))))) (define (expr->Xaccu info) (lambda (o) (pmatch o ;; g_cells[10].type ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))) - (let* ((struct-type "scm") ;; FIXME - (struct (assoc-ref (.types info) struct-type)) - (size (length struct)) + (let* ((type (ident->type info array)) + (fields (or (type->description info type) '())) + (size (type->size info type)) + (count (length fields)) (field-size 4) ;; FIXME:4, not fixed - (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b)))))))) + (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) (index (cstring->number index)) (text (.text info))) (clone info #:text (append text - (list (lambda (f g t d) + (list (lambda (f g ta t d) (append (i386:value->base index) (i386:base->accu) - (if (> size 1) (i386:accu+accu) '()) - (if (= size 3) (i386:accu+base) '()) + (if (> count 1) (i386:accu+accu) '()) + (if (= count 3) (i386:accu+base) '()) (i386:accu-shl 2)))) + ;; de-ref: g_cells, non: arena + ;;((ident->base info) array) ((ident->base info) array) - (list (lambda (f g t d) - (i386:accu+base))))))) + (list (lambda (f g ta t d) + (append + (i386:accu+base) + (i386:accu+value offset)))))))) ;; g_cells[x].type ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))) - (let* ((struct-type "scm") ;; FIXME - (struct (assoc-ref (.types info) struct-type)) - (size (length struct)) + (let* ((type (ident->type info array)) + (fields (or (type->description info type) '())) + (size (type->size info type)) + (count (length fields)) (field-size 4) ;; FIXME:4, not fixed - (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b)))))))) + (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) (text (.text info))) (clone info #:text (append text ((ident->base info) index) - (list (lambda (f g t d) + (list (lambda (f g ta t d) (append (i386:base->accu) - (if (> size 1) (i386:accu+accu) '()) - (if (= size 3) (i386:accu+base) '()) + (if (> count 1) (i386:accu+accu) '()) + (if (= count 3) (i386:accu+base) '()) (i386:accu-shl 2)))) + ;; de-ref: g_cells, non: arena + ;;((ident->base info) array) ((ident->base info) array) - (list (lambda (f g t d) - (i386:accu+base))))))) + (list (lambda (f g ta t d) + (append + (i386:accu+base) + (i386:accu+value offset)))))))) + + ;;((d-sel (ident "cdr") (p-expr (ident "scm_make_cell")))) + ((d-sel (ident ,field) (p-expr (ident ,name))) + (let* ((type (ident->type info name)) + (fields (or (type->description info type) '())) + (field-size 4) ;; FIXME + (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) + (text (.text info))) + (clone info #:text + (append text + ((ident->accu info) name) + (list (lambda (f g ta t d) + (i386:accu+value offset))))))) (_ - (format (current-error-port) "SKIP expr->Xaccu=~s\n" o) + (format (current-error-port) "SKIP: expr->Xaccu=~s\n" o) + barf info) ))) -(define (string->global string) - (cons string (append (string->list string) (list #\nul)))) - -(define (ident->global name value) - (cons name (int->bv32 value))) - (define (ident->constant name value) (cons name value)) -(define (ident->type name value) - (cons name value)) +(define (make-type name type size description) + (cons name (list type size description))) + +(define (enum->type name fields) + (make-type name 'enum 4 fields)) + +(define (struct->type name fields) + (make-type name 'struct (* 4 (length fields)) fields)) ;; FIXME + +(define (decl->type o) + (pmatch o + ((fixed-type ,type) type) + ((struct-ref (ident ,name)) (list "struct" name)) + ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))));; "scm" + (list "struct" name)) ;; FIXME + (_ + ;;(stderr "SKIP: decl type=~s\n" o) + o))) (define (expr->global o) (pmatch o ((p-expr (string ,string)) (string->global string)) (_ #f))) -(define (dec->hex o) - (number->string o 16)) - (define (byte->hex o) (string->number (string-drop o 2) 16)) @@ -455,9 +783,9 @@ (define (case->jump-info info) (define (jump n) - (list (lambda (f g t d) (i386:Xjump n)))) + (list (lambda (f g ta t d) (i386:Xjump n)))) (define (jump-nz n) - (list (lambda (f g t d) (i386:Xjump-nz n)))) + (list (lambda (f g ta t d) (i386:Xjump-nz n)))) (define (statement->info info body-length) (lambda (o) (pmatch o @@ -478,7 +806,7 @@ (clause-length (length (text->list clause-text)))) (clone info #:text (append (.text info) - (list (lambda (f g t d) (i386:accu-cmp-value value))) + (list (lambda (f g ta t d) (i386:accu-cmp-value value))) (jump-nz clause-length) clause-text) #:globals (.globals clause-info))))) @@ -494,7 +822,7 @@ (clause-length (length (text->list clause-text)))) (clone info #:text (append (.text info) - (list (lambda (f g t d) (i386:accu-cmp-value value))) + (list (lambda (f g ta t d) (i386:accu-cmp-value value))) (jump-nz clause-length) clause-text) #:globals (.globals clause-info))))) @@ -515,7 +843,7 @@ (info (clone info #:text '())) (info ((ast->info info) o)) (jump-text (lambda (body-length) - (list (lambda (f g t d) (type body-length)))))) + (list (lambda (f g ta t d) (type body-length)))))) (lambda (body-length) (clone info #:text (append text @@ -545,6 +873,29 @@ (append text (.text (a-jump (+ b-length body-length))) (.text (b-jump body-length))))))) + ((or ,a ,b) + (let* ((text (.text info)) + (info (clone info #:text '())) + + (a-jump ((test->jump->info info) a)) + (a-text (.text (a-jump 0))) + (a-length (length (text->list a-text))) + + (jump-text (list (lambda (f g ta t d) (i386:Xjump 0)))) + (jump-length (length (text->list jump-text))) + + (b-jump ((test->jump->info info) b)) + (b-text (.text (b-jump 0))) + (b-length (length (text->list b-text))) + + (jump-text (list (lambda (f g ta t d) (i386:Xjump b-length))))) + + (lambda (body-length) + (clone info #:text + (append text + (.text (a-jump jump-length)) + jump-text + (.text (b-jump body-length))))))) ((array-ref . _) ((jump i386:jump-byte-z) o)) ((de-ref _) ((jump i386:jump-byte-z) o)) (_ ((jump i386:jump-z) o))))) @@ -563,47 +914,143 @@ (cons type name)) ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name)))) (cons type name)) + ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list (param-decl (decl-spec-list (type-spec (void))))))))) + (cons type name)) ;; FIXME function / int (_ (stderr "struct-field: no match: ~a" o) barf))) +(define (ast->type o) + (pmatch o + ((fixed-type ,type) + type) + ((struct-ref (ident ,type)) + (list "struct" type)) + (_ (stderr "SKIP: type=~s\n" o) + "int"))) + +(define i386:type-alist + '(("char" . (builtin 1 #f)) + ("int" . (builtin 4 #f)))) + +(define (type->size info o) + ;; (stderr "types=~s\n" (.types info)) + ;; (stderr "type->size o=~s => ~s\n" o (cadr (assoc-ref (.types info) o))) + (cadr (assoc-ref (.types info) o))) + +(define (ident->decl info o) + ;; (stderr "ident->decl o=~s\n" o) + ;; (stderr " types=~s\n" (.types info)) + ;; (stderr " local=~s\n" (assoc-ref (.locals info) o)) + ;; (stderr " global=~s\n" (assoc-ref (.globals info) o)) + (or (assoc-ref (.locals info) o) + (assoc-ref (.globals info) o) + (begin + (stderr "NO IDENT: ~a\n" (assoc-ref (.functions info) o)) + (assoc-ref (.functions info) o)))) + +(define (ident->type info o) + (and=> (ident->decl info o) car)) + +(define (ident->pointer info o) + (or (and=> (ident->decl info o) global:pointer) 0)) + +(define (type->description info o) + ;; (stderr "type->description =~s\n" o) + ;; (stderr "types=~s\n" (.types info)) + ;; (stderr "type->description o=~s ==> ~s\n" o (caddr (assoc-ref (.types info) o))) + ;; (stderr " assoc ~a\n" (assoc-ref (.types info) o)) + (caddr (assoc-ref (.types info) o))) + +(define (local? o) ;; formals < 0, locals > 0 + (positive? (local:id o))) + (define (ast->info info) (lambda (o) (let ((globals (.globals info)) (locals (.locals info)) + (constants (.constants info)) (text (.text info))) - (define (add-local name) - (let ((locals (acons name (1+ (length (filter positive? (map cdr locals)))) locals))) + (define (add-local locals name type pointer) + (let* ((id (1+ (length (filter local? (map cdr locals))))) + (locals (cons (make-local name type pointer id) locals))) locals)) - ;;(stderr "\nS=~a\n" o) + ;; (stderr "\n ast->info=~s\n" o) ;; (stderr " globals[~a=>~a]: ~a\n" (length globals) (length (append-map cdr globals)) (map (lambda (s) (if (string? s) (string-delete #\newline s))) (map car globals))) ;; (stderr " text=~a\n" text) ;; (stderr " info=~a\n" info) ;; (stderr " globals=~a\n" globals) (pmatch o - (((trans-unit . _) . _) ((ast-list->info info) o)) - ((trans-unit . ,elements) ((ast-list->info info) elements)) + (((trans-unit . _) . _) + ((ast-list->info info) o)) + ((trans-unit . ,elements) + ((ast-list->info info) elements)) ((fctn-defn . _) ((function->info info) o)) ((comment . _) info) ((cpp-stmt (define (name ,name) (repl ,value))) - (stderr "SKIP: #define ~s ~s\n" name value) info) - ;; ; + ((cast (type-name (decl-spec-list (type-spec (void)))) _) + info) + + ;; FIXME: expr-stmt wrapper? + (trans-unit info) ((expr-stmt) info) + ((assn-expr . ,assn-expr) + ((ast->info info) `(expr-stmt ,o))) + + ((d-sel . ,d-sel) + (let ((expr ((expr->accu info) `(d-sel ,@d-sel)))) + expr)) ((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements)) ((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))) (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME - (clone info #:text (append text (list (lambda (f g t d) (asm->hex arg0)))))) + (clone info #:text (append text (list (lambda (f g ta t d) (asm->hex arg0)))))) (let* ((globals (append globals (filter-map expr->global expr-list))) (info (clone info #:globals globals)) (args (map (expr->arg info) expr-list))) - (clone info #:text - (append text (list (lambda (f g t d) - (apply i386:call (cons* f g t d - (+ t (function-offset name f)) args))))) - #:globals globals)))) + (if ;;#t ;;(assoc-ref globals name) + (not (equal? name "functionx")) + (clone info #:text + (append text + (list (lambda (f g ta t d) + (apply i386:call (cons* f g ta t d + (+ t (function-offset name f)) args))))) + #:globals globals) + (let* ((empty (clone info #:text '())) + ;;(accu ((ident->accu info) name)) + (accu ((expr->accu empty) `(p-expr (ident ,name))))) + (stderr "DINGES: ~a\n" o) + (clone info #:text + (append text + (list (lambda (f g ta t d) + '(#x90))) + ;;accu + (.text accu) + (list (lambda (f g ta t d) + '(#x90))) + (list (lambda (f g ta t d) + (apply i386:call-accu (cons* f g ta t d args))))) + #:globals globals)))))) + + ;;((expr-stmt (fctn-call (d-sel (ident "function") (array-ref (d-sel (ident "cdr") (array-ref (p-expr (ident "fn")) (p-expr (ident "g_cells")))) (p-expr (ident "g_functions")))) (expr-list)))) + ((expr-stmt (fctn-call ,function (expr-list . ,expr-list))) + (let* ((globals (append globals (filter-map expr->global expr-list))) + (info (clone info #:globals globals)) + (args (map (expr->arg info) expr-list)) + (empty (clone info #:text '())) + (accu ((expr->accu empty) function))) + (clone info #:text + (append text + (list (lambda (f g ta t d) + '(#x90))) + (.text accu) + (list (lambda (f g ta t d) + '(#x90))) + (list (lambda (f g ta t d) + (apply i386:call-accu (cons* f g ta t d args))))) + #:globals globals))) ((if ,test ,body) (let* ((text-length (length text)) @@ -626,6 +1073,37 @@ body-text) #:globals (.globals body-info)))) + ((if ,test ,then ,else) + (let* ((text-length (length text)) + + (test-jump->info ((test->jump->info info) test)) + (test+jump-info (test-jump->info 0)) + (test-length (length (.text test+jump-info))) + + (then-info ((ast->info test+jump-info) then)) + (text-then-info (.text then-info)) + (then-text (list-tail text-then-info test-length)) + (then-jump-text (list (lambda (f g ta t d) (i386:Xjump 0)))) + (then-jump-length (length (text->list then-jump-text))) + (then-length (+ (length (text->list then-text)) then-jump-length)) + + (else-info ((ast->info test+jump-info) else)) + (text-else-info (.text else-info)) + (else-text (list-tail text-else-info test-length)) + (else-length (length (text->list else-text))) + + (text+test-text (.text (test-jump->info (+ then-length then-jump-length)))) + (test-text (list-tail text+test-text text-length)) + (then-jump-text (list (lambda (f g ta t d) (i386:Xjump else-length))))) + + (clone info #:text + (append text + test-text + then-text + then-jump-text + else-text) + #:globals (.globals then-info)))) ;; FIXME: else-globals + ((expr-stmt (cond-expr ,test ,then ,else)) (let* ((text-length (length text)) @@ -638,8 +1116,9 @@ (then-text (list-tail text-then-info test-length)) (then-length (length (text->list then-text))) - (jump-text (list (lambda (f g t d) (i386:jump 0)))) + (jump-text (list (lambda (f g ta t d) (i386:Xjump 0)))) (jump-length (length (text->list jump-text))) + (test+then+jump-info (clone then-info #:text (append (.text then-info) jump-text))) @@ -651,7 +1130,7 @@ (text+test-text (.text (test-jump->info (+ then-length jump-length)))) (test-text (list-tail text+test-text text-length)) - (jump-text (list (lambda (f g t d) (i386:jump else-length))))) + (jump-text (list (lambda (f g ta t d) (i386:Xjump else-length))))) (clone info #:text (append text @@ -662,10 +1141,7 @@ #:globals (.globals else-info)))) ((switch ,expr (compd-stmt (block-item-list . ,cases))) - (let* ((accu ((expr->accu info) expr)) - (expr (if (info? accu) accu ;; AAARGH - (clone info #:text - (append text (list accu))))) + (let* ((expr ((expr->accu info) expr)) (empty (clone info #:text '())) (case-infos (map (case->jump-info empty) cases)) (case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos)) @@ -696,9 +1172,11 @@ (test+jump-info (test-jump->info 0)) (test-length (length (text->list (.text test+jump-info)))) - (skip-body-text (list (lambda (f g t d) (i386:jump (+ 2 body-length step-length))))) ;; FIXME: 2 + (skip-body-text (list (lambda (f g ta t d) + (i386:Xjump (+ body-length step-length))))) - (jump-text (list (lambda (f g t d) (i386:jump (- (+ body-length step-length test-length)))))) + (jump-text (list (lambda (f g ta t d) + (i386:Xjump (- (+ body-length step-length test-length)))))) (jump-length (length (text->list jump-text))) (test-text (.text (test-jump->info jump-length)))) @@ -724,10 +1202,10 @@ (test+jump-info (test-jump->info 0)) (test-length (length (text->list (.text test+jump-info)))) - - (skip-body-text (list (lambda (f g t d) (i386:jump (+ 2 body-length))))) ;; FIXME: 2 - - (jump-text (list (lambda (f g t d) (i386:jump (- (+ body-length test-length)))))) + (skip-body-text (list (lambda (f g ta t d) + (i386:Xjump body-length)))) + (jump-text (list (lambda (f g ta t d) + (i386:Xjump (- (+ body-length test-length)))))) (jump-length (length (text->list jump-text))) (test-text (.text (test-jump->info jump-length)))) @@ -745,17 +1223,19 @@ ((ast->info info) statement))) ((goto (ident ,label)) - (let ((offset (length (text->list text)))) + (let ((offset (length (text->list text))) + (jump (lambda (n) (i386:Xjump n)))) (clone info #:text (append text - (list (lambda (f g t d) - (i386:jump (- (label-offset (.function info) label f) offset)))))))) + (list (lambda (f g ta t d) + (jump (- (label-offset (.function info) label f) offset (length (jump 0)))))))))) + ;;; FIXME: only zero?! ((p-expr (ident ,name)) (clone info #:text (append text ((ident->accu info) name) - (list (lambda (f g t d) + (list (lambda (f g ta t d) (append (i386:accu-zero?))))))) @@ -763,7 +1243,7 @@ (let ((value (cstring->number value))) (clone info #:text (append text - (list (lambda (f g t d) + (list (lambda (f g ta t d) (append (i386:value->accu value) (i386:accu-zero?)))))))) @@ -772,7 +1252,7 @@ (clone info #:text (append text ((ident->accu info) name) - (list (lambda (f g t d) + (list (lambda (f g ta t d) (append (i386:byte-mem->accu))))))) @@ -780,7 +1260,7 @@ (let ((info ((ast->info info) `(expr-stmt ,o)))) (clone info #:text (append (.text info) - (list (lambda (f g t d) + (list (lambda (f g ta t d) (i386:accu-zero?))))))) ;; FIXME @@ -789,9 +1269,9 @@ (clone info #:text (append text ((ident->accu info) name) - (list (lambda (f g t d) + ((ident-add info) name 1) + (list (lambda (f g ta t d) (append - (i386:local-add (assoc-ref locals name) 1) (i386:accu-zero?))))))) ((post-inc ,expr) ((ast->info info) `(expr-stmt ,o))) ((post-dec ,expr) ((ast->info info) `(expr-stmt ,o))) @@ -800,360 +1280,174 @@ ;; i++ ((expr-stmt (post-inc (p-expr (ident ,name)))) - (clone info #:text - (append text (list (lambda (f g t d) - (i386:local-add (assoc-ref locals name) 1)))))) + (clone info #:text (append text ((ident-add info) name 1)))) ;; ++i ((expr-stmt (pre-inc (p-expr (ident ,name)))) + (or (assoc-ref locals name) barf) (clone info #:text - (append text (list (lambda (f g t d) - (append - (i386:local-add (assoc-ref locals name) 1) - (i386:local->accu (assoc-ref locals name)) - (i386:accu-zero?))))))) + (append text + ((ident-add info) name 1) + ((ident->accu info) name) + (list (lambda (f g ta t d) + (append + ;;(i386:local->accu (local:id (assoc-ref locals name))) + (i386:accu-zero?))))))) ;; i-- ((expr-stmt (post-dec (p-expr (ident ,name)))) + (or (assoc-ref locals name) barf) (clone info #:text (append text ((ident->accu info) name) - (list (lambda (f g t d) + ((ident-add info) name -1) + (list (lambda (f g ta t d) (append - (i386:local-add (assoc-ref locals name) -1) + ;;(i386:local-add (local:id (assoc-ref locals name)) -1) (i386:accu-zero?))))))) ;; --i ((expr-stmt (pre-dec (p-expr (ident ,name)))) + (or (assoc-ref locals name) barf) (clone info #:text - (append text (list (lambda (f g t d) - (append - (i386:local-add (assoc-ref locals name) -1) - (i386:local->accu (assoc-ref locals name)) - (i386:accu-zero?))))))) + (append text + ((ident-add info) name -1) + ((ident->accu info) name) + (list (lambda (f g ta t d) + (append + ;;(i386:local-add (local:id (assoc-ref locals name)) -1) + ;;(i386:local->accu (local:id (assoc-ref locals name))) + (i386:accu-zero?))))))) ((not ,expr) (let* ((test-info ((ast->info info) expr))) (clone info #:text (append (.text test-info) - (list (lambda (f g t d) + (list (lambda (f g ta t d) (append (i386:accu-not) (i386:accu-zero?))))) #:globals (.globals test-info)))) - ((eq (p-expr (ident ,a)) (p-expr (fixed ,b))) - (let ((b (cstring->number b))) + ((eq ,a ,b) + (let* ((base ((expr->base info) a)) + (empty (clone base #:text '())) + (accu ((expr->accu empty) b))) (clone info #:text (append text - ((ident->base info) a) - (list (lambda (f g t d) - (append - (i386:value->accu b) - (i386:sub-base)))))))) + (.text base) + (.text accu) + (list (lambda (f g ta t d) + (i386:sub-base))))))) - ((eq (p-expr (ident ,a)) (p-expr (char ,b))) - (let ((b (char->integer (car (string->list b))))) + ((gt ,a ,b) + (let* ((base ((expr->base info) a)) + (empty (clone base #:text '())) + (accu ((expr->accu empty) b))) (clone info #:text (append text - ((ident->base info) a) - (list (lambda (f g t d) - (append - (i386:value->accu b) - (i386:sub-base)))))))) + (.text base) + (.text accu) + (list (lambda (f g ta t d) + (i386:sub-base))))))) - ((eq (p-expr (ident ,a)) (neg (p-expr (fixed ,b)))) - (let ((b (- (cstring->number b)))) + ((ne ,a ,b) + (let* ((base ((expr->base info) a)) + (empty (clone base #:text '())) + (accu ((expr->accu empty) b))) (clone info #:text (append text - ((ident->base info) a) - (list (lambda (f g t d) + (.text base) + (.text accu) + (list (lambda (f g ta t d) (append - (i386:value->accu b) - (i386:sub-base)))))))) - - ((eq (fctn-call . ,call) (p-expr (fixed ,b))) - (let ((b (cstring->number b)) - (info ((ast->info info) `(expr-stmt (fctn-call ,@call))))) - (clone info #:text - (append text - (.text info) - (list (lambda (f g t d) - (append - (i386:value->base b) - (i386:sub-base)))))))) - - ((eq (fctn-call . ,call) (p-expr (char ,b))) - (let ((b (char->integer (car (string->list b)))) - (info ((ast->info info) `(expr-stmt (fctn-call ,@call))))) - (clone info #:text - (append text - (.text info) - (list (lambda (f g t d) - (append - (i386:value->base b) - (i386:sub-base)))))))) - - ((cast (type-name (decl-spec-list (type-spec (void)))) _) - info) - - ((eq (fctn-call . ,call) (p-expr (ident ,b))) - (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call))))) - (clone info #:text - (append text - (.text info) - ((ident->base info) b) - (list (lambda (f g t d) - (append - (i386:sub-base)))))))) - - ((eq (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b)))) - (clone info #:text - (append text - ((ident->accu info) a) - (list (lambda (f g t d) - (append - (i386:byte-mem->base) - (i386:local->accu (assoc-ref locals b)) - (i386:byte-mem->accu) - (i386:byte-test-base))))))) - - ((eq (de-ref (p-expr (ident ,a))) (p-expr (char ,b))) - (let ((b (char->integer (car (string->list b))))) - (clone info #:text - (append text - ((ident->accu info) a) - (list (lambda (f g t d) - (append - (i386:byte-mem->base) - (i386:value->accu b) - (i386:byte-test-base)))))))) - - ((eq (d-sel (ident ,field) . ,d-sel) (p-expr (fixed ,b))) - (let* ((expr ((expr->Xaccu info) `(d-sel (ident ,field) ,@d-sel))) - (b (cstring->number b)) - - (struct-type "scm") ;; FIXME - (struct (assoc-ref (.types info) struct-type)) - (size (length struct)) - (field-size 4) ;; FIXME:4, not fixed - (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))) - (clone info #:text (append (.text expr) - (list (lambda (f g t d) - (append - (i386:mem+n->accu offset) - (i386:value->base b) - (i386:test-base)))))))) - - ((gt (p-expr (ident ,a)) (p-expr (fixed ,b))) - (let ((b (cstring->number b))) - (clone info #:text - (append text - ((ident->base info) a) - (list (lambda (f g t d) - (append - (i386:value->accu b) - (i386:sub-base)))))))) - - ((gt (p-expr (ident ,a)) (neg (p-expr (fixed ,b)))) - (let ((b (- (cstring->number b)))) - (clone info #:text - (append text - ((ident->base info) a) - (list (lambda (f g t d) - (append - (i386:value->accu b) - (i386:sub-base)))))))) - - - ((ne (p-expr (ident ,a)) (p-expr (fixed ,b))) - (let ((b (cstring->number b))) - (clone info #:text - (append text - ((ident->base info) a) - (list (lambda (f g t d) - (append - (i386:value->accu b) (i386:sub-base) (i386:xor-zf)))))))) - ((ne (p-expr (ident ,a)) (p-expr (char ,b))) - (let ((b (char->integer (car (string->list b))))) + ((lt ,a ,b) + (let* ((base ((expr->base info) a)) + (empty (clone base #:text '())) + (accu ((expr->accu empty) b))) (clone info #:text (append text - ((ident->base info) a) - (list (lambda (f g t d) - (append - (i386:value->accu b) - (i386:sub-base) - (i386:xor-zf)))))))) + (.text base) + (.text accu) + (list (lambda (f g ta t d) + (i386:base-sub))))))) - ((ne (p-expr (ident ,a)) (neg (p-expr (fixed ,b)))) - (let ((b (- (cstring->number b)))) + ;; TODO: byte dinges + ((Xsub ,a ,b) + (let* ((base ((expr->base info) a)) + (empty (clone base #:text '())) + (accu ((expr->accu empty) b))) (clone info #:text (append text - ((ident->base info) a) - (list (lambda (f g t d) - (append - (i386:value->accu b) - (i386:sub-base) - (i386:xor-zf)))))))) + (.text base) + (.text accu) + (list (lambda (f g ta t d) + (i386:base-sub))))))) - ((ne (p-expr (ident ,a)) (p-expr (ident ,constant))) - (let ((b (assoc-ref (.constants info) constant))) - (clone info #:text - (append text - ((ident->base info) a) - (list (lambda (f g t d) - (append - (i386:value->accu b) - (i386:sub-base) - (i386:xor-zf)))))))) - - ((ne (fctn-call . ,call) (p-expr (fixed ,b))) - (let ((b (cstring->number b)) - (info ((ast->info info) `(expr-stmt (fctn-call ,@call))))) - (clone info #:text - (append text - (.text info) - (list (lambda (f g t d) - (append - (i386:value->base b) - (i386:sub-base) - (i386:xor-zf)))))))) - - ((ne (fctn-call . ,call) (p-expr (ident ,b))) - (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call))))) - (clone info #:text - (append text - (.text info) - ((ident->base info) b) - (list (lambda (f g t d) - (append - (i386:sub-base) - (i386:xor-zf)))))))) - - ((ne (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b)))) - (clone info #:text - (append text - ((ident->accu info) a) - (list (lambda (f g t d) - (append - (i386:byte-mem->base) - (i386:local->accu (assoc-ref locals b)) - (i386:byte-mem->accu) - (i386:byte-test-base) - (i386:xor-zf))))))) - - ((ne (de-ref (p-expr (ident ,a))) (p-expr (char ,b))) - (let ((b (char->integer (car (string->list b))))) - (clone info #:text - (append text - ((ident->accu info) a) - (list (lambda (f g t d) - (append - (i386:byte-mem->base) - (i386:value->accu b) - (i386:byte-test-base) - (i386:xor-zf)))))))) - - ;; CAR (x) != 1 // cell_nil - ((ne (d-sel . ,d-sel) (p-expr (fixed ,b))) - (let ((expr ((expr->accu info) `(d-sel ,@d-sel))) - (b (cstring->number b))) - (clone info #:text - (append text - (.text expr) - (list (lambda (f g t d) - (append - (i386:value->base b) - (i386:sub-base) - (i386:xor-zf)))))))) - - ;; CAR (x) != PAIR - ((ne (d-sel . ,d-sel) (p-expr (ident ,constant))) - (let ((expr ((expr->accu info) `(d-sel ,@d-sel))) - (b (assoc-ref (.constants info) constant))) - (clone info #:text - (append text - (.text expr) - (list (lambda (f g t d) - (append - (i386:value->base b) - (i386:sub-base) - (i386:xor-zf)))))))) - - ((lt (p-expr (ident ,a)) (p-expr (fixed ,b))) - (let ((b (cstring->number b))) - (clone info #:text - (append text - ((ident->base info) a) - (list (lambda (f g t d) - (append - (i386:value->accu b) - (i386:base-sub)))))))) - - ((sub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b)))) + ((Xsub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b)))) (clone info #:text (append text - (list (lambda (f g t d) + (list (lambda (f g ta t d) (append - ;;(and (stderr "006\n") '()) - (i386:local->accu (assoc-ref locals a)) + (i386:local->accu (local:id (assoc-ref locals a))) (i386:byte-mem->base) - (i386:local->accu (assoc-ref locals b)) + (i386:local->accu (local:id (assoc-ref locals b))) (i386:byte-mem->accu) (i386:byte-sub-base))))))) - ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name))) + ;; g_cells[0] + ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,array))) (let ((value (cstring->number value))) (clone info #:text (append text - ((ident->base info) name) - (list (lambda (f g t d) - (append - (i386:value->accu value) - (i386:byte-base-mem->accu)))))))) ; FIXME: type: char + ((ident->base info) array) + (list (lambda (f g ta t d) + (append + (i386:value->accu value) + ;;(i386:byte-base-mem->accu) + (i386:base-mem->accu) + ))))))) ; FIXME: type: char - ((array-ref (p-expr (ident ,name)) (p-expr (ident ,index))) + ;; g_cells[a] + ((array-ref (p-expr (ident ,index)) (p-expr (ident ,array))) (clone info #:text (append text - ((ident->base info) name) - ((ident->accu info) index) - (list (lambda (f g t d) - (i386:byte-base-mem->accu)))))) ; FIXME: type: char + ((ident->base info) index) ;; FIXME: chars! index*size + ((ident->accu info) array) + (list (lambda (f g ta t d) + ;;(i386:byte-base-mem->accu) + (i386:base-mem->accu) + ))))) ; FIXME: type: char ((return ,expr) (let ((accu ((expr->accu info) expr))) - (if (info? accu) - (clone accu #:text - (append (.text accu) (list (i386:ret (lambda _ '()))))) - (clone info #:text - (append text (list (i386:ret accu))))))) + (clone accu #:text + (append (.text accu) (list (i386:ret (lambda _ '()))))))) ;; int i; ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name)))) - (clone info #:locals (add-local name))) - - ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value)))))) - (let* ((locals (add-local name)) - (info (clone info #:locals locals))) - (let ((value (cstring->number value))) - (clone info #:text - (append text ((value->ident info) name value)))))) + (if (.function info) + (clone info #:locals (add-local locals name type 0)) + (clone info #:globals (append globals (list (ident->global name type 0 0)))))) ;; int i = 0; ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value)))))) - (let* ((locals (add-local name)) - (info (clone info #:locals locals)) - (value (cstring->number value))) - (clone info #:text - (append text - ((value->ident info) name value))))) + (let ((value (cstring->number value))) + (if (.function info) + (let* ((locals (add-local locals name type 0)) + (info (clone info #:locals locals))) + (clone info #:text + (append text + ((value->ident info) name value)))) + (clone info #:globals (append globals (list (ident->global name type 0 value))))))) ;; char c = 'A'; ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value)))))) - (let* ((locals (add-local name)) + (if (not (.function info)) decl-barf0) + (let* ((locals (add-local locals name type 0)) (info (clone info #:locals locals)) (value (char->integer (car (string->list value))))) (clone info #:text @@ -1162,7 +1456,8 @@ ;; int i = -1; ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value))))))) - (let* ((locals (add-local name)) + (if (not (.function info)) decl-barf1) + (let* ((locals (add-local locals name type 0)) (info (clone info #:locals locals)) (value (- (cstring->number value)))) (clone info #:text @@ -1171,7 +1466,8 @@ ;; int i = argc; ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local)))))) - (let* ((locals (add-local name)) + (if (not (.function info)) decl-barf2) + (let* ((locals (add-local locals name type 0)) (info (clone info #:locals locals))) (clone info #:text (append text @@ -1180,78 +1476,98 @@ ;; char *p = "t.c"; ;;(decl (decl-spec-list (type-spec (fixed-type "char"))) (init-declr-list (init-declr (ptr-declr (pointer) (ident "p")) (initzer (p-expr (string "t.c\n")))))) - ((decl (decl-spec-list (type-spec (fixed-type _))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,value)))))) - (let* ((locals (add-local name)) + ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,value)))))) + (if (not (.function info)) decl-barf3) + (let* ((locals (add-local locals name type 1)) (globals (append globals (list (string->global value)))) (info (clone info #:locals locals #:globals globals))) (clone info #:text (append text - (list (lambda (f g t d) + (list (lambda (f g ta t d) (append (i386:global->accu (+ (data-offset value g) d))))) ((accu->ident info) name))))) ;; char arena[20000]; - ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count)))))) - (let* ((globals (.globals info)) - (count (cstring->number count)) - (size 1) ;; FIXME - (array (list (ident->global name #xaaaaaaaa))) ;;FIXME: deref? - (dummy (list (cons (string->list "dummy") - (string->list (make-string (* count size) #\nul)))))) - (clone info #:globals (append globals array dummy)))) - - ;; struct scm* arena[200]; - ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count)))))) - (let* ((globals (.globals info)) - (count (cstring->number count)) - (size 12) ;; FIXME - (array (list (ident->global name #x58585858))) ;;FIXME: deref? - (dummy (list (cons (string->list "dummy") - (string->list (make-string (* count size) #\nul)))))) - (stderr "(* count size): ~a\n" (* count size)) - (clone info #:globals (append globals array dummy)))) + ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count)))))) + (let ((type (ast->type type))) + (if (.function info) + TODO:decl-array + (let* ((globals (.globals info)) + (count (cstring->number count)) + (size (type->size info type)) + ;;;;(array (make-global name type -1 (string->list (make-string (* count size) #\nul)))) + (array (make-global name type -1 (string->list (make-string (* count size) #\nul)))) + (globals (append globals (list array)))) + (clone info + #:globals globals))))) ;;struct scm *g_cells = (struct scm*)arena; ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (cast (type-name (decl-spec-list (type-spec (struct-ref (ident ,=type)))) (abs-declr (pointer))) (p-expr (ident ,value))))))) - (let* ((locals (add-local name)) - (info (clone info #:locals locals))) - (clone info #:text - (append text - ((ident->accu info) name) - ((accu->ident info) value))))) ;; FIXME: deref? + ;;(stderr "0TYPE: ~s\n" type) + (if (.function info) + (let* ((locals (add-local locals name type 1)) + (info (clone info #:locals locals))) + (clone info #:text + (append text + ((ident->accu info) name) + ((accu->ident info) value)))) ;; FIXME: deref? + (let* ((globals (append globals (list (ident->global name type 1 0)))) + (info (clone info #:globals globals))) + (clone info #:text + (append text + ((ident->accu info) name) + ((accu->ident info) value)))))) ;; FIXME: deref? + + ;; SCM tmp; + ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name)))) + ;;(stderr "1TYPE: ~s\n" type) + (if (.function info) + (clone info #:locals (add-local locals name type 0)) + (clone info #:globals (append globals (list (ident->global name type 0 0)))))) ;; SCM g_stack = 0; - ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _)) - ((ast->info info) (list-head o (- (length o) 1)))) - - ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value)))))) + ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value)))))) + ;;(stderr "2TYPE: ~s\n" type) (if (.function info) - (let* ((locals (add-local name)) + (let* ((locals (add-local locals name type 0)) (globals (append globals (list (string->global value)))) (info (clone info #:locals locals #:globals globals))) (clone info #:text (append text - (list (lambda (f g t d) + (list (lambda (f g ta t d) (append (i386:global->accu (+ (data-offset value g) d))))) ((accu->ident info) name)))) (let* ((value (length (globals->data globals))) - (globals (append globals (list (ident->global name value))))) + (globals (append globals (list (ident->global name type 0 value))))) (clone info #:globals globals)))) + ;; SCM g_stack = 0; // comment + ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _)) + ((ast->info info) (list-head o (- (length o) 1)))) + ;; SCM i = argc; ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local)))))) - (let* ((locals (add-local name)) - (info (clone info #:locals locals))) - (clone info #:text - (append text - ((ident->accu info) local) - ((accu->ident info) name))))) - + ;;(stderr "3TYPE: ~s\n" type) + (if (.function info) + (let* ((locals (add-local locals name type 0)) + (info (clone info #:locals locals))) + (clone info #:text + (append text + ((ident->accu info) local) + ((accu->ident info) name)))) + (let* ((globals (append globals (list (ident->global name type 0 0)))) + (info (clone info #:globals globals))) + (clone info #:text + (append text + ((ident->accu info) local) + ((accu->ident info) name)))))) + ;; int i = f (); ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call))))) - (let* ((locals (add-local name)) + ;;(stderr "4TYPE: ~s\n" type) + (let* ((locals (add-local locals name type 0)) (info (clone info #:locals locals))) (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call))))) (clone info @@ -1260,9 +1576,29 @@ ((accu->ident info) name)) #:locals locals)))) + ;; 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) + (list (lambda (f g ta t d) + (append + ;;(i386:value->base t) + ;;(i386:accu+base) + (i386:value->base ta) + (i386:accu+base))))) + #:locals locals))) + ;; SCM x = car (e); - ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call))))) - (let* ((locals (add-local name)) + ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call))))) + ;;(stderr "5TYPE: ~s\n" type) + (let* ((locals (add-local locals name type 0)) (info (clone info #:locals locals))) (let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call))))) (clone info @@ -1272,163 +1608,304 @@ ;; char *p = (char*)g_cells; ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (cast (type-name (decl-spec-list (type-spec (fixed-type ,=type))) (abs-declr (pointer))) (p-expr (ident ,value))))))) - (let* ((locals (add-local name)) - (info (clone info #:locals locals))) - (clone info #:text - (append text - ((ident->accu info) value) - ((accu->ident info) name))))) + ;;(stderr "6TYPE: ~s\n" type) + (if (.function info) + (let* ((locals (add-local locals name type 1)) + (info (clone info #:locals locals))) + (clone info #:text + (append text + ((ident->accu info) value) + ((accu->ident info) name)))) + (let* ((globals (append globals (list (ident->global name type 1 0)))) + (here (data-offset name globals)) + (there (data-offset value globals))) + (clone info + #:globals globals + #:init (append (.init info) + (list (lambda (functions globals ta t d data) + (append + (list-head data here) + ;;; FIXME: type + ;;; char *x = arena; + (int->bv32 (+ d (data-offset value globals))) + ;;; char *y = x; + ;;;(list-head (list-tail data there) 4) + (list-tail data (+ here 4)))))))))) ;; char *p = g_cells; - ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value)))))) - (let* ((locals (add-local name)) - (info (clone info #:locals locals))) - (clone info #:text - (append text - ((ident->accu info) value) - ((accu->ident info) name))))) + ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value)))))) + ;;(stderr "7TYPE: ~s\n" type) + (let ((type (decl->type type))) + ;;(stderr "0DECL: ~s\n" type) + (if (.function info) + (let* ((locals (add-local locals name type 1)) + (info (clone info #:locals locals))) + (clone info #:text + (append text + ((ident->accu info) value) + ((accu->ident info) name)))) + (let* ((globals (append globals (list (ident->global name type 1 0)))) + (here (data-offset name globals)) + (there (data-offset value globals))) + (clone info + #:globals globals + #:init (append (.init info) + (list (lambda (functions globals ta t d data) + (append + (list-head data here) + ;;; FIXME: type + ;;; char *x = arena;p + (int->bv32 (+ d (data-offset value globals))) + ;;; char *y = x; + ;;;(list-head (list-tail data there) 4) + (list-tail data (+ here 4))))))))))) ;; enum ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields))))) - (let ((type (ident->type name "enum")) + (let ((type (enum->type name fields)) (constants (map ident->constant (map cadadr fields) (iota (length fields))))) - (clone info #:types (append (.types info) (list type)) + (clone info + #:types (append (.types info) (list type)) #:constants (append constants (.constants info))))) ;; struct ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields))))) - (let* ((type (ident->type name (map struct-field fields)))) + (let* ((type (struct->type (list "struct" name) (map struct-field fields)))) + (stderr "type: ~a\n" type) (clone info #:types (append (.types info) (list type))))) - - ;; i = 0; - ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value)))) - ;;(stderr "RET LOCAL[~a]: ~a\n" name (assoc-ref locals name)) - (let ((value (cstring->number value))) - (clone info #:text (append text ((value->ident info) name value))))) - ;; i = 0; ...from for init FIXME - ((assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value))) - (let ((value (cstring->number value))) - (clone info #:text (append text ((value->ident info) name value))))) - - ;; i = i + 48; - ((expr-stmt (assn-expr (p-expr (ident ,a)) (op _) (add (p-expr (ident ,b)) (p-expr (fixed ,value))))) - (let ((value (cstring->number value))) + ;; *p++ = b; + ((expr-stmt (assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)) + (when (not (equal? op "=")) + (stderr "OOOPS0.0: op=~s\n" op) + barf) + (let* ((empty (clone info #:text '())) + (base ((expr->base empty) b))) (clone info #:text (append text - ((ident->base info) b) - (list (lambda (f g t d) - (append - (i386:value->accu value) - (i386:accu+base)))) - ((accu->ident info) a))))) - - ;; c = 'A'; - ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (char ,value)))) - (let ((value (char->integer (car (string->list value))))) - (clone info #:text (append text ((value->ident info) name value))))) - - ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (fctn-call . ,call))) - (let* ((info ((ast->info info) `(expr-stmt (fctn-call ,@call))))) - (clone info #:text (append (.text info) ((accu->ident info) name))))) - - ;; p = g_cell; - ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (ident ,value)))) - (clone info #:text - (append text - ((ident->accu info) value) - ((accu->ident info) name)))) - - ;; *p = 0; - ((expr-stmt (assn-expr (de-ref (p-expr (ident ,name))) (op _) (p-expr (fixed ,value)))) - (let ((value (cstring->number value))) - (clone info #:text (append text - (list (lambda (f g t d) - (i386:value->base 0))) - ((base->ident-ref info) name))))) - - ;; *p++ = c; - ((expr-stmt (assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op _) (p-expr (ident ,value)))) - ;; (stderr "VALUE: ~a\n" value) - ;; (stderr "LOCALS: ~a\n" (.locals info)) - ;; (stderr " ==> ~a\n" (assoc-ref (.locals info) value)) - (clone info #:text - (append text - ;;((ident-ref->base info) value) - ((ident->base info) value) - ((base->ident-ref info) name) - (list (lambda (f g t d) - (i386:local-add (assoc-ref locals name) 1)))))) - - ((d-sel . ,d-sel) - (let ((expr ((expr->accu info) `(d-sel ,@d-sel)))) - expr)) - - ;; i = CAR (x) - ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (d-sel . ,d-sel))) - (let ((expr ((expr->accu info) `(d-sel ,@d-sel)))) - (clone info #:text (append (.text expr) - ((accu->ident info) name))))) - - - ;; TYPE (x) = PAIR; - ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op _) (p-expr (ident ,constant)))) - (let* ((expr ((expr->Xaccu info) `(d-sel (ident ,field) ,@d-sel))) - (b (assoc-ref (.constants info) constant)) - - (struct-type "scm") ;; FIXME - (struct (assoc-ref (.types info) struct-type)) - (size (length struct)) - (field-size 4) ;; FIXME:4, not fixed - (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))) - (clone info #:text (append (.text expr) - (list (lambda (f g t d) - (i386:value->accu-ref+n offset b))))))) + (.text base) + ((base->ident-address info) name) + ((ident-add info) name 1))))) ;; CAR (x) = 0 - ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op _) (p-expr (fixed ,value)))) - (let* ((expr ((expr->Xaccu info) `(d-sel (ident ,field) ,@d-sel))) - (b (cstring->number value)) - - (struct-type "scm") ;; FIXME - (struct (assoc-ref (.types info) struct-type)) - (size (length struct)) + ;; TYPE (x) = PAIR; + ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op ,op) ,b)) + (when (not (equal? op "=")) + (stderr "OOOPS0: op=~s\n" op) + barf) + (let* ((empty (clone info #:text '())) + (expr ((expr->Xaccu empty) `(d-sel (ident ,field) ,@d-sel))) ;; <-OFFSET + (base ((expr->base empty) b)) + (type (list "struct" "scm")) ;; FIXME + (fields (type->description info type)) + (size (type->size info type)) (field-size 4) ;; FIXME:4, not fixed - (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b)))))))) ) - (clone info #:text (append (.text expr) - (list (lambda (f g t d) - (i386:value->accu-ref+n offset b))))))) + (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) ) + (clone info #:text (append text + (.text expr) + (list (lambda (f g ta t d) + '(#x90))) + (.text base) + (list (lambda (f g ta t d) + '(#x90))) + (list (lambda (f g ta t d) + ;;(i386:byte-base->accu-ref) ;; FIXME: size + (i386:base->accu-address) + )))))) + + + ;; i = 0; + ;; c = f (); + ;; i = i + 48; + ;; p = g_cell; + ((expr-stmt (assn-expr (p-expr (ident ,name)) (op ,op) ,b)) + (when (and (not (equal? op "=")) + (not (equal? op "+=")) + (not (equal? op "-="))) + (stderr "OOOPS1: op=~s\n" op) + barf) + (let* ((empty (clone info #:text '())) + (base ((expr->base empty) b))) + (clone info #:text (append text + (.text base) + (if (equal? op "=") '() + (append ((ident->accu info) name) + (list (lambda (f g ta t d) + (append + (if (equal? op "+=") + (i386:accu+base) + (i386:accu-base)) + (i386:accu->base)))))) + ;;assign: + ((base->ident info) name))))) + + ;; *p = 0; + ((expr-stmt (assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b)) + (when (not (equal? op "=")) + (stderr "OOOPS2: op=~s\n" op) + barf) + (let* ((empty (clone info #:text '())) + (base ((expr->base empty) b))) + (clone info #:text (append text + (.text base) + ;;assign: + ((base->ident-address info) name))))) ;; g_cells[0] = 65; - ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,name))) (op _) (p-expr (fixed ,value)))) - (let ((index (cstring->number index)) - (value (cstring->number value))) + ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,name))) (op ,op) ,b)) + (when (not (equal? op "=")) + (stderr "OOOPS3: op=~s\n" op) + barf) + (let* ((index (cstring->number index)) + (empty (clone info #:text '())) + (base ((expr->base empty) b))) (clone info #:text (append text - ((ident->base info) name) - ((ident->accu info) index) - (list (lambda (f g t d) - (i386:accu+base) - (i386:value->accu-ref value))))))) + (.text base) - ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,name))) (op _) (p-expr (char ,value)))) - (let ((index (cstring->number index)) - (value (char->integer (car (string->list value))))) - (clone info #:text - (append text + (list (lambda (f g ta t d) + (i386:push-base))) ((ident->base info) name) - ((ident->accu info) index) - (list (lambda (f g t d) - (i386:accu+base) - (i386:value->accu-ref value))))))) + (list (lambda (f g ta t d) + (append + (i386:value->accu index) + (i386:accu+base)))) + (list (lambda (f g ta t d) + (i386:pop-base))) + + (list (lambda (f g ta t d) + (i386:base->accu-address))))))) + + ;; g_cells[i] = c; + ((expr-stmt (assn-expr (array-ref (p-expr (ident ,index)) (p-expr (ident ,name))) (op ,op) ,b)) + (when (not (equal? op "=")) + (stderr "OOOPS4: op=~s\n" op) + barf) + (let* ((empty (clone info #:text '())) + (base ((expr->base empty) b))) + (clone info #:text + (append text + (.text base) + + (list (lambda (f g ta t d) + (i386:push-base))) + ((ident->base info) name) + ((ident->accu info) index) ;; FIXME: chars! index*size + (list (lambda (f g ta t d) + (i386:accu+base))) ; FIXME: type: char + (list (lambda (f g ta t d) + (i386:pop-base))) + + (list (lambda (f g ta t d) + ;;(i386:byte-base->accu-address) + (i386:base->accu-address) + )))))) + + ;; g_functions[g_function++] = g_foo; + ((expr-stmt (assn-expr (array-ref (post-inc (p-expr (ident ,index))) (p-expr (ident ,name))) (op ,op) ,b)) + (when (not (equal? op "=")) + (stderr "OOOPS5: op=~s\n" op) + barf) + (let* ((empty (clone info #:text '())) + (base ((expr->base empty) b))) + (clone info #:text + (append text + (.text base) + + (list (lambda (f g ta t d) + (i386:push-base))) + ((ident->base info) name) + ((ident->accu info) index) ;; FIXME: chars! index*size + (list (lambda (f g ta t d) + (i386:accu+base))) ; FIXME: type: char + (list (lambda (f g ta t d) + (i386:pop-base))) + + (list (lambda (f g ta t d) + (append + (i386:base->accu-address)))) + + ((ident-add info) index 1) + )))) + + ;; DECL + ;; + ;; struct f = {...}; + ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers))))) + (let* ((type (decl->type type)) + ;;(foo (stderr "1DECL: ~s\n" type)) + (fields (type->description info type)) + (size (type->size info type)) + (field-size 4)) ;; FIXME:4, not fixed + ;;(stderr "7TYPE: ~s\n" type) + (if (.function info) + (let* ((locals (let loop ((fields (cdr fields)) (locals locals)) + (if (null? fields) locals + (loop (cdr fields) (add-local locals "foobar" "int" 0))))) + (locals (add-local locals name type -1)) + (info (clone info #:locals locals)) + (empty (clone info #:text '()))) + (let loop ((fields (iota (length fields))) (initzers initzers) (info info)) + ;; (stderr "LOEP local initzers=~s\n" initzers) + (if (null? fields) info + (let ((offset (* field-size (car fields))) + (initzer (car initzers))) + (loop (cdr fields) (cdr initzers) + (clone info #:text + (append + (.text info) + ((ident->accu info) name) + (list (lambda (f g ta t d) + (append + (i386:accu->base)))) + (.text ((expr->accu empty) initzer)) + (list (lambda (f g ta t d) + (i386:accu->base-address+n offset)))))))))) + (let* ((global (make-global name type -1 (string->list (make-string size #\nul)))) + (globals (append globals (list global))) + (here (data-offset name globals)) + (info (clone info #:globals globals)) + (field-size 4)) + (let loop ((fields (iota (length fields))) (initzers initzers) (info info)) + ;; (stderr "LOEP local initzers=~s\n" initzers) + (if (null? fields) info + (let ((offset (* field-size (car fields))) + (initzer (car initzers))) + (loop (cdr fields) (cdr initzers) + (clone info #:init + (append + (.init info) + (list (lambda (functions globals ta t d data) + (append + (list-head data (+ here offset)) + (initzer->data info functions globals ta t d (car initzers)) + (list-tail data (+ here offset field-size))))))))))))))) + + ((decl . _) + (format (current-error-port) "SKIP: decl statement=~s\n" o) + info) (_ - (format (current-error-port) "SKIP statement=~s\n" o) + (format (current-error-port) "SKIP: statement=~s\n" o) + barf info))))) +(define (initzer->data info functions globals ta t d o) + (pmatch o + ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value))) + ((initzer (ref-to (p-expr (ident ,name)))) + ;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions)))) + (int->bv32 (+ ta (function-offset name functions)))) + ((initzer (p-expr (ident ,name))) + (let ((value (assoc-ref (.constants info) name))) + (int->bv32 value))) + (_ (stderr "initzer->data:SKIP: ~s\n" o) + barf + (int->bv32 0)))) + (define (info->exe info) (display "dumping elf\n" (current-error-port)) - (map write-any (make-elf (.functions info) (.globals info)))) + (map write-any (make-elf (.functions info) (.globals info) (.init info)))) (define (.formals o) (pmatch o @@ -1447,7 +1924,7 @@ (pmatch o ((param-list . ,formals) (let ((n (length formals))) - (list (lambda (f g t d) + (list (lambda (f g ta t d) (append (i386:function-preamble) (append-map (formal->text n) formals (iota n)) @@ -1459,8 +1936,7 @@ (pmatch o ((param-list . ,formals) (let ((n (length formals))) - ;;(stderr "FORMALS: ~a ==> ~a\n" formals n) - (map cons (map .name formals) (iota n -2 -1)))) + (map make-local (map .name formals) (map .type formals) (make-list n 0) (iota n -2 -1)))) (_ (format (current-error-port) "formals->info: no match: ~a\n" o) barf))) @@ -1638,7 +2114,9 @@ strcmp (char const* a, char const* b) (define (compile) (let* ((ast (mescc)) - (info (make #:functions i386:libc)) + (info (make + #:functions i386:libc + #:types i386:type-alist)) (ast (append libc ast)) (info ((ast->info info) ast)) (info ((ast->info info) _start))) diff --git a/module/mes/elf-util.mes b/module/mes/elf-util.mes index 499d56ec..4676eaec 100644 --- a/module/mes/elf-util.mes +++ b/module/mes/elf-util.mes @@ -31,21 +31,47 @@ (mes (mes-use-module (srfi srfi-1)))) +(define (make-global name type pointer value) + (cons name (list type pointer value))) + +(define global:type car) +(define global:pointer cadr) +(define global:value caddr) + +(define (dec->hex o) + (cond ((number? o) (number->string o 16)) + ((char? o) (number->string (char->integer o) 16)))) + (define (functions->lambdas functions) (append-map cdr functions)) -(define (lambda/label->list f g t d) +(define (lambda/label->list f g ta t d) (lambda (l/l) - (if (not (procedure? l/l)) '() (l/l f g t d)))) + (if (not (procedure? l/l)) '() (l/l f g ta t d)))) (define (text->list o) - (append-map (lambda/label->list '() '() 0 0) o)) + (append-map (lambda/label->list '() '() 0 0 0) o)) -(define (functions->text functions globals t d) +(define (functions->text functions globals ta t d) (let loop ((lambdas/labels (functions->lambdas functions)) (text '())) (if (null? lambdas/labels) text (loop (cdr lambdas/labels) - (append text ((lambda/label->list functions globals (- (length text)) d) (car lambdas/labels))))))) + (append text ((lambda/label->list functions globals ta (- (length text)) d) (car lambdas/labels))))))) + +;; (define (functions->text functions globals ta t d) +;; (let loop ((functions functions) (text '())) +;; (if (null? functions) text +;; (loop (cdr functions) +;; (append '() ;;text +;; (function->text functions globals ta t d text (car functions))))))) + +;; (define (function->text functions globals ta t d text function) +;; (format (current-error-port) "elf func=~a\n" (car function)) +;; (let loop ((lambdas/labels (cdr function)) (text text)) +;; (if (null? lambdas/labels) text +;; (loop (cdr lambdas/labels) +;; (append '() ;;text +;; ((lambda/label->list functions globals ta (- (length text)) d) (car lambdas/labels))))))) (define (function-prefix name functions) (member name (reverse functions) (lambda (a b) (equal? (car b) name)))) @@ -55,7 +81,7 @@ (lambda (name functions) (or (assoc-ref cache name) (let* ((prefix (function-prefix name functions)) - (offset (if prefix (length (functions->text (cdr prefix) '() 0 0)) + (offset (if prefix (length (functions->text (cdr prefix) '() 0 0 0)) 0))) (if (or (equal? name "exit") (> offset 0)) (set! cache (assoc-set! cache name offset))) offset))))) @@ -67,12 +93,12 @@ (let loop ((text (cdr function-entry))) (if (or (equal? (car text) label) (null? text)) 0 (let* ((l/l (car text)) - (t ((lambda/label->list '() '() 0 0) l/l)) + (t ((lambda/label->list '() '() 0 0 0) l/l)) (n (length t))) (+ (loop (cdr text)) n)))))))) (define (globals->data globals) - (append-map cdr globals)) + (append-map (compose global:value cdr) globals)) (define (data-offset name globals) (let* ((prefix (member name (reverse globals) diff --git a/module/mes/elf-util.scm b/module/mes/elf-util.scm index a4b0b869..15394e2a 100644 --- a/module/mes/elf-util.scm +++ b/module/mes/elf-util.scm @@ -25,13 +25,18 @@ (define-module (mes elf-util) #:use-module (srfi srfi-1) #:export (data-offset + dec->hex function-offset label-offset functions->lambdas functions->text lambda/label->list text->list - globals->data)) + globals->data + make-global + global:type + global:pointer + global:value)) (cond-expand (guile-2) diff --git a/module/mes/elf.mes b/module/mes/elf.mes index 5e6f0bf2..9d748e16 100644 --- a/module/mes/elf.mes +++ b/module/mes/elf.mes @@ -46,7 +46,7 @@ (define elf32-off int->bv32) (define elf32-word int->bv32) -(define (make-elf functions globals) +(define (make-elf functions globals init) (define vaddress #x08048000) (define ei-magic `(#x7f ,@(string->list "ELF"))) @@ -181,7 +181,7 @@ (map car functions)))) (define text-length - (length (functions->text functions globals 0 0))) + (length (functions->text functions globals 0 0 0))) (define data-offset (+ text-offset text-length)) @@ -240,8 +240,11 @@ (define SHF-EXEC 4) (define SHF-STRINGS #x20) - (let* ((text (functions->text functions globals 0 data-address)) - (data (globals->data globals)) + (let* ((text (functions->text functions globals text-address 0 data-address)) + (raw-data (globals->data globals)) + (data (let loop ((data raw-data) (init init)) + (if (null? init) data + (loop ((car init) functions globals text-address 0 data-address data) (cdr init))))) (entry (+ text-offset (function-offset "_start" functions))) (sym (sym functions globals)) (str (str functions))) @@ -269,8 +272,9 @@ (define section-headers-offset (+ str-offset str-length)) - (format (current-error-port) "ELF text=~a\n" text) - ;;(format (current-error-port) "ELF data=~a\n" data) + (format (current-error-port) "ELF text=~a\n" (map dec->hex text)) + (format (current-error-port) "ELF raw-data=~a\n" (map dec->hex raw-data)) + (format (current-error-port) "ELF data=~a\n" (map dec->hex data)) (format (current-error-port) "text-offset=~a\n" text-offset) (format (current-error-port) "data-offset=~a\n" data-offset) (format (current-error-port) "_start=~a\n" (number->string entry 16)) diff --git a/module/mes/libc-i386.mes b/module/mes/libc-i386.mes index 1c6cab1a..75d1fca6 100644 --- a/module/mes/libc-i386.mes +++ b/module/mes/libc-i386.mes @@ -31,8 +31,8 @@ (define (i386:function-locals) '(#x83 #xec #x20)) ; sub $0x10,%esp -- 8 local vars -(define (i386:push-global-ref o) - (or o push-global-ref) +(define (i386:push-global-address o) + (or o push-global-address) `(#x68 ,@(int->bv32 o))) ; push $0x (define (i386:push-global o) @@ -44,8 +44,8 @@ (or n push-local) `(#xff #x75 ,(- 0 (* 4 n)))) ; pushl 0x(%ebp) -(define (i386:push-local-ref n) - (or n push-local-ref) +(define (i386:push-local-address n) + (or n push-local-address) `(#x8d #x45 ,(- 0 (* 4 n)) ; lea 0x(%ebp),%eax #x50)) ; push %eax @@ -56,30 +56,39 @@ ;;#x0f #xbe #xc0 ; movsbl %al,%eax ***FIXME BYTE**** #x50)) ; push %eax -(define (i386:push-accu) - `(#x50)) ; push %eax +(define (i386:pop-accu) + '(#x58)) ; pop %eax -(define (i386:push-arg f g t d) +(define (i386:push-accu) + '(#x50)) ; push %eax + +(define (i386:pop-base) + '(#x5a)) ; pop %eax + +(define (i386:push-base) + '(#x52)) ; push %eax + +(define (i386:push-arg f g ta t d) (lambda (o) (or o push-arg) (cond ((number? o) `(#x68 ,@(int->bv32 o))) ; push $ ((and (pair? o) (procedure? (car o))) - (append-map (lambda (p) (p f g t d)) o)) + (append-map (lambda (p) (p f g ta t d)) o)) ((pair? o) o) - ((procedure? o) (o f g t d)) + ((procedure? o) (o f g ta t d)) (_ barf)))) (define (i386:ret . rest) - (lambda (f g t d) + (lambda (f g ta t d) `( ,@(cond ((null? rest) '()) ((number? (car rest)) - `(#xb8 ; mov $<>,%eax + `(#xb8 ; mov $<>,%eaxx ,@(int->bv32 (car rest)))) ((pair? (car rest)) (car rest)) ((procedure? (car rest)) - ((car rest) f g t d))) + ((car rest) f g ta t d))) #xc9 ; leave #xc3 ; ret ))) @@ -87,14 +96,37 @@ (define (i386:accu->base) '(#x89 #xc2)) ; mov %eax,%edx +(define (i386:accu->base-address) + '(#x89 #x02)) ; mov %eax,%(edx) + +(define (i386:byte-accu->base-address) + '(#x88 #x02)) ; mov %al,%(edx) + +(define (i386:accu->base-address+n n) + (or n accu->base-address+n) + `(#x89 #x42 ,n)) ; mov %eax,$0x%(edx) + (define (i386:accu->local n) (or n accu->local) `(#x89 #x45 ,(- 0 (* 4 n)))) ; mov %eax,-<0xn>(%ebp) +(define (i386:base->local n) + (or n base->local) + `(#x89 #x55 ,(- 0 (* 4 n)))) ; mov %edx,-<0xn>(%ebp) + +(define (i386:base->global n) + (or n base->global) + `(#x89 #x15 ,@(int->bv32 n))) ; mov %edx,0x0 + (define (i386:accu->global n) (or n accu->global) `(#xa3 ,@(int->bv32 n))) ; mov %eax,0x0 +(define (i386:accu->global-address n) + (or n accu->global-address) + `(#x8b #x15 ,@(int->bv32 n) ; mov 0x,%edx + #x89 #x02 )) ; mov %eax,(%edx) + (define (i386:accu-zero?) '(#x85 #xc0)) ; cmpl %eax,%eax @@ -103,6 +135,7 @@ (i386:xor-zf))) (define (i386:accu-shl n) + (or n accu:shl n) `(#xc1 #xe0 ,n)) ; shl $0x8,%eax (define (i386:accu+accu) @@ -111,6 +144,21 @@ (define (i386:accu+base) `(#x01 #xd0)) ; add %edx,%eax +(define (i386:accu+value v) + (or v accu+value) + `(#x05 ,@(int->bv32 v))) ; add %eax,%eax + +(define (i386:accu-base) + `(#x29 #xd0)) ; sub %edx,%eax + +;; (define (i386:accu/base) +;; '(#xf7 #xf2)) ; div %edx,%eax + +(define (i386:accu/base) + '(#x86 #xd3 ; mov %edx,%ebx + #x31 #xd2 ; xor %edx,%edx + #xf7 #xf3)) ; div %ebx + (define (i386:base->accu) '(#x89 #xd0)) ; mov %edx,%eax @@ -118,6 +166,15 @@ (or n local->accu) `(#x8b #x45 ,(- 0 (* 4 n)))) ; mov -<0xn>(%ebp),%eax +(define (i386:local-address->accu n) + (or n ladd) + `(#x8d #x45 ,(- 0 (* 4 n)))) ; lea 0x(%ebp),%eax + +(define (i386:local-ptr->accu n) + (or n local-ptr->accu) + `(#x89 #xe8 ; mov %ebp,%eax + #x83 #xc0 ,(- 0 (* 4 n)))) ; add $0x,%eax + (define (i386:byte-local->accu n) (or n byte-local->accu) `(#x0f #xb6 #x45 ,(- 0 (* 4 n)))) ; movzbl 0x(%ebp),%eax @@ -126,21 +183,26 @@ (or n local->base) `(#x8b #x55 ,(- 0 (* 4 n)))) ; mov -<0xn>(%ebp),%edx -;; (define (i386:local-ref->base n) -;; (or n local-ref->base) -;; `(#x8b #x15 ,@(int->bv32 (- 0 (* 4 n))))) ; mov 0x,%edx - -(define (i386:local-ref->base n) - (or n local-ref->base) +(define (i386:local-address->base n) ;; DE-REF + (or n local-address->base) `(#x8d #x55 ,(- 0 (* 4 n)))) ; lea 0x(%ebp),%edx -(define (i386:global-ref->base n) - (or n global->base) - `(#x8b #x15 ,@(int->bv32 n))) ; mov 0x,%edx +(define (i386:local-ptr->base n) + (or n local-ptr->base) + `(#x89 #xea ; mov %ebp,%edx + #x83 #xc2 ,(- 0 (* 4 n)))) ; add $0x,%edx (define (i386:global->base n) (or n global->base) - `(#xba ,@(int->bv32 n))) ; mov $,%edx + `(#xba ,@(int->bv32 n))) ; mov $,%edx + +(define (i386:global-address->accu n) + (or n global-address->accu) + `(#xa1 ,@(int->bv32 n))) ; mov 0x,%eax + +(define (i386:global-address->base n) + (or n global-address->base) + `(#x8b #x15 ,@(int->bv32 n))) ; mov 0x,%edx (define (i386:byte-base-mem->accu) '(#x01 #xd0 ; add %edx,%eax @@ -163,44 +225,46 @@ `(#x8b #x40 ,n)) ; mov 0x(%eax),%eax (define (i386:base-mem+n->accu n) + (or n base-mem+n->accu) `(#x01 #xd0 ; add %edx,%eax #x8b #x40 ,n)) ; mov (%eax),%eax -(define (i386:global->accu o) - (or o global->accu) - `(#xb8 ,@(int->bv32 o))) ; mov $<>,%eax - (define (i386:value->accu v) - (or v value->accu) + (or v urg:value->accu) `(#xb8 ,@(int->bv32 v))) ; mov $,%eax -(define (i386:value->accu-ref v) - (or v value->accu-ref) +(define (i386:value->accu-address v) `(#xc7 #x00 ,@(int->bv32 v))) ; movl $0x,(%eax) -(define (i386:value->accu-ref+n n v) +(define (i386:value->accu-address+n n v) + (or v urg:value->accu-address+n) `(#xc7 #x40 ,n ,@(int->bv32 v))) ; movl $,0x(%eax) -(define (i386:base->accu-ref) +(define (i386:base->accu-address) '(#x89 #x10)) ; mov %edx,(%eax) -(define (i386:byte-base->accu-ref) +(define (i386:byte-base->accu-address) '(#x88 #x10)) ; mov %dl,(%eax) +(define (i386:byte-base->accu-address+n n) + (or n byte-base->accu-address+n) + `(#x88 #x50 ,n)) ; mov %dl,0x(%eax) + (define (i386:value->base v) + (or v urg:value->base) `(#xba ,@(int->bv32 v))) ; mov $,%edx (define (i386:local-add n v) - (or n ladd) + (or n urg:local-add) `(#x83 #x45 ,(- 0 (* 4 n)) ,v)) ; addl $,0x(%ebp) -(define (i386:local-address->accu n) - (or n ladd) - `(#x8d #x45 ,(- 0 (* 4 n)))) ; lea 0x(%ebp),%eax +(define (i386:global-add n v) + (or n urg:global-add) + `(#x83 #x05 ,@(int->bv32 n) ,v)) ; addl $,0x -(define (i386:local-address->accu n) - (or n ladd) - `(#x8d #x45 ,(- 0 (* 4 n)))) ; lea 0x(%ebp),%eax +(define (i386:global->accu o) + (or o urg:global->accu) + `(#xb8 ,@(int->bv32 o))) ; mov $<>,%eax (define (i386:value->global n v) (or n value->global) @@ -213,11 +277,12 @@ ,@(int->bv32 v))) (define (i386:local-test n v) - (or n lt) + (or n local-test) `(#x83 #x7d ,(- 0 (* 4 n)) ,v)) ; cmpl $,0x(%ebp) -(define (i386:call f g t d address . arguments) - (let* ((pushes (append-map (i386:push-arg f g t d) (reverse arguments))) +(define (i386:call f g ta t d address . arguments) + (or address urg:call) + (let* ((pushes (append-map (i386:push-arg f g ta t d) (reverse arguments))) (s (length pushes)) (n (length arguments))) `( @@ -225,12 +290,32 @@ #xe8 ,@(int->bv32 (- address 5 s)) ; call relative #x83 #xc4 ,(* n 4) ; add $00,%esp ))) + +(define (i386:call-accu f g ta t d . arguments) + ;;(or address urg:call) + (let* ((pushes (append-map (i386:push-arg f g ta t d) (reverse arguments))) + (s (length pushes)) + (n (length arguments))) + `( + ,@(i386:push-accu) + ,@pushes ; push args + ;;#xe8 ,@(int->bv32 (- address 5 s)) ; call relative + ;; FIXME: add t?/address + ;; #x50 ; push %eax + ;; #xc3 ; ret + ,@(i386:pop-accu) + ;; #x05 ,@(int->bv32 t) ; add ,%eax + ;; #x05 ,@(int->bv32 ta) ; add ,%eax + #xff #xd0 ; call *%eax + #x83 #xc4 ,(* n 4) ; add $00,%esp + ))) (define (i386:accu-not) `(#x0f #x94 #xc0 ; sete %al #x0f #xb6 #xc0)) ; movzbl %al,%eax (define (i386:xor-accu v) + (or n urg:xor-accu) `(#x35 ,@(int->bv32 v))) ;xor $0xff,%eax (define (i386:xor-zf) @@ -245,44 +330,55 @@ '(#x85 #xc0)) ; test %eax,%eax (define (i386:Xjump n) - `(#xe9 ,@(int->bv32 n))) ; jmp . + + (or n urg:Xjump) + `(#xe9 ,@(int->bv32 (if (>= n 0) n (- n 5))))) ; jmp . + (define (i386:Xjump-nz n) + (or n urg:Xjump-nz) `(#x0f #x85 ,@(int->bv32 n))) ; jnz . + -(define (i386:jump n) ;;FIXME: NEED THIS WEIRDNESS for t.c - `(#xeb ,(if (>= n 0) (- n 2) (- n 2)))) ; jmp - -;; (define (i386:jump n) -;; `(#xeb ,(if (>= n 0) n (- n 2)))) ; jmp +(define (i386:jump n) ;;FIXME: NEED THIS WEIRDNESS for t.c + (when (or (> n #x80) (< n #x-80)) + (format (current-error-port) "JUMP n=~a\n" n) + barf) + `(#xeb ,(if (>= n 0) (- n 2) (- n 2)))) ; jmp (define (i386:jump-c n) + (or n jump-c) `(#x72 ,(if (>= n 0) n (- n 2)))) ; jc (define (i386:jump-cz n) + (or n jump-cz) `(#x76 ,(if (>= n 0) n (- n 2)))) ; jna (define (i386:jump-ncz n) + (or n jump-ncz) `(#x77 ,(if (>= n 0) n (- n 2)))) ; ja (define (i386:jump-nc n) + (or n jump-nc) `(#x73 ,(if (>= n 0) n (- n 2)))) ; jnc (define (i386:jump-z n) + (or n jump-z) `(#x74 ,(if (>= n 0) n (- n 2)))) ; jz (define (i386:jump-nz n) + (or n jump-nz) `(#x75 ,(if (>= n 0) n (- n 2)))) ; jnz (define (i386:test-jump-z n) + (or n jump-z) `(#x85 #xc0 ; test %eax,%eax #x74 ,(if (>= n 0) n (- n 4)))) ; jz (define (i386:jump-byte-nz n) + (or n jump-byte-nz) `(#x84 #xc0 ; test %al,%al #x75 ,(if (>= n 0) n (- n 4)))) ; jne (define (i386:jump-byte-z n) + (or n jump-byte-z) `(#x84 #xc0 ; test %al,%al #x74 ,(if (>= n 0) n (- n 4)))) ; jne @@ -305,7 +401,7 @@ `(#x29 #xc2)) ; sub %eax,%edx ;;; libc bits -(define (i386:exit f g t d) +(define (i386:exit f g ta t d) `( #x5b ; pop %ebx #x5b ; pop %ebx @@ -313,7 +409,7 @@ #xcd #x80 ; int $0x80 )) -(define (i386:open f g t d) +(define (i386:open f g ta t d) `( #x55 ; push %ebp #x89 #xe5 ; mov %esp,%ebp @@ -328,7 +424,7 @@ #xc3 ; ret )) -(define (i386:read f g t d) +(define (i386:read f g ta t d) `( #x55 ; push %ebp #x89 #xe5 ; mov %esp,%ebp @@ -344,7 +440,7 @@ #xc3 ; ret )) -(define (i386:write f g t d) +(define (i386:write f g ta t d) `( #x55 ; push %ebp #x89 #xe5 ; mov %esp,%ebp diff --git a/module/mes/libc-i386.scm b/module/mes/libc-i386.scm index 1ecb6180..a7036d9b 100644 --- a/module/mes/libc-i386.scm +++ b/module/mes/libc-i386.scm @@ -31,21 +31,32 @@ i386:accu-not i386:accu-cmp-value i386:accu->base + i386:accu->base-address + i386:accu->base-address+n i386:accu->global + i386:accu->global-address i386:accu->local i386:accu-non-zero? i386:accu-test i386:accu-zero? i386:accu+accu i386:accu+base + i386:accu+value + i386:accu/base + i386:accu-base i386:accu-shl i386:base-sub i386:base->accu - i386:base->accu-ref + i386:base->accu-address + i386:byte-accu->base-address + i386:base->global + i386:base->local i386:base-mem->accu i386:byte-base-sub - i386:byte-base->accu-ref + i386:byte-base->accu-address + i386:byte-base->accu-address+n i386:byte-base-mem->accu + i386:local-address->accu i386:byte-local->accu i386:byte-mem->accu i386:base-mem+n->accu @@ -53,11 +64,15 @@ i386:byte-test-base i386:byte-sub-base i386:call + i386:call-accu i386:formal i386:function-locals i386:function-preamble + i386:global-add i386:global->accu i386:global->base + i386:global-address->accu + i386:global-address->base i386:jump i386:jump i386:jump-byte-nz @@ -73,24 +88,29 @@ i386:local->base i386:local-add i386:local-address->accu - i386:local-ref->base + i386:local-ptr->accu + i386:local-ptr->base + i386:local-address->base i386:local-test i386:mem->accu i386:mem+n->accu + i386:pop-accu i386:push-accu + i386:pop-base + i386:push-base i386:push-global - i386:push-global-ref + i386:push-global-address i386:push-local i386:push-local-de-ref - i386:push-local-ref + i386:push-local-address i386:ret i386:ret-local i386:sub-base i386:test-base i386:test-jump-z i386:value->accu - i386:value->accu-ref - i386:value->accu-ref+n + i386:value->accu-address + i386:value->accu-address+n i386:value->global i386:value->local i386:value->base diff --git a/scaffold/mini-mes.c b/scaffold/mini-mes.c index 88e1c37b..14dab35d 100644 --- a/scaffold/mini-mes.c +++ b/scaffold/mini-mes.c @@ -32,6 +32,9 @@ #define NYACC_CDR nyacc_cdr #endif +char arena[2000]; +//char buf0[400]; + int g_stdin = 0; #if __GNUC__ @@ -219,112 +222,92 @@ void assert_fail (char* s) { eputs ("assert fail:"); +#if __GNUC__ eputs (s); +#endif eputs ("\n"); +#if __GNUC__ *((int*)0) = 0; +#endif } -#if __NYACC__ || FIXME_NYACC -#define assert(x) ((x) ? (void)0 : assert_fail(0)) -// #else -// NYACC -// #define assert(x) ((x) ? (void)0 : assert_fail(#x)) +#if __GNUC__ +#define assert(x) ((x) ? (void)0 : assert_fail ("boo:" #x)) +#else +//#define assert(x) ((x) ? (void)0 : assert_fail ("boo:" #x)) +#define assert(x) ((x) ? (void)0 : assert_fail (0)) #endif -#define false 0 -#define true 1 -typedef int bool; - -int ARENA_SIZE = 100000; typedef int SCM; #if __GNUC__ -bool g_debug = false; +int g_debug = 0; #endif int g_free = 0; SCM g_symbols = 0; SCM g_stack = 0; -SCM r0 = 0; // a/env -SCM r1 = 0; // param 1 -SCM r2 = 0; // save 2+load/dump -SCM r3 = 0; // continuation +// a/env +SCM r0 = 0; +// param 1 +SCM r1 = 0; +// save 2+load/dump +SCM r2 = 0; +// continuation +SCM r3 = 0; #if __NYACC__ || FIXME_NYACC -enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, TSTRING, SYMBOL, VALUES, TVECTOR, BROKEN_HEART}; +enum type_t {CHAR, CLOSURE, CONTINUATION, TFUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, TSTRING, SYMBOL, VALUES, TVECTOR, BROKEN_HEART}; #else enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART}; #endif -typedef int (*f_t) (void); -typedef SCM (*function0_t) (void); -typedef SCM (*function1_t) (SCM); -typedef SCM (*function2_t) (SCM, SCM); -typedef SCM (*function3_t) (SCM, SCM, SCM); -typedef SCM (*functionn_t) (SCM); -typedef struct function_struct { - // union { - // f_t function; - // function0_t function0; - // function1_t function1; - // function2_t function2; - // function3_t function3; - // functionn_t functionn; - // } data; - f_t function; - int arity; -} function_t; -struct scm; -typedef struct scm { +struct scm { enum type_t type; - union { - char const *name; - SCM string; - SCM car; - SCM ref; - int length; - } NYACC_CAR; - union { - int value; - int function; - SCM cdr; - SCM closure; - SCM continuation; - SCM macro; - SCM vector; - int hits; - } NYACC_CDR; -} scm; + SCM car; + SCM cdr; +}; -scm scm_nil = {SPECIAL, "()"}; -scm scm_f = {SPECIAL, "#f"}; -scm scm_t = {SPECIAL, "#t"}; -scm scm_dot = {SPECIAL, "."}; -scm scm_arrow = {SPECIAL, "=>"}; -scm scm_undefined = {SPECIAL, "*undefined*"}; -scm scm_unspecified = {SPECIAL, "*unspecified*"}; -scm scm_closure = {SPECIAL, "*closure*"}; -scm scm_circular = {SPECIAL, "*circular*"}; -scm scm_begin = {SPECIAL, "*begin*"}; +typedef int (*f_t) (void); +struct function { + int (*function) (void); + int arity; +}; -scm scm_vm_apply = {SPECIAL, "core:apply"}; -scm scm_vm_apply2 = {SPECIAL, "*vm-apply2*"}; +struct scm *g_cells = arena; -scm scm_vm_eval = {SPECIAL, "core:eval"}; +//scm *g_news = 0; -scm scm_vm_begin = {SPECIAL, "*vm-begin*"}; -//scm scm_vm_begin_read_input_file = {SPECIAL, "*vm-begin-read-input-file*"}; -scm scm_vm_begin2 = {SPECIAL, "*vm-begin2*"}; +// struct scm scm_nil = {SPECIAL, "()"}; +// struct scm scm_f = {SPECIAL, "#f"}; +// struct scm scm_t = {SPECIAL, "#t"}; +// struct scm_dot = {SPECIAL, "."}; +// struct scm_arrow = {SPECIAL, "=>"}; +// struct scm_undefined = {SPECIAL, "*undefined*"}; +// struct scm_unspecified = {SPECIAL, "*unspecified*"}; +// struct scm_closure = {SPECIAL, "*closure*"}; +// struct scm_circular = {SPECIAL, "*circular*"}; +// struct scm_begin = {SPECIAL, "*begin*"}; -scm scm_vm_return = {SPECIAL, "*vm-return*"}; +// struct scm_vm_apply = {SPECIAL, "core:apply"}; +// struct scm_vm_apply2 = {SPECIAL, "*vm-apply2*"}; + +// struct scm_vm_eval = {SPECIAL, "core:eval"}; + +// struct scm_vm_begin = {SPECIAL, "*vm-begin*"}; +// //scm scm_vm_begin_read_input_file = {SPECIAL, "*vm-begin-read-input-file*"}; +// struct scm_vm_begin2 = {SPECIAL, "*vm-begin2*"}; + +// struct scm_vm_return = {SPECIAL, "*vm-return*"}; + +// //#include "mes.symbols.h" -//#include "mes.symbols.h" #define cell_nil 1 #define cell_f 2 #define cell_t 3 #define cell_dot 4 -#define cell_arrow 5 +// #define cell_arrow 5 #define cell_undefined 6 #define cell_unspecified 7 #define cell_closure 8 @@ -348,61 +331,62 @@ scm scm_vm_return = {SPECIAL, "*vm-return*"}; #define cell_vm_return 63 -#if 0 -char arena[200]; -struct scm *g_cells = (struct scm*)arena; -#else -struct scm g_cells[200]; -#endif - -//scm *g_news = 0; - - SCM tmp; SCM tmp_num; SCM tmp_num2; -function_t functions[200]; +int ARENA_SIZE = 200; +struct function functions[2]; int g_function = 0; SCM make_cell (SCM type, SCM car, SCM cdr); -function_t fun_make_cell = {&make_cell, 3}; -scm scm_make_cell = {FUNCTION, "make-cell", 0}; +struct function fun_make_cell = {&make_cell, 3}; +struct scm scm_make_cell = {TFUNCTION,0,0}; + //, "make-cell", 0}; SCM cell_make_cell; SCM cons (SCM x, SCM y); -function_t fun_cons = {&cons, 2}; -scm scm_cons = {FUNCTION, "cons", 0}; +struct function fun_cons = {&cons, 2}; +struct scm scm_cons = {TFUNCTION,0,0}; + // "cons", 0}; SCM cell_cons; SCM car (SCM x); -function_t fun_car = {&car, 1}; -scm scm_car = {FUNCTION, "car", 0}; +struct function fun_car = {&car, 1}; +struct scm scm_car = {TFUNCTION,0,0}; + // "car", 0}; SCM cell_car; SCM cdr (SCM x); -function_t fun_cdr = {&cdr, 1}; -scm scm_cdr = {FUNCTION, "cdr", 0}; +struct function fun_cdr = {&cdr, 1}; +struct scm scm_cdr = {TFUNCTION,0,0}; +// "cdr", 0}; SCM cell_cdr; // SCM eq_p (SCM x, SCM y); -// function_t fun_eq_p = {&eq_p, 2}; -// scm scm_eq_p = {FUNCTION, "eq?", 0}; +// struct function fun_eq_p = {&eq_p, 2}; +// scm scm_eq_p = {TFUNCTION,0,0};// "eq?", 0}; // SCM cell_eq_p; #define TYPE(x) (g_cells[x].type) #define CAR(x) g_cells[x].car -#define LENGTH(x) g_cells[x].length -#define STRING(x) g_cells[x].string +#define LENGTH(x) g_cells[x].car +#define STRING(x) g_cells[x].car #define CDR(x) g_cells[x].cdr -#define CLOSURE(x) g_cells[x].closure +#if __GNUC__ +//#define CLOSURE(x) g_cells[x].closure +#endif #define CONTINUATION(x) g_cells[x].cdr -#define FUNCTION(x) functions[g_cells[x].function] -#define VALUE(x) g_cells[x].value -#define VECTOR(x) g_cells[x].vector +#if __GNUC__ +//#define FUNCTION(x) functions[g_cells[x].function] +#endif + +#define FUNCTION(x) functions[g_cells[x].cdr] +#define VALUE(x) g_cells[x].cdr +#define VECTOR(x) g_cells[x].cdr #define MAKE_CHAR(n) make_cell (tmp_num_ (CHAR), 0, tmp_num2_ (n)) //#define MAKE_CONTINUATION(n) make_cell (tmp_num_ (CONTINUATION), n, g_stack) @@ -443,7 +427,7 @@ make_cell (SCM type, SCM car, SCM cdr) if (VALUE (type) == CHAR || VALUE (type) == NUMBER) { if (car) CAR (x) = CAR (car); if (cdr) CDR(x) = CDR(cdr); - } else if (VALUE (type) == FUNCTION) { + } else if (VALUE (type) == TFUNCTION) { if (car) CAR (x) = car; if (cdr) CDR(x) = CDR(cdr); } else { @@ -470,8 +454,13 @@ tmp_num2_ (int x) SCM cons (SCM x, SCM y) { +#if __GNUC__ VALUE (tmp_num) = PAIR; return make_cell (tmp_num, x, y); +#else + //FIXME GNUC + return 0; +#endif } SCM @@ -498,24 +487,33 @@ cdr (SCM x) return CDR(x); } -SCM -eq_p (SCM x, SCM y) -{ - return (x == y - || ((TYPE (x) == KEYWORD && TYPE (y) == KEYWORD - && STRING (x) == STRING (y))) - || (TYPE (x) == CHAR && TYPE (y) == CHAR - && VALUE (x) == VALUE (y)) - || (TYPE (x) == NUMBER && TYPE (y) == NUMBER - && VALUE (x) == VALUE (y))) - ? cell_t : cell_f; -} +// SCM +// eq_p (SCM x, SCM y) +// { +// return (x == y +// || ((TYPE (x) == KEYWORD && TYPE (y) == KEYWORD +// && STRING (x) == STRING (y))) +// || (TYPE (x) == CHAR && TYPE (y) == CHAR +// && VALUE (x) == VALUE (y)) +// || (TYPE (x) == NUMBER && TYPE (y) == NUMBER +// && VALUE (x) == VALUE (y))) +// ? cell_t : cell_f; +// } SCM gc_push_frame () { SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil)))); - return g_stack = cons (frame, g_stack); + g_stack = cons (frame, g_stack); + return g_stack; +} + +SCM +xgc_push_frame () +{ + // SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil)))); + // g_stack = cons (frame, g_stack); + return g_stack; } SCM @@ -540,7 +538,8 @@ pairlis (SCM x, SCM y, SCM a) SCM assq (SCM x, SCM a) { - while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a); + //while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a); + while (a != cell_nil && x == CAAR (a)) a = CDR (a); return a != cell_nil ? car (a) : cell_f; } @@ -565,6 +564,7 @@ assert_defined (SCM x, SCM e) SCM push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal)) { + puts ("push_cc\n"); SCM x = r3; r3 = c; r2 = p2; @@ -575,6 +575,20 @@ push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal)) return cell_unspecified; } +SCM +xpush_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal)) +{ + puts ("push_cc\n"); + SCM x = r3; + r3 = c; + r2 = p2; + xgc_push_frame (); + r1 = p1; + r0 = a; + r3 = x; + return cell_unspecified; +} + SCM caar (SCM x) {return car (car (x));} SCM cadr (SCM x) {return car (cdr (x));} SCM cdar (SCM x) {return cdr (car (x));} @@ -597,9 +611,9 @@ eval_apply () case cell_vm_evlis2: goto evlis2; case cell_vm_evlis3: goto evlis3; #endif - case cell_vm_apply: goto apply; - case cell_vm_apply2: goto apply2; - case cell_vm_eval: goto eval; + case cell_vm_apply: {goto apply;} + case cell_vm_apply2: {goto apply2;} + case cell_vm_eval: {goto eval;} #if 0 #if FIXED_PRIMITIVES case cell_vm_eval_car: goto eval_car; @@ -612,9 +626,9 @@ eval_apply () case cell_vm_eval2: goto eval2; case cell_vm_macro_expand: goto macro_expand; #endif - case cell_vm_begin: goto begin; + case cell_vm_begin: {goto begin;} ///case cell_vm_begin_read_input_file: goto begin_read_input_file; - case cell_vm_begin2: goto begin2; + case cell_vm_begin2: {goto begin2;} #if 0 case cell_vm_if: goto vm_if; case cell_vm_if_expr: goto if_expr; @@ -622,9 +636,8 @@ eval_apply () case cell_vm_call_with_values2: goto call_with_values2; case cell_vm_return: goto vm_return; #endif - case cell_unspecified: return r1; - default: - assert (0); + case cell_unspecified: {return r1;} + default: {assert (0);} } SCM x = cell_nil; @@ -646,7 +659,7 @@ eval_apply () apply: switch (TYPE (car (r1))) { - case FUNCTION: { + case TFUNCTION: { //check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1)); r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply goto vm_return; @@ -823,7 +836,7 @@ eval_apply () r1 = assert_defined (r1, assq_ref_env (r1, r0)); goto vm_return; } - default: goto vm_return; + default: {goto vm_return;} } // SCM macro; @@ -937,7 +950,7 @@ call (SCM fn, SCM x) if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1) && x != cell_nil && TYPE (CDR (x)) == PAIR && TYPE (CADR (x)) == VALUES) x = cons (CAR (x), cons (CDADAR (x), CDR (x))); - function_t* f = &FUNCTION (fn); + struct function* f = &FUNCTION (fn); switch (FUNCTION (fn).arity) { // case 0: return FUNCTION (fn).function0 (); @@ -945,11 +958,12 @@ call (SCM fn, SCM x) // case 2: return FUNCTION (fn).function2 (car (x), cadr (x)); // case 3: return FUNCTION (fn).function3 (car (x), cadr (x), car (cddr (x))); // case -1: return FUNCTION (fn).functionn (x); - case 0: return (FUNCTION (fn).function) (); - case 1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x)); - case 2: return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x)); - case 3: return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x))); - case -1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x); + case 0: {return (FUNCTION (fn).function) ();} + case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x));} + case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x));} + case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x)));} + //case -1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);} + default: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);} } return cell_unspecified; @@ -987,7 +1001,7 @@ mes_g_stack (SCM a) ///((internal)) // Environment setup SCM -make_tmps (scm* cells) +make_tmps (struct scm* cells) { tmp = g_free++; cells[tmp].type = CHAR; @@ -995,6 +1009,7 @@ make_tmps (scm* cells) cells[tmp_num].type = NUMBER; tmp_num2 = g_free++; cells[tmp_num2].type = NUMBER; + return 0; } SCM @@ -1066,67 +1081,68 @@ mes_symbols () ///((internal)) //#include "mes.symbols.i" #else g_free++; -g_cells[cell_nil] = scm_nil; +// g_cells[cell_nil] = scm_nil; g_free++; -g_cells[cell_f] = scm_f; +// g_cells[cell_f] = scm_f; g_free++; -g_cells[cell_t] = scm_t; +// g_cells[cell_t] = scm_t; g_free++; -g_cells[cell_dot] = scm_dot; +// g_cells[cell_dot] = scm_dot; g_free++; -g_cells[cell_arrow] = scm_arrow; +// g_cells[cell_arrow] = scm_arrow; g_free++; -g_cells[cell_undefined] = scm_undefined; +// g_cells[cell_undefined] = scm_undefined; g_free++; -g_cells[cell_unspecified] = scm_unspecified; +// g_cells[cell_unspecified] = scm_unspecified; g_free++; -g_cells[cell_closure] = scm_closure; +// g_cells[cell_closure] = scm_closure; g_free++; -g_cells[cell_circular] = scm_circular; +// g_cells[cell_circular] = scm_circular; g_free++; -g_cells[cell_begin] = scm_begin; +// g_cells[cell_begin] = scm_begin; /// g_free = 44; g_free++; -g_cells[cell_vm_apply] = scm_vm_apply; +// g_cells[cell_vm_apply] = scm_vm_apply; g_free++; -g_cells[cell_vm_apply2] = scm_vm_apply2; +// g_cells[cell_vm_apply2] = scm_vm_apply2; g_free++; -g_cells[cell_vm_eval] = scm_vm_eval; +// g_cells[cell_vm_eval] = scm_vm_eval; /// g_free = 55; g_free++; -g_cells[cell_vm_begin] = scm_vm_begin; +// g_cells[cell_vm_begin] = scm_vm_begin; g_free++; // g_cells[cell_vm_begin_read_input_file] = scm_vm_begin_read_input_file; g_free++; -g_cells[cell_vm_begin2] = scm_vm_begin2; +// g_cells[cell_vm_begin2] = scm_vm_begin2; /// g_free = 62; g_free++; -g_cells[cell_vm_return] = scm_vm_return; +// g_cells[cell_vm_return] = scm_vm_return; #endif g_symbol_max = g_free; make_tmps (g_cells); + // FIXME GNUC g_symbols = 0; for (int i=1; i\n"); if (VALUE (x) == 0) @@ -1408,29 +1445,29 @@ display_ (SCM x) SCM simple_bload_env (SCM a) ///((internal)) { - //g_stdin = open ("module/mes/read-0-32.mo", 0); - g_stdin = open ("module/mes/hack-32.mo", 0); + puts ("reading: "); + char *mo = "module/mes/hack-32.mo"; + puts (mo); + puts ("\n"); + g_stdin = open (mo, 0); if (g_stdin < 0) {eputs ("no such file: module/mes/read-0-32.mo\n");return 1;} - int c; char *p = (char*)g_cells; - char *q = (char*)g_cells; + int c; - puts ("q: "); - puts (q); - puts ("\n"); - -#if __GNUC__ +#if 0 + //__GNUC__ puts ("fd: "); puts (itoa (g_stdin)); puts ("\n"); #endif -#if __GNUC__ +#if 0 + //__GNUC__ assert (getchar () == 'M'); assert (getchar () == 'E'); assert (getchar () == 'S'); - puts ("GOT MES!\n"); + puts (" *GOT MES*\n"); g_stack = getchar () << 8; g_stack += getchar (); puts ("stack: "); @@ -1446,8 +1483,9 @@ simple_bload_env (SCM a) ///((internal)) c = getchar (); putchar (c); if (c != 'S') exit (12); - puts ("\n"); - puts ("GOT MES!\n"); + puts (" *GOT MES*\n"); + + // skip stack getchar (); getchar (); #endif @@ -1457,20 +1495,19 @@ simple_bload_env (SCM a) ///((internal)) { *p++ = c; c = getchar (); + putchar (c); } - puts ("q: "); - puts (q); - puts ("\n"); -#if 1 - //__GNUC__ + puts ("read done\n"); + g_free = (p-(char*)g_cells) / sizeof (struct scm); // gc_peek_frame (); // g_symbols = r1; g_symbols = 1; g_stdin = STDIN; r0 = mes_builtins (r0); - + +#if __GNUC__ puts ("cells read: "); puts (itoa (g_free)); puts ("\n"); @@ -1478,33 +1515,31 @@ simple_bload_env (SCM a) ///((internal)) puts ("symbols: "); puts (itoa (g_symbols)); puts ("\n"); - display_ (g_symbols); - puts ("\n"); - - fill (); - - r2 = 10; - puts ("\n"); - puts ("program: "); - puts (itoa (r2)); - puts ("\n"); - display_ (r2); - puts ("\n"); -#else - display_ (10); - puts ("\n"); - puts ("\n"); - fill (); - display_ (10); + // display_ (g_symbols); + // puts ("\n"); #endif + + display_ (10); + puts ("\n"); + + fill (); + r2 = 10; + + if (TYPE (12) != PAIR) + exit (33); + + puts ("program["); +#if __GNUC__ + puts (itoa (r2)); +#endif + puts ("]: "); + + display_ (r2); + //display_ (14); puts ("\n"); - g_stack = 20; - TYPE (20) = SYMBOL; - CAR (20) = 1; r0 = 1; - //g_free = 21; - r2 = 10; + //r2 = 10; return r2; } @@ -1551,16 +1586,25 @@ stderr_ (SCM x) int main (int argc, char *argv[]) { - puts ("mini-mes!\n"); + puts ("Hello mini-mes!\n"); #if __GNUC__ //g_debug = getenv ("MES_DEBUG"); #endif //if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA")); if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE"); +#if __GNUC__ if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs (VERSION);}; +#else + if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs ("0.4");}; +#endif g_stdin = STDIN; - r0 = mes_environment (); +#if 1 + r0 = mes_environment (); +#else + puts ("FIXME: mes_environment ()\n"); +#endif + #if MES_MINI SCM program = simple_bload_env (r0); #else @@ -1588,7 +1632,6 @@ main (int argc, char *argv[]) eputs ("]\n"); } #endif - puts ("Hello mini-mes!\n"); return 0; } diff --git a/scaffold/t.c b/scaffold/t.c index 39884362..411b9185 100644 --- a/scaffold/t.c +++ b/scaffold/t.c @@ -87,34 +87,42 @@ strcmp (char const* a, char const* b) while (*a && *b && *a == *b) {a++;b++;} return *a - *b; } -int test (char *p); #endif -// struct scm { -// int type; -// int car; -// int cdr; -// }; +struct scm { + int type; + int car; + int cdr; +}; -char arena[20]; -char *g_cells = arena; +char arena[200]; +struct scm *g_cells = arena; +char *g_chars = arena; +char buf[200]; -int -main (int argc, char *argv[]) -{ - char *p = "t.c\n"; - puts ("t.c\n"); +int foo () {puts ("t: foo\n"); return 0;}; +int bar () {puts ("t: bar\n"); return 0;}; +struct function { + int (*function) (void); + int arity; +}; +struct function g_fun = {&exit, 1}; +struct function g_foo = {&foo, 1}; +struct function g_bar = {&bar, 1}; - if (argc > 1 && !strcmp (argv[1], "--help")) return 1; - puts ("t: if (argc > 1 && !strcmp (argv[1], \"--help\")\n"); +//void *functions[2]; +int functions[2]; - // FIXME mescc?! - if (argc > 1) if (!strcmp (argv[1], "--help")) return 1; +struct function g_functions[2]; +int g_function = 0; - return test (p); - return 22; -} +enum type_t {CHAR, CLOSURE, CONTINUATION, TFUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, TSTRING, SYMBOL, VALUES, TVECTOR, BROKEN_HEART}; +typedef int SCM; +int g_free = 3; +SCM tmp; + +#if 1 int swits (int c) { @@ -141,6 +149,128 @@ swits (int c) return x; } +int g = 48; +int +get () +{ + int i = g; + g++; + return i; +} + +int +read_test () +{ + puts ("read test\n"); + char *p = (char*)g_chars; + int i = 0; + puts ("t: read 0123456789\n"); + int c = get (); + while (i < 10) { + *p++ = c; + putchar (c); + c = get (); + i++; + } + puts ("\n"); + if (strcmp (g_chars, "0123456789")) return 1; + return 0; +} + +int +math_test () +{ + int i; + puts ("t: 4/2="); + i = 4 / 2; + if (i!=2) return 1; + i += 48; + putchar (i); + puts ("\n"); + return read_test (); +} + +SCM +make_tmps_test (struct scm* cells) +{ + puts ("t: tmp = g_free++\n"); + tmp = g_free++; + puts ("t: cells[tmp].type = CHAR\n"); + cells[tmp].type = CHAR; + return math_test(); +} + +#define TYPE(x) (g_cells[x].type) +#define CAR(x) g_cells[x].car +#define CDR(x) g_cells[x].cdr + +struct scm scm_fun = {TFUNCTION,0,0}; +SCM cell_fun; + +int +struct_test () +{ + 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; + + CDR (3) = 0x22; + CDR (4) = 0x23; + if (CDR (3) != 0x22) + return CDR (3); + + puts ("t: struct fun = {&exit, 1};\n"); + struct function fun = {&exit, 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: fun.arity != 1;\n"); + if (fun.arity != 1) return 1; + + puts ("t: fun.function != exit;\n"); + if (fun.function != &exit) return 1; + + puts ("t: g_functions[g_function++] = g_foo;\n"); + g_functions[g_function++] = g_foo; + + int fn = 0; + puts ("t: g_functions[g_cells[fn].cdr].arity\n"); + if (!g_functions[g_cells[fn].cdr].arity) return 1; + + int (*functionx) (void) = 0; + functionx = g_functions[0].function; + puts ("t: *functionx == foo\n"); + if (*functionx != foo) return 11; + + puts ("t: (*functionx) () == foo\n"); + if ((*functionx) () != 0) return 12; + + fn++; + g_functions[0] = g_bar; + if (g_cells[fn].cdr != 0) return 13; + puts ("t: g_functions[g_cells[fn].cdr].function\n"); + functionx = g_functions[g_cells[fn].cdr].function; + puts ("t: *functionx == bar\n"); + if (*functionx != bar) return 15; + puts ("t: (*functionx) () == bar\n"); + if ((*functionx) () != 0) return 16; + + scm_fun.cdr = g_function; + g_functions[g_function++] = g_fun; + cell_fun = g_free++; + g_cells[cell_fun] = scm_fun; + + return make_tmps_test (g_cells); +} + int test (char *p) { @@ -148,6 +278,10 @@ test (char *p) int t = 1; int one = 1; char c = 'C'; + int i=0; + + char *x = arena; + char *y = g_chars; puts ("t: if (0)\n"); if (0) return 1; @@ -194,34 +328,46 @@ test (char *p) puts ("t: if (t && !one)\n"); if (t && !one) return 1; - int i=0; + puts ("t: if (f || !t)\n"); + if (f || !t) return 1; + puts ("t: if (i++)\n"); if (i++) return 1; puts ("t: if (--i)\n"); if (--i) return 1; + puts ("t: i += 2\n"); + i += 2; + if (i != 2) return 1; + + puts ("t: i -= 2\n"); + i -= 2; + if (i != 0) return 1; + puts ("t: (one == 1) ?\n"); (one == 1) ? 1 : exit (1); puts ("t: (f) ?\n"); (f) ? exit (1) : 1; - puts ("t: *g_cells != 'A'\n"); + puts ("t: *g_chars != 'A'\n"); arena[0] = 'A'; - if (*g_cells != 'A') return 1; + if (*g_chars != 'A') return 1; puts ("t: *x != 'A'\n"); - char *x = g_cells; if (*x != 'A') return 1; + puts ("t: *y != 'A'\n"); + if (*y != 'A') return 1; + puts ("t: *x != 'Q'\n"); - g_cells[0] = 'Q'; + g_chars[0] = 'Q'; if (*x != 'Q') return 1; puts ("t: *x++ != 'C'\n"); *x++ = c; - if (*g_cells != 'C') return 1; + if (*g_chars != 'C') return 1; puts ("t: switch 0\n"); if (swits (0) != 0) return swits (0); @@ -237,6 +383,10 @@ test (char *p) return 1; ok0: + puts ("t: if (0); return 1; else;\n"); + if (0) return 1; else goto ok01; + ok01: + puts ("t: if (t)\n"); if (t) goto ok1; return 1; @@ -291,6 +441,11 @@ test (char *p) return 1; ok8: + puts ("t: if (f || t)\n"); + if (f || t) goto ok80; + return 1; + ok80: + puts ("t: if (++i)\n"); if (++i) goto ok9; return 1; @@ -301,36 +456,59 @@ test (char *p) return 1; ok10: - puts ("t: *g_cells == 'B'\n"); + puts ("t: *g_chars == 'B'\n"); arena[0] = 'B'; - if (*g_cells == 'B') goto ok11; + if (*g_chars == 'B') goto ok11; return 1; - ok11: + ok11: puts ("t: *x == 'B'\n"); - x = g_cells; + x = arena; if (*x == 'B') goto ok12; return 1; ok12: - puts ("t: *x == 'R'\n"); - g_cells[0] = 'R'; - x = g_cells; - if (*x == 'R') goto ok13; + puts ("t: *y == 'B'\n"); + y = g_chars; + if (*y == 'B') goto ok13; return 1; ok13: - puts ("t: *x++ == 'C'\n"); - *x++ = c; - if (*g_cells == 'C') goto ok14; + puts ("t: *x == 'R'\n"); + g_chars[0] = 'R'; + if (*x == 'R') goto ok14; return 1; ok14: - puts ("t: for (i=0; i<4; ++i)\n"); - for (i=0; i<4; ++i); - if (i != 4) return i; + puts ("t: *x++ == 'C'\n"); + *x++ = c; + if (*g_chars == 'C') goto ok15; + return 1; + ok15: - return 0; + puts ("t: for (i=1; i<5; ++i)\n"); + for (i=1; i<5; ++i); + if (i != 5) return i; + + return struct_test (); +} +#endif + +int +main (int argc, char *argv[]) +{ + char *p = "t.c\n"; + puts ("t.c\n"); + + if (argc > 1 && !strcmp (argv[1], "--help")) return 1; + puts ("t: if (argc > 1 && !strcmp (argv[1], \"--help\")\n"); + + // FIXME mescc?! + if (argc > 1) if (!strcmp (argv[1], "--help")) return 1; + + return test (p); + + return 22; } #if __GNUC__ diff --git a/scaffold/tiny-mes.c b/scaffold/tiny-mes.c index 5e7261b2..2804e6f2 100644 --- a/scaffold/tiny-mes.c +++ b/scaffold/tiny-mes.c @@ -31,6 +31,8 @@ #define NYACC_CDR nyacc_cdr #endif +char arena[200]; + int g_stdin = 0; #if __GNUC__ @@ -262,12 +264,10 @@ struct scm { SCM cdr; }; -#if 0 -char arena[200]; -struct scm *g_cells = (struct scm*)arena; -#else -struct scm g_cells[200]; -#endif +//char arena[200]; +//struct scm *g_cells = arena; +//struct scm *g_cells = (struct scm*)arena; +struct scm *g_cells = arena; #define cell_nil 1 #define cell_f 2 @@ -348,7 +348,7 @@ fill () TYPE (9) = 0x2d2d2d2d; CAR (9) = 0x2d2d2d2d; CDR (9) = 0x3e3e3e3e; -#if 0 + // (A(B)) TYPE (10) = PAIR; CAR (10) = 11; @@ -373,35 +373,7 @@ fill () TYPE (14) = 0x58585858; CAR (14) = 0x58585858; CDR (14) = 0x58585858; -#else - // (cons 0 1) - TYPE (10) = PAIR; - CAR (10) = 11; - CDR (10) = 12; - TYPE (11) = FUNCTION; - CAR (11) = 0x58585858; - // 0 = make_cell - // 1 = cons - CDR (11) = 1; - - TYPE (12) = PAIR; - CAR (12) = 13; - CDR (12) = 14; - - TYPE (13) = NUMBER; - CAR (13) =0x58585858; - CDR (13) = 0; - - TYPE (14) = PAIR; - CAR (14) = 15; - CDR (14) = 1; - - TYPE (15) = NUMBER; - CAR (15) = 0x58585858; - CDR (15) = 1; - -#endif TYPE (16) = 0x3c3c3c3c; CAR (16) = 0x2d2d2d2d; CDR (16) = 0x2d2d2d2d; @@ -484,35 +456,18 @@ display_ (SCM x) SCM bload_env (SCM a) ///((internal)) { - //g_stdin = open ("module/mes/read-0-32.mo", 0); - g_stdin = open ("module/mes/hack-32.mo", 0); + puts ("reading: "); + char *mo = "module/mes/hack-32.mo"; + puts (mo); + puts ("\n"); + g_stdin = open (mo, 0); if (g_stdin < 0) {eputs ("no such file: module/mes/read-0-32.mo\n");return 1;} - int c; + // BOOM + //char *p = arena; char *p = (char*)g_cells; - char *q = (char*)g_cells; + int c; - puts ("q: "); - puts (q); - puts ("\n"); - -#if __GNUC__ - puts ("fd: "); - puts (itoa (g_stdin)); - puts ("\n"); -#endif - -#if __GNUC__ - assert (getchar () == 'M'); - assert (getchar () == 'E'); - assert (getchar () == 'S'); - puts ("GOT MES!\n"); - g_stack = getchar () << 8; - g_stack += getchar (); - puts ("stack: "); - puts (itoa (g_stack)); - puts ("\n"); -#else c = getchar (); putchar (c); if (c != 'M') exit (10); @@ -522,54 +477,30 @@ bload_env (SCM a) ///((internal)) c = getchar (); putchar (c); if (c != 'S') exit (12); - puts ("\n"); - puts ("GOT MES!\n"); + puts (" *GOT MES*\n"); + + // skip stack getchar (); getchar (); -#endif c = getchar (); + // int i = 0; while (c != -1) { *p++ = c; + //g_cells[i] = c; + // i++; c = getchar (); + //puts ("\nc:"); + //putchar (c); } - puts ("q: "); - puts (q); - puts ("\n"); -#if 0 - //__GNUC__ - g_free = (p-(char*)g_cells) / sizeof (struct scm); - gc_peek_frame (); - g_symbols = r1; - g_stdin = STDIN; - r0 = mes_builtins (r0); - - puts ("cells read: "); - puts (itoa (g_free)); - puts ("\n"); - - puts ("symbols: "); - puts (itoa (g_symbols)); - puts ("\n"); - display_ (g_symbols); - puts ("\n"); - - r2 = 10; - puts ("\n"); - puts ("program: "); - puts (itoa (r2)); - puts ("\n"); - display_ (r2); - puts ("\n"); -#else + puts ("read done\n"); display_ (10); - puts ("\n"); - puts ("\n"); - fill (); - display_ (10); -#endif + // puts ("\n"); + // fill (); + // display_ (10); + puts ("\n"); return r2; } @@ -577,52 +508,20 @@ bload_env (SCM a) ///((internal)) int main (int argc, char *argv[]) { - puts ("filled sexp:\n"); + // if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE\n"); + // if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");eputs (VERSION);return eputs ("\n");}; + + // if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE\n"); + + // puts ("Hello tiny-mes!\n"); fill (); + puts (g_cells); + puts ("\n"); + // return 22; display_ (10); puts ("\n"); - -#if __GNUC__ - g_debug = (int)getenv ("MES_DEBUG"); -#endif - //if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA")); - - if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE\n"); - if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");eputs (VERSION);return eputs ("\n");}; - - if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE\n"); - - -#if __GNUC__ - g_stdin = STDIN; - r0 = mes_environment (); -#endif - -#if MES_MINI - puts ("Hello tiny-mes!\n"); SCM program = bload_env (r0); -#else - SCM program = (argc > 1 && !strcmp (argv[1], "--load")) - ? bload_env (r0) : load_env (r0); - if (argc > 1 && !strcmp (argv[1], "--dump")) return dump (); - - push_cc (r2, cell_unspecified, r0, cell_unspecified); - r3 = cell_vm_begin; - r1 = eval_apply (); - stderr_ (r1); - - eputs ("\n"); - gc (g_stack); -#endif -#if __GNUC__ - if (g_debug) - { - eputs ("\nstats: ["); - eputs (itoa (g_free)); - eputs ("]\n"); - } -#endif return 0; }