;;; Code:
+;;(define barf #f)
+
(cond-expand
(guile-2
(set-port-encoding! (current-output-port) "ISO-8859-1"))
(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)
((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
(define <constants> '<constants>)
(define <functions> '<functions>)
(define <globals> '<globals>)
+(define <init> '<init>)
(define <locals> '<locals>)
(define <function> '<function>)
(define <text> '<text>)
-(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
(<info> (list <info>
(cons <types> types)
(cons <constants> constants)
(cons <functions> functions)
(cons <globals> globals)
+ (cons <init> init)
(cons <locals> locals)
(cons <function> function)
(cons <text> text)))))
(pmatch o
((<info> . ,alist) (assq-ref alist <globals>))))
+(define (.init o)
+ (pmatch o
+ ((<info> . ,alist) (assq-ref alist <init>))))
+
(define (.locals o)
(pmatch o
((<info> . ,alist) (assq-ref alist <locals>))))
(constants (.constants o))
(functions (.functions o))
(globals (.globals o))
+ (init (.init o))
(locals (.locals o))
(function (.function o))
(text (.text o)))
(constants constants)
(functions functions)
(globals globals)
+ (init init)
(locals locals)
(function function)
(text text))
- (make <info> #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:function function #:text text))))))
+ (make <info> #: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)
+(define (string->global string)
+ (make-global string "string" 0 (append (string->list string) (list #\nul))))
+
+(define (ident->global name type pointer value)
+ (make-global name type pointer (int->bv32 value)))
+
+(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 local)
- ((push-global globals) o))))) ;; FIXME: char*/int
+ (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-ref globals locals)
+(define (push-ident-address info)
(lambda (o)
- (let ((local (assoc-ref locals o)))
- (if local (i386:push-local-ref local)
- ((push-global-ref globals) 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 globals locals)
+(define (push-ident-de-ref 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-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)
(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))
(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)
,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)))
-
- ;; 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)))
+ (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
- (list (lambda (f g t d)
+ (append (.text info)
+ ((ident->accu info) name))))
+
+ ((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->base index)
- (i386:base->accu)
- (if (> size 1) (i386:accu+accu) '())
- (if (= size 3) (i386:accu+base) '())
- (i386:accu-shl 2))))
+ (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 t d)
- (i386:accu+base)))))))
+ (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)))))))
- ;; 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)))
+ ((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
- ((ident->base info) index)
- (list (lambda (f g t d)
+ ((ident->accu info) name))))
+
+ ((de-ref (p-expr (ident ,name)))
+ (stderr "de-ref: ~a\n" name)
+ (clone info #:text
+ (append text
+ ((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))
(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
(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)))))
(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)))))
(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
(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)))))
(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))
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))
(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)))
(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
#: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))
(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))))
(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))))
((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?)))))))
(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?))))))))
(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)))))))
(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
(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)))
;; 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)))
- (clone info #:text
- (append text
- ((ident->base info) a)
- (list (lambda (f g t d)
- (append
- (i386:value->accu b)
- (i386:sub-base))))))))
-
- ((eq (p-expr (ident ,a)) (p-expr (char ,b)))
- (let ((b (char->integer (car (string->list b)))))
- (clone info #:text
- (append text
- ((ident->base info) a)
- (list (lambda (f g t d)
- (append
- (i386:value->accu b)
- (i386:sub-base))))))))
-
- ((eq (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))))))))
-
- ((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))))
+ ((eq ,a ,b)
+ (let* ((base ((expr->base info) a))
+ (empty (clone base #:text '()))
+ (accu ((expr->accu empty) 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)))))
+ (.text base)
+ (.text accu)
+ (list (lambda (f g ta t d)
+ (i386:sub-base)))))))
+
+ ((gt ,a ,b)
+ (let* ((base ((expr->base info) a))
+ (empty (clone base #:text '()))
+ (accu ((expr->accu empty) 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)))
+ (.text base)
+ (.text accu)
+ (list (lambda (f g ta t d)
+ (i386:sub-base)))))))
+
+ ((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)
(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))))))))
-
- ((ne (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
- (let ((b (- (cstring->number b))))
+ (.text base)
+ (.text accu)
+ (list (lambda (f g ta t d)
+ (i386:base-sub)))))))
+
+ ;; 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
;; 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
;; 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
;; 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 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))))
+ ;; 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))))))
- ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
+ ;; SCM g_stack = 0;
+ ((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
((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
;; 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)))))
+ (.text base)
+ ((base->ident-address info) name)
+ ((ident-add info) name 1)))))
- ;; 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)))))
+ ;; CAR (x) = 0
+ ;; 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 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)
+ ))))))
- ((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)))))
+ ;; i = 0;
+ ;; c = f ();
+ ;; i = i + 48;
;; 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))))
-
+ ((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 _) (p-expr (fixed ,value))))
- (let ((value (cstring->number value)))
+ ((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
- (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)))))))
-
- ;; 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))
- (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)
+ ;;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
(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))
(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)))
(define (compile)
(let* ((ast (mescc))
- (info (make <info> #:functions i386:libc))
+ (info (make <info>
+ #:functions i386:libc
+ #:types i386:type-alist))
(ast (append libc ast))
(info ((ast->info info) ast))
(info ((ast->info info) _start)))
#define NYACC_CDR nyacc_cdr
#endif
+char arena[2000];
+//char buf0[400];
+
int g_stdin = 0;
#if __GNUC__
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
+
+struct scm {
+ enum type_t type;
+ SCM car;
+ SCM cdr;
+};
+
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;
+struct function {
+ int (*function) (void);
int arity;
-} function_t;
-struct scm;
+};
+
+struct scm *g_cells = arena;
+
+//scm *g_news = 0;
+
+// 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*"};
+
+// 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"
-typedef 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 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*"};
-
-scm scm_vm_apply = {SPECIAL, "core:apply"};
-scm scm_vm_apply2 = {SPECIAL, "*vm-apply2*"};
-
-scm scm_vm_eval = {SPECIAL, "core:eval"};
-
-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*"};
-
-scm scm_vm_return = {SPECIAL, "*vm-return*"};
-
-//#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
#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)
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 {
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
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)
+gc_push_frame ()
{
- 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 frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
+ g_stack = cons (frame, g_stack);
+ return g_stack;
}
SCM
-gc_push_frame ()
+xgc_push_frame ()
{
- SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
- return g_stack = cons (frame, g_stack);
+ // SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
+ // g_stack = cons (frame, g_stack);
+ return g_stack;
}
SCM
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;
}
SCM
push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
{
+ puts ("push_cc\n");
SCM x = r3;
r3 = c;
r2 = p2;
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));}
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;
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;
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;
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;
r1 = assert_defined (r1, assq_ref_env (r1, r0));
goto vm_return;
}
- default: goto vm_return;
+ default: {goto vm_return;}
}
// SCM macro;
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 ();
// 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;
//\f Environment setup
SCM
-make_tmps (scm* cells)
+make_tmps (struct scm* cells)
{
tmp = g_free++;
cells[tmp].type = CHAR;
cells[tmp_num].type = NUMBER;
tmp_num2 = g_free++;
cells[tmp_num2].type = NUMBER;
+ return 0;
}
SCM
//#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<g_symbol_max; i++)
g_symbols = cons (i, g_symbols);
#if __GNUC__ && 0
//#include "mes.symbol-names.i"
#else
-g_cells[cell_nil].car = cstring_to_list (scm_nil.name);
-g_cells[cell_f].car = cstring_to_list (scm_f.name);
-g_cells[cell_t].car = cstring_to_list (scm_t.name);
-g_cells[cell_dot].car = cstring_to_list (scm_dot.name);
-g_cells[cell_arrow].car = cstring_to_list (scm_arrow.name);
-g_cells[cell_undefined].car = cstring_to_list (scm_undefined.name);
-g_cells[cell_unspecified].car = cstring_to_list (scm_unspecified.name);
-g_cells[cell_closure].car = cstring_to_list (scm_closure.name);
-g_cells[cell_circular].car = cstring_to_list (scm_circular.name);
-g_cells[cell_begin].car = cstring_to_list (scm_begin.name);
+// g_cells[cell_nil].car = cstring_to_list (scm_nil.name);
+// g_cells[cell_f].car = cstring_to_list (scm_f.name);
+// g_cells[cell_t].car = cstring_to_list (scm_t.name);
+// g_cells[cell_dot].car = cstring_to_list (scm_dot.name);
+// g_cells[cell_arrow].car = cstring_to_list (scm_arrow.name);
+// g_cells[cell_undefined].car = cstring_to_list (scm_undefined.name);
+// g_cells[cell_unspecified].car = cstring_to_list (scm_unspecified.name);
+// g_cells[cell_closure].car = cstring_to_list (scm_closure.name);
+// g_cells[cell_circular].car = cstring_to_list (scm_circular.name);
+// g_cells[cell_begin].car = cstring_to_list (scm_begin.name);
#endif
// a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
// a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
+ //FIXME GNUC
a = acons (cell_symbol_dot, cell_dot, a); //
a = acons (cell_symbol_begin, cell_begin, a);
a = acons (cell_closure, a, a);
SCM
mes_environment () ///((internal))
{
- SCM a = mes_symbols ();
- return mes_g_stack (a);
+ SCM a = 0;
+ a = mes_symbols ();
+ a = mes_g_stack (a);
+ return a;
}
SCM
// #include "posix.environment.i"
// #include "reader.environment.i"
#else
-scm_make_cell.function = g_function;
+
+scm_make_cell.cdr = g_function;
functions[g_function++] = fun_make_cell;
cell_make_cell = g_free++;
-g_cells[cell_make_cell] = scm_make_cell;
-
-scm_cons.function = g_function;
+#if __GNUC__
+ puts ("WOOOT=");
+ puts (itoa (g_free));
+ //FIXME GNUC
+#else
+g_cells[16] = scm_make_cell;
+#endif
+
+scm_cons.cdr = g_function;
functions[g_function++] = fun_cons;
cell_cons = g_free++;
+#if __GNUC__
+ //FIXME GNUC
g_cells[cell_cons] = scm_cons;
-
-scm_car.function = g_function;
+#else
+g_cells[17] = scm_cons;
+#endif
+
+scm_car.cdr = g_function;
functions[g_function++] = fun_car;
cell_car = g_free++;
+#if __GNUC__
+ //FIXME GNUC
g_cells[cell_car] = scm_car;
-
-scm_cdr.function = g_function;
+#endif
+
+#if __GNUC__
+ //FIXME GNUC
+scm_cdr.cdr = g_function;
functions[g_function++] = fun_cdr;
cell_cdr = g_free++;
g_cells[cell_cdr] = scm_cdr;
// scm_cdr.string = cstring_to_list (scm_cdr.name);
// g_cells[cell_cdr].string = MAKE_STRING (scm_cdr.string);
// a = acons (make_symbol (scm_cdr.string), cell_cdr, a);
+#endif
#endif
return a;
}
*p++ = c;
c = getchar ();
}
- g_free = (p-(char*)g_cells) / sizeof (scm);
+ g_free = (p-(char*)g_cells) / sizeof (struct scm);
gc_peek_frame ();
g_symbols = r1;
g_stdin = STDIN;
CDR (12) = 1;
TYPE (13) = CHAR;
- CAR (11) = 0x58585858;
+ CAR (13) = 0x58585858;
CDR (13) = 90;
TYPE (14) = 0x58585858;
CAR (10) = 11;
CDR (10) = 12;
- TYPE (11) = FUNCTION;
+ TYPE (11) = TFUNCTION;
CAR (11) = 0x58585858;
// 0 = make_cell
// 1 = cons
+ // 2 = car
CDR (11) = 1;
TYPE (12) = PAIR;
CAR (12) = 13;
+ //CDR (12) = 1;
CDR (12) = 14;
TYPE (13) = NUMBER;
- CAR (13) =0x58585858;
+ CAR (13) = 0x58585858;
CDR (13) = 0;
TYPE (14) = PAIR;
CDR (15) = 1;
#endif
- TYPE (16) = 0x3c3c3c3c;
- CAR (16) = 0x2d2d2d2d;
- CDR (16) = 0x2d2d2d2d;
+
return 0;
}
putchar (VALUE (x));
break;
}
- case FUNCTION:
+ case TFUNCTION:
{
//puts ("<function>\n");
if (VALUE (x) == 0)
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;
-
- puts ("q: ");
- puts (q);
- puts ("\n");
+ int c;
-#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: ");
c = getchar ();
putchar (c);
if (c != 'S') exit (12);
- puts ("\n");
- puts ("GOT MES!\n");
+ puts (" *GOT MES*\n");
+
+ // skip stack
getchar ();
getchar ();
#endif
{
*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");
puts ("symbols: ");
puts (itoa (g_symbols));
puts ("\n");
- display_ (g_symbols);
+ // display_ (g_symbols);
+ // puts ("\n");
+#endif
+
+ display_ (10);
puts ("\n");
fill ();
-
r2 = 10;
- puts ("\n");
- puts ("program: ");
+
+ if (TYPE (12) != PAIR)
+ exit (33);
+
+ puts ("program[");
+#if __GNUC__
puts (itoa (r2));
- puts ("\n");
- display_ (r2);
- puts ("\n");
-#else
- display_ (10);
- puts ("\n");
- puts ("\n");
- fill ();
- display_ (10);
#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;
}
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
eputs ("]\n");
}
#endif
- puts ("Hello mini-mes!\n");
return 0;
}
projects / mes.git / commitdiff