mescc: Refactor type system: introduce <array>, <pointer>, <var>.
* module/language/c99/info.scm (<array>, <pointer>, <var>): New type. * module/language/c99/compiler.mes (ast-><type>): New function. (ast-type): Use it.
This commit is contained in:
Jan Nieuwenhuizen
parent
c9ba7a619b
commit
b75dd7eca2
|
|
@ -135,42 +135,42 @@
|
|||
(cons name value))
|
||||
|
||||
(define (enum->type-entry name fields)
|
||||
(cons `("tag" ,name) (make-type 'enum 4 0 fields)))
|
||||
(cons `(tag ,name) (make-type 'enum 4 fields)))
|
||||
|
||||
(define (struct->type-entry name fields)
|
||||
(cons `("tag" ,name) (make-type 'struct (apply + (map field:size fields)) 0 fields)))
|
||||
(cons `(tag ,name) (make-type 'struct (apply + (map field:size fields)) fields)))
|
||||
|
||||
(define (union->type-entry name fields)
|
||||
(cons `("tag" ,name) (make-type 'union (apply + (map field:size fields)) 0 fields)))
|
||||
(cons `(tag ,name) (make-type 'union (apply + (map field:size fields)) fields)))
|
||||
|
||||
(define i386:type-alist
|
||||
`(("char" . ,(make-type 'builtin 1 0 #f))
|
||||
("short" . ,(make-type 'builtin 2 0 #f))
|
||||
("int" . ,(make-type 'builtin 4 0 #f))
|
||||
("long" . ,(make-type 'builtin 4 0 #f))
|
||||
;;("long long" . ,(make-type 'builtin 8 0 #f))
|
||||
;;("long long int" . ,(make-type 'builtin 8 0 #f))
|
||||
`(("char" . ,(make-type 'builtin 1 #f))
|
||||
("short" . ,(make-type 'builtin 2 #f))
|
||||
("int" . ,(make-type 'builtin 4 #f))
|
||||
("long" . ,(make-type 'builtin 4 #f))
|
||||
;;("long long" . ,(make-type 'builtin 8 #f))
|
||||
;;("long long int" . ,(make-type 'builtin 8 #f))
|
||||
|
||||
("long long" . ,(make-type 'builtin 4 0 #f)) ;; FIXME
|
||||
("long long int" . ,(make-type 'builtin 4 0 #f))
|
||||
("long long" . ,(make-type 'builtin 4 #f)) ;; FIXME
|
||||
("long long int" . ,(make-type 'builtin 4 #f))
|
||||
|
||||
("void" . ,(make-type 'builtin 1 0 #f))
|
||||
("void" . ,(make-type 'builtin 1 #f))
|
||||
;; FIXME sign
|
||||
("unsigned char" . ,(make-type 'builtin 1 0 #f))
|
||||
("unsigned short" . ,(make-type 'builtin 2 0 #f))
|
||||
("unsigned short int" . ,(make-type 'builtin 2 0 #f))
|
||||
("unsigned" . ,(make-type 'builtin 4 0 #f))
|
||||
("unsigned int" . ,(make-type 'builtin 4 0 #f))
|
||||
("unsigned long" . ,(make-type 'builtin 4 0 #f))
|
||||
("unsigned char" . ,(make-type 'builtin 1 #f))
|
||||
("unsigned short" . ,(make-type 'builtin 2 #f))
|
||||
("unsigned short int" . ,(make-type 'builtin 2 #f))
|
||||
("unsigned" . ,(make-type 'builtin 4 #f))
|
||||
("unsigned int" . ,(make-type 'builtin 4 #f))
|
||||
("unsigned long" . ,(make-type 'builtin 4 #f))
|
||||
|
||||
;; ("unsigned long long" . ,(make-type 'builtin 8 0 #f))
|
||||
;; ("unsigned long long int" . ,(make-type 'builtin 8 0 #f))
|
||||
("unsigned long long" . ,(make-type 'builtin 4 0 #f)) ;; FIXME
|
||||
("unsigned long long int" . ,(make-type 'builtin 4 0 #f))
|
||||
;; ("unsigned long long" . ,(make-type 'builtin 8 #f))
|
||||
;; ("unsigned long long int" . ,(make-type 'builtin 8 #f))
|
||||
("unsigned long long" . ,(make-type 'builtin 4 #f)) ;; FIXME
|
||||
("unsigned long long int" . ,(make-type 'builtin 4 #f))
|
||||
|
||||
("float" . ,(make-type 'builtin 4 0 #f))
|
||||
("double" . ,(make-type 'builtin 8 0 #f))
|
||||
("long double" . ,(make-type 'builtin 16 0 #f))))
|
||||
("float" . ,(make-type 'builtin 4 #f))
|
||||
("double" . ,(make-type 'builtin 8 #f))
|
||||
("long double" . ,(make-type 'builtin 16 #f))))
|
||||
|
||||
(define (field:name o)
|
||||
(pmatch o
|
||||
|
|
@ -202,102 +202,125 @@
|
|||
(_ (error (format #f "field:type: ~s\n" o)))))
|
||||
|
||||
(define (ast->type info o)
|
||||
(define (get-type o)
|
||||
(let ((t (assoc-ref (.types info) o)))
|
||||
(pmatch t
|
||||
((typedef ,next) (or (get-type next) o))
|
||||
(_ t))))
|
||||
(-><type> (ast-><type> o info)))
|
||||
|
||||
(define (get-type o info)
|
||||
(let ((t (assoc-ref (.types info) o)))
|
||||
(pmatch t
|
||||
((typedef ,next) (or (get-type next info) o))
|
||||
(_ t))))
|
||||
|
||||
(define (ast-><type> o info)
|
||||
(stderr "ast-><type> o=~s\n" o)
|
||||
(pmatch o
|
||||
(,t (guard (type? t)) t)
|
||||
((p-expr ,expr) (ast->type info expr))
|
||||
((pre-inc ,expr) (ast->type info expr))
|
||||
((post-inc ,expr) (ast->type info expr))
|
||||
(,p (guard (pointer? p)) p)
|
||||
(,a (guard (c-array? a)) a)
|
||||
|
||||
((char ,value) (get-type "char" info))
|
||||
((enum-ref . _) (get-type "int" info))
|
||||
((fixed ,value) (get-type "int" info))
|
||||
((sizeof-expr . _) (get-type "int" info))
|
||||
((sizeof-type . _) (get-type "int" info))
|
||||
((string _) (make-c-array (get-type "char" info) #f))
|
||||
((void) (get-type "void" info))
|
||||
|
||||
((ident ,name) (ident->type info name))
|
||||
((char ,value) (get-type "char"))
|
||||
((fixed ,value) (get-type "int"))
|
||||
((type-spec (typename ,type))
|
||||
(ast->type info type))
|
||||
((array-ref ,index ,array)
|
||||
(ast->type info array))
|
||||
((fctn-call (p-expr (ident ,name)) . _) (ident->type info name))
|
||||
|
||||
|
||||
((fixed-type ,type) (ast-><type> type info))
|
||||
((float-type ,type) (ast-><type> type info))
|
||||
((typename ,type) (ast-><type> type info))
|
||||
|
||||
((array-ref ,index ,array) (rank-- (ast-><type> array info)))
|
||||
|
||||
((de-ref ,expr) (rank-- (ast-><type> expr info)))
|
||||
((ref-to ,expr) (rank++ (ast-><type> expr info)))
|
||||
|
||||
((p-expr ,expr) (ast-><type> expr info))
|
||||
((pre-inc ,expr) (ast-><type> expr info))
|
||||
((post-inc ,expr) (ast-><type> expr info))
|
||||
|
||||
((type-spec (typename ,type)) (ast-><type> type info))
|
||||
|
||||
((struct-ref (ident ,type))
|
||||
(or (get-type type)
|
||||
(let ((struct (if (pair? type) type `("tag" ,type))))
|
||||
(ast->type info struct))))
|
||||
(or (get-type type info)
|
||||
(let ((struct (if (pair? type) type `(tag ,type))))
|
||||
(ast-><type> struct info))))
|
||||
((union-ref (ident ,type))
|
||||
(or (get-type type)
|
||||
(let ((struct (if (pair? type) type `("tag" ,type))))
|
||||
(ast->type info struct))))
|
||||
(or (get-type type info)
|
||||
(let ((struct (if (pair? type) type `(tag ,type))))
|
||||
(ast-><type> struct info))))
|
||||
|
||||
;;;
|
||||
((struct-def (ident ,name) . _)
|
||||
(ast->type info `("tag" ,name)))
|
||||
(ast-><type> `(tag ,name) info))
|
||||
((union-def (ident ,name) . _)
|
||||
(ast->type info `("tag" ,name)))
|
||||
(ast-><type> `(tag ,name) info))
|
||||
((struct-def (field-list . ,fields))
|
||||
(let ((fields (append-map (struct-field info) fields)))
|
||||
(make-type 'struct (apply + (map field:size fields)) 0 fields)))
|
||||
(make-type 'struct (apply + (map field:size fields)) fields)))
|
||||
((union-def (field-list . ,fields))
|
||||
(let ((fields (append-map (struct-field info) fields)))
|
||||
(make-type 'union (apply + (map field:size fields)) 0 fields)))
|
||||
((void) (ast->type info "void"))
|
||||
((fixed-type ,type) (ast->type info type))
|
||||
((float-type ,type) (ast->type info type))
|
||||
((typename ,type) (ast->type info type))
|
||||
((de-ref ,expr)
|
||||
(ast->type info expr))
|
||||
(make-type 'union (apply + (map field:size fields)) fields)))
|
||||
|
||||
|
||||
|
||||
((d-sel (ident ,field) ,struct)
|
||||
(let ((type0 (ast->type info struct)))
|
||||
(ast->type info (field-type info type0 field))))
|
||||
(let ((type0 (ast-><type> struct info)))
|
||||
(ast-><type> (field-type info type0 field) info)))
|
||||
((i-sel (ident ,field) ,struct)
|
||||
(let ((type0 (ast->type info struct)))
|
||||
(ast->type info (field-type info type0 field))))
|
||||
((ref-to ,expr) (ast->type info expr))
|
||||
((pre-inc ,a) (ast->type info a))
|
||||
((pre-dec ,a) (ast->type info a))
|
||||
((post-inc ,a) (ast->type info a))
|
||||
((post-dec ,a) (ast->type info a))
|
||||
((add ,a ,b) (ast->type info a))
|
||||
((sub ,a ,b) (ast->type info a))
|
||||
((bitwise-and ,a ,b) (ast->type info a))
|
||||
((bitwise-not ,a) (ast->type info a))
|
||||
((bitwise-or ,a ,b) (ast->type info a))
|
||||
((bitwise-xor ,a ,b) (ast->type info a))
|
||||
((lshift ,a ,b) (ast->type info a))
|
||||
((rshift ,a ,b) (ast->type info a))
|
||||
((div ,a ,b) (ast->type info a))
|
||||
((mod ,a ,b) (ast->type info a))
|
||||
((mul ,a ,b) (ast->type info a))
|
||||
((not ,a) (ast->type info a))
|
||||
((neg ,a) (ast->type info a))
|
||||
((eq ,a ,b) (ast->type info a))
|
||||
((ge ,a ,b) (ast->type info a))
|
||||
((gt ,a ,b) (ast->type info a))
|
||||
((ne ,a ,b) (ast->type info a))
|
||||
((le ,a ,b) (ast->type info a))
|
||||
((lt ,a ,b) (ast->type info a))
|
||||
((or ,a ,b) (ast->type info a))
|
||||
((and ,a ,b) (ast->type info a))
|
||||
(let ((type0 (ast-><type> struct info)))
|
||||
(ast-><type> (field-type info type0 field) info)))
|
||||
|
||||
;; arithmetic
|
||||
((pre-inc ,a) (ast-><type> a info))
|
||||
((pre-dec ,a) (ast-><type> a info))
|
||||
((post-inc ,a) (ast-><type> a info))
|
||||
((post-dec ,a) (ast-><type> a info))
|
||||
((add ,a ,b) (ast-><type> a info))
|
||||
((sub ,a ,b) (ast-><type> a info))
|
||||
((bitwise-and ,a ,b) (ast-><type> a info))
|
||||
((bitwise-not ,a) (ast-><type> a info))
|
||||
((bitwise-or ,a ,b) (ast-><type> a info))
|
||||
((bitwise-xor ,a ,b) (ast-><type> a info))
|
||||
((lshift ,a ,b) (ast-><type> a info))
|
||||
((rshift ,a ,b) (ast-><type> a info))
|
||||
((div ,a ,b) (ast-><type> a info))
|
||||
((mod ,a ,b) (ast-><type> a info))
|
||||
((mul ,a ,b) (ast-><type> a info))
|
||||
((not ,a) (ast-><type> a info))
|
||||
((neg ,a) (ast-><type> a info))
|
||||
((eq ,a ,b) (ast-><type> a info))
|
||||
((ge ,a ,b) (ast-><type> a info))
|
||||
((gt ,a ,b) (ast-><type> a info))
|
||||
((ne ,a ,b) (ast-><type> a info))
|
||||
((le ,a ,b) (ast-><type> a info))
|
||||
((lt ,a ,b) (ast-><type> a info))
|
||||
|
||||
;; logical
|
||||
((or ,a ,b) (ast-><type> a info))
|
||||
((and ,a ,b) (ast-><type> a info))
|
||||
|
||||
|
||||
((cast (type-name ,type) ,expr) ; FIXME: ignore expr?
|
||||
(ast->type info type))
|
||||
(ast-><type> type info))
|
||||
((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: ignore expr?
|
||||
(ast->type info type))
|
||||
(ast-><type> type info))
|
||||
|
||||
((decl-spec-list (type-spec ,type))
|
||||
(ast->type info type))
|
||||
(ast-><type> type info))
|
||||
((assn-expr ,a ,op ,b)
|
||||
(ast->type info a))
|
||||
((enum-ref . _) (get-type "int"))
|
||||
((sizeof-type . _) (get-type "int"))
|
||||
((sizeof-expr . _) (get-type "int"))
|
||||
((string _) (get-type "char"))
|
||||
((fctn-call (p-expr (ident ,function)) . ,rest)
|
||||
(or (and=> (assoc-ref (.functions info) function) function:type)
|
||||
(begin
|
||||
(stderr "ast->type: no such function: ~s\n" function)
|
||||
(get-type "int"))))
|
||||
(_ (let ((type (get-type o)))
|
||||
(ast-><type> a info))
|
||||
|
||||
|
||||
(_ (let ((type (get-type o info)))
|
||||
(cond ((type? type) type)
|
||||
((and (pair? type) (equal? (car type) "tag"))
|
||||
((and (pair? type) (eq? (car type) 'tag))
|
||||
(stderr "NO STRUCT YET:~s\n" (.types info))
|
||||
type)
|
||||
((and (pair? o) (equal? (car o) "tag"))
|
||||
((and (pair? o) (eq? (car o) 'tag))
|
||||
(stderr "NO STRUCT YET:~s\n" (.types info))
|
||||
o)
|
||||
(else
|
||||
|
|
@ -308,11 +331,7 @@
|
|||
((compose type:description (cut ast->type info <>) o)))
|
||||
|
||||
(define (ast-type->size info o)
|
||||
;;((compose type:size (cut ast->type info <>)) o)
|
||||
(let ((type (if (type? o) o
|
||||
(ast->type info o))))
|
||||
(if (not (type? type)) (error "ast-type->size: no such type:" o)
|
||||
(type:size type))))
|
||||
((compose type:size -><type> (cut ast->type info <>)) o))
|
||||
|
||||
(define (field-field info struct field)
|
||||
(let* ((xtype (if (type? struct) struct
|
||||
|
|
@ -395,21 +414,23 @@
|
|||
(let ((var (ident->variable info o)))
|
||||
(cond ((global? var) (global:type var))
|
||||
((local? var) (local:type var))
|
||||
((function? var) (function:type var))
|
||||
((assoc-ref (.constants info) o) (assoc-ref (.types info) "int"))
|
||||
((pair? var) (car var))
|
||||
(else (stderr "ident->type ~s => ~s\n" o var)
|
||||
#f))))
|
||||
|
||||
(define (ident->pointer info o)
|
||||
(define (ident->rank info o)
|
||||
(let ((local (assoc-ref (.locals info) o)))
|
||||
(if local (let* ((t ((compose type:pointer local:type) local))
|
||||
(if local (let* ((t 0 ;; <pointer> ((compose type:pointer local:type) local)
|
||||
)
|
||||
(v (local:pointer local))
|
||||
(p (+ (abs t) (abs v))))
|
||||
(if (or (< t 0) (< v 0)) (- p) p))
|
||||
(let ((global (assoc-ref (.globals info) o)))
|
||||
(if global
|
||||
(let* ((t ((compose type:pointer global:type) global))
|
||||
;;(global:pointer (ident->variable info o))
|
||||
(let* ((t 0 ;; <pointer> ((compose type:pointer global:type) global)
|
||||
)
|
||||
(v (global:pointer global))
|
||||
(p (+ (abs t) (abs v))))
|
||||
(if (or (< t 0) (< v 0)) (- p) p))
|
||||
|
|
@ -431,28 +452,28 @@
|
|||
((pointer) 1)
|
||||
((pointer ,pointer) (1+ (pointer->ptr pointer)))))
|
||||
|
||||
(define (expr->pointer info o)
|
||||
(define (expr->rank info o)
|
||||
(pmatch o
|
||||
((pointer . _) (pointer->ptr o))
|
||||
((p-expr (char ,value)) 0)
|
||||
((p-expr (fixed ,value)) 0)
|
||||
((ident ,name) (ident->pointer info name))
|
||||
((p-expr ,expr) (expr->pointer info expr))
|
||||
((de-ref ,expr) (ptr-dec (expr->pointer info expr)))
|
||||
((assn-expr ,lhs ,op ,rhs) (expr->pointer info lhs))
|
||||
((add ,a ,b) (expr->pointer info a))
|
||||
((div ,a ,b) (expr->pointer info a))
|
||||
((mod ,a ,b) (expr->pointer info a))
|
||||
((mul ,a ,b) (expr->pointer info a))
|
||||
((sub ,a ,b) (expr->pointer info a))
|
||||
((neg ,a) (expr->pointer info a))
|
||||
((pre-inc ,a) (expr->pointer info a))
|
||||
((pre-dec ,a) (expr->pointer info a))
|
||||
((post-inc ,a) (expr->pointer info a))
|
||||
((post-dec ,a) (expr->pointer info a))
|
||||
((ref-to ,expr) (ptr-inc (expr->pointer info expr)))
|
||||
((ident ,name) (ident->rank info name))
|
||||
((p-expr ,expr) (expr->rank info expr))
|
||||
((de-ref ,expr) (ptr-dec (expr->rank info expr)))
|
||||
((assn-expr ,lhs ,op ,rhs) (expr->rank info lhs))
|
||||
((add ,a ,b) (expr->rank info a))
|
||||
((div ,a ,b) (expr->rank info a))
|
||||
((mod ,a ,b) (expr->rank info a))
|
||||
((mul ,a ,b) (expr->rank info a))
|
||||
((sub ,a ,b) (expr->rank info a))
|
||||
((neg ,a) (expr->rank info a))
|
||||
((pre-inc ,a) (expr->rank info a))
|
||||
((pre-dec ,a) (expr->rank info a))
|
||||
((post-inc ,a) (expr->rank info a))
|
||||
((post-dec ,a) (expr->rank info a))
|
||||
((ref-to ,expr) (ptr-inc (expr->rank info expr)))
|
||||
((array-ref ,index ,array)
|
||||
(ptr-dec (abs (expr->pointer info array))))
|
||||
(ptr-dec (abs (expr->rank info array))))
|
||||
|
||||
((d-sel (ident ,field) ,struct)
|
||||
(let ((type (ast->type info struct)))
|
||||
|
|
@ -463,53 +484,52 @@
|
|||
(field-pointer info type field)))
|
||||
|
||||
((cast (type-name ,type) ,expr) ; FIXME: add expr?
|
||||
(let* ((type (ast->type info type))
|
||||
(pointer (type:pointer type)))
|
||||
pointer))
|
||||
(let* ((type (ast->type info type)))
|
||||
(->rank type)))
|
||||
((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: add expr?
|
||||
(let* ((type (ast->type info type))
|
||||
(pointer0 (type:pointer type))
|
||||
(pointer1 (ptr-declr->pointer pointer))
|
||||
(pointer2 (expr->pointer info expr)))
|
||||
(pointer0 (->rank type))
|
||||
(pointer1 (ptr-declr->rank pointer))
|
||||
(pointer2 (expr->rank info expr)))
|
||||
(+ pointer0 pointer1)))
|
||||
((type-spec ,type)
|
||||
(or (and=> (ast->type info o) type:pointer)
|
||||
(or (and=> (ast->type info o) ->rank)
|
||||
(begin
|
||||
(stderr "expr->pointer: not supported: ~a\n" o)
|
||||
(stderr "expr->rank: not supported: ~a\n" o)
|
||||
0)))
|
||||
((fctn-call (p-expr (ident ,function)) . ,rest)
|
||||
(or (and=> (and=> (assoc-ref (.functions info) function) function:type)
|
||||
(lambda (t)
|
||||
(and (type? t) (type:pointer t))))
|
||||
(and (type? t) 0 (->rank t))))
|
||||
(begin
|
||||
(stderr "expr->pointer: no such function: ~a\n" function)
|
||||
(stderr "expr->rank: no such function: ~a\n" function)
|
||||
0)))
|
||||
|
||||
((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr ,pointer ,init) . ,initzer)))
|
||||
(let* ((t (expr->pointer info `(type-spec ,type)))
|
||||
(i (expr->pointer info init))
|
||||
(p (expr->pointer info pointer))
|
||||
(let* ((t (expr->rank info `(type-spec ,type)))
|
||||
(i (expr->rank info init))
|
||||
(p (expr->rank info pointer))
|
||||
(e (+ (abs t) (abs i) (abs p))))
|
||||
(if (or (< t 0) (< i 0)) (- e) e)))
|
||||
((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr ,init . ,initzer)))
|
||||
(let* ((t (expr->pointer info `(type-spec ,type)))
|
||||
(i (expr->pointer info init))
|
||||
(let* ((t (expr->rank info `(type-spec ,type)))
|
||||
(i (expr->rank info init))
|
||||
(p (+ (abs t) (abs i))))
|
||||
(if (or (< t 0) (< i 0)) (- p) p)))
|
||||
((ptr-declr ,pointer (array-of ,array . ,rest))
|
||||
(let* ((p (expr->pointer info pointer))
|
||||
(a (expr->pointer info array))
|
||||
(let* ((p (expr->rank info pointer))
|
||||
(a (expr->rank info array))
|
||||
(t (+ (abs p) (abs a) 2)))
|
||||
(- t)))
|
||||
((ptr-declr ,pointer . ,rest)
|
||||
(expr->pointer info pointer))
|
||||
(expr->rank info pointer))
|
||||
((array-of ,array . ,rest)
|
||||
(let ((a (abs (expr->pointer info array))))
|
||||
(let ((a (abs (expr->rank info array))))
|
||||
(- (+ a 1))))
|
||||
(_ (stderr "expr->pointer: not supported: ~s\n" o) 0)))
|
||||
(_ (stderr "expr->rank: not supported: ~s\n" o) 0)))
|
||||
|
||||
(define (expr->size info o)
|
||||
(let ((ptr (expr->pointer info o)))
|
||||
(let ((ptr (expr->rank info o)))
|
||||
(if (or (= ptr -1)
|
||||
(= ptr 0))
|
||||
(ast-type->size info o)
|
||||
|
|
@ -520,7 +540,7 @@
|
|||
|
||||
(define (push-global info)
|
||||
(lambda (o)
|
||||
(let ((ptr (ident->pointer info o)))
|
||||
(let ((ptr (ident->rank info o)))
|
||||
(cond ((< ptr 0) (list (i386:push-label `(#:address ,o))))
|
||||
(else (list (i386:push-label-mem `(#:address ,o))))))))
|
||||
|
||||
|
|
@ -560,15 +580,15 @@
|
|||
(wrap-as (i386:push-byte-local-de-de-ref (local:id o)))
|
||||
(error "TODO int-de-de-ref")))))
|
||||
|
||||
(define (make-global-entry key type pointer array value)
|
||||
(cons key (make-global key type pointer array value #f)))
|
||||
(define (make-global-entry name type pointer array value)
|
||||
(cons name (make-global name type pointer array value #f)))
|
||||
|
||||
(define (string->global-entry string)
|
||||
(let ((value (append (string->list string) (list #\nul))))
|
||||
(make-global-entry `(#:string ,string) "char" 0 (length value) value)))
|
||||
|
||||
(define (make-local-entry name type pointer array id)
|
||||
(cons name (make-local type pointer array id)))
|
||||
(cons name (make-local name type pointer array id)))
|
||||
|
||||
(define* (mescc:trace name #:optional (type ""))
|
||||
(format (current-error-port) " :~a~a\n" name type))
|
||||
|
|
@ -644,13 +664,13 @@
|
|||
((assoc-ref (.statics info) o)
|
||||
=>
|
||||
(lambda (global)
|
||||
(let* ((ptr (ident->pointer info o)))
|
||||
(let* ((ptr (ident->rank info o)))
|
||||
(cond ((< ptr 0) (list (i386:label->accu `(#:address ,global))))
|
||||
(else (list (i386:label-mem->accu `(#:address ,global))))))))
|
||||
((assoc-ref (.globals info) o)
|
||||
=>
|
||||
(lambda (global)
|
||||
(let* ((ptr (ident->pointer info o)))
|
||||
(let* ((ptr (ident->rank info o)))
|
||||
(cond ((< ptr 0) (list (i386:label->accu `(#:address ,o))))
|
||||
(else (list (i386:label-mem->accu `(#:address ,o))))))))
|
||||
((assoc-ref (.constants info) o)
|
||||
|
|
@ -865,7 +885,7 @@
|
|||
|
||||
((array-ref ,index ,array)
|
||||
(let* ((info (expr->accu index info))
|
||||
(ptr (expr->pointer info array))
|
||||
(ptr (expr->rank info array))
|
||||
(size (expr->size info o))
|
||||
(info (accu*n info size))
|
||||
(info (expr->base array info)))
|
||||
|
|
@ -940,7 +960,7 @@
|
|||
(append-text info (wrap-as (i386:value->accu size)))))
|
||||
|
||||
((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,type))))))
|
||||
(let* ((type `("tag" ,type))
|
||||
(let* ((type `(tag ,type))
|
||||
(size (ast-type->size info type)))
|
||||
(append-text info (wrap-as (i386:value->accu size)))))
|
||||
|
||||
|
|
@ -964,7 +984,7 @@
|
|||
((d-sel ,field ,struct)
|
||||
(let* ((info (expr->accu* o info))
|
||||
(info (append-text info (ast->comment o)))
|
||||
(ptr (expr->pointer info o))
|
||||
(ptr (expr->rank info o))
|
||||
(size (if (= ptr 0) (ast-type->size info o)
|
||||
4)))
|
||||
(if (or (= -2 ptr) (= -1 ptr)) info
|
||||
|
|
@ -977,7 +997,7 @@
|
|||
((i-sel ,field ,struct)
|
||||
(let* ((info (expr->accu* o info))
|
||||
(info (append-text info (ast->comment o)))
|
||||
(ptr (expr->pointer info o))
|
||||
(ptr (expr->rank info o))
|
||||
(size (if (= ptr 0) (ast-type->size info o)
|
||||
4)))
|
||||
(if (or (= -2 ptr) (= ptr -1)) info
|
||||
|
|
@ -1033,7 +1053,7 @@
|
|||
((post-inc ,expr)
|
||||
(let* ((info (append (expr->accu expr info)))
|
||||
(info (append-text info (wrap-as (i386:push-accu))))
|
||||
(ptr (expr->pointer info expr))
|
||||
(ptr (expr->rank info expr))
|
||||
(size (cond ((= ptr 1) (ast-type->size info expr))
|
||||
((> ptr 1) 4)
|
||||
(else 1)))
|
||||
|
|
@ -1044,7 +1064,7 @@
|
|||
((post-dec ,expr)
|
||||
(let* ((info (append (expr->accu expr info)))
|
||||
(info (append-text info (wrap-as (i386:push-accu))))
|
||||
(ptr (expr->pointer info expr))
|
||||
(ptr (expr->rank info expr))
|
||||
(size (cond ((= ptr 1) (ast-type->size info expr))
|
||||
((> ptr 1) 4)
|
||||
(else 1)))
|
||||
|
|
@ -1053,7 +1073,7 @@
|
|||
info))
|
||||
|
||||
((pre-inc ,expr)
|
||||
(let* ((ptr (expr->pointer info expr))
|
||||
(let* ((ptr (expr->rank info expr))
|
||||
(size (cond ((= ptr 1) (ast-type->size info expr))
|
||||
((> ptr 1) 4)
|
||||
(else 1)))
|
||||
|
|
@ -1062,7 +1082,7 @@
|
|||
info))
|
||||
|
||||
((pre-dec ,expr)
|
||||
(let* ((ptr (expr->pointer info expr))
|
||||
(let* ((ptr (expr->rank info expr))
|
||||
(size (cond ((= ptr 1) (ast-type->size info expr))
|
||||
((> ptr 1) 4)
|
||||
(else 1)))
|
||||
|
|
@ -1073,10 +1093,9 @@
|
|||
|
||||
|
||||
((add ,a (p-expr (fixed ,value)))
|
||||
(let* ((ptr (expr->pointer info a))
|
||||
(let* ((ptr (expr->rank info a))
|
||||
(type (ast->type info a))
|
||||
(struct? (or (and (pair? type) (equal? (car type) "tag"))
|
||||
(memq (type:type type) '(struct union))))
|
||||
(struct? (structured-type? type))
|
||||
(size (cond ((= ptr 1) (ast-type->size info a))
|
||||
((> ptr 1) 4)
|
||||
((and struct? (= ptr -2)) 4)
|
||||
|
|
@ -1088,11 +1107,10 @@
|
|||
(append-text info (wrap-as (i386:accu+value value)))))
|
||||
|
||||
((add ,a ,b)
|
||||
(let* ((ptr (expr->pointer info a))
|
||||
(ptr-b (expr->pointer info b))
|
||||
(let* ((ptr (expr->rank info a))
|
||||
(ptr-b (expr->rank info b))
|
||||
(type (ast->type info a))
|
||||
(struct? (or (and (pair? type) (equal? (car type) "tag"))
|
||||
(memq (type:type type) '(struct union))))
|
||||
(struct? (structured-type? type))
|
||||
(size (cond ((= ptr 1) (ast-type->size info a))
|
||||
((> ptr 1) 4)
|
||||
((and struct? (= ptr -2)) 4)
|
||||
|
|
@ -1107,10 +1125,9 @@
|
|||
(append-text info (wrap-as (i386:accu+base)))))))
|
||||
|
||||
((sub ,a (p-expr (fixed ,value)))
|
||||
(let* ((ptr (expr->pointer info a))
|
||||
(let* ((ptr (expr->rank info a))
|
||||
(type (ast->type info a))
|
||||
(struct? (or (and (pair? type) (equal? (car type) "tag"))
|
||||
(memq (type:type type) '(struct union))))
|
||||
(struct? (structured-type? type))
|
||||
(size (cond ((= ptr 1) (ast-type->size info a))
|
||||
((> ptr 1) 4)
|
||||
((and struct? (= ptr -2)) 4)
|
||||
|
|
@ -1122,11 +1139,10 @@
|
|||
(append-text info (wrap-as (i386:accu+value (- value))))))
|
||||
|
||||
((sub ,a ,b)
|
||||
(let* ((ptr (expr->pointer info a))
|
||||
(ptr-b (expr->pointer info b))
|
||||
(let* ((ptr (expr->rank info a))
|
||||
(ptr-b (expr->rank info b))
|
||||
(type (ast->type info a))
|
||||
(struct? (or (and (pair? type) (equal? (car type) "tag"))
|
||||
(memq (type:type type) '(struct union))))
|
||||
(struct? (structured-type? type))
|
||||
(size (cond ((= ptr 1) (ast-type->size info a))
|
||||
((> ptr 1) 4)
|
||||
((and struct? (= ptr -2)) 4)
|
||||
|
|
@ -1215,30 +1231,29 @@
|
|||
((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
|
||||
(let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info))
|
||||
(type (ident->type info name))
|
||||
(ptr (ident->pointer info name))
|
||||
(ptr (ident->rank info name))
|
||||
(size (if (> ptr 1) 4 1)))
|
||||
(append-text info ((ident-add info) name size))))
|
||||
|
||||
((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b)
|
||||
(let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info))
|
||||
(type (ident->type info name))
|
||||
(ptr (ident->pointer info name))
|
||||
(ptr (ident->rank info name))
|
||||
(size (if (> ptr 1) 4 1)))
|
||||
(append-text info ((ident-add info) name (- size)))))
|
||||
|
||||
((assn-expr ,a (op ,op) ,b)
|
||||
(let* ((info (append-text info (ast->comment o)))
|
||||
(ptr-a (expr->pointer info a))
|
||||
(ptr-b (expr->pointer info b))
|
||||
(ptr-a (expr->rank info a))
|
||||
(ptr-b (expr->rank info b))
|
||||
(size-a (expr->size info a))
|
||||
(size-b (expr->size info b))
|
||||
(info (expr->accu b info))
|
||||
(info (if (equal? op "=") info
|
||||
(let* ((ptr (expr->pointer info a))
|
||||
(ptr-b (expr->pointer info b))
|
||||
(let* ((ptr (expr->rank info a))
|
||||
(ptr-b (expr->rank info b))
|
||||
(type (ast->type info a))
|
||||
(struct? (or (and (pair? type) (equal? (car type) "tag"))
|
||||
(memq (type:type type) '(struct union))))
|
||||
(struct? (structured-type? type))
|
||||
(size (cond ((= ptr 1) (ast-type->size info a))
|
||||
((> ptr 1) 4)
|
||||
((and struct? (= ptr -2)) 4)
|
||||
|
|
@ -1402,14 +1417,14 @@
|
|||
(info (append-text info (wrap-as `((#:label ,skip-b-label))))))
|
||||
info))
|
||||
|
||||
((array-ref ,index ,expr) (let* ((ptr (expr->pointer info expr))
|
||||
((array-ref ,index ,expr) (let* ((ptr (expr->rank info expr))
|
||||
(size (if (= ptr 1) (ast-type->size info expr)
|
||||
4)))
|
||||
((jump (if (= size 1) i386:jump-byte-z
|
||||
i386:jump-z)
|
||||
(wrap-as (i386:accu-zero?))) o)))
|
||||
|
||||
((de-ref ,expr) (let* ((ptr (expr->pointer info expr))
|
||||
((de-ref ,expr) (let* ((ptr (expr->rank info expr))
|
||||
(size (if (= ptr 1) (ast-type->size info expr)
|
||||
4)))
|
||||
((jump (if (= size 1) i386:jump-byte-z
|
||||
|
|
@ -1486,7 +1501,7 @@
|
|||
(pmatch o
|
||||
((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
|
||||
(comp-declr-list (comp-declr (ident ,name))))
|
||||
(list (list name `("tag" ,type) 4 0)))
|
||||
(list (list name `(tag ,type) 4 0)))
|
||||
((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
|
||||
(list (list name type (ast-type->size info type) 0)))
|
||||
((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
|
||||
|
|
@ -1522,21 +1537,21 @@
|
|||
(list (list name type (* count size) -1))))
|
||||
|
||||
((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
|
||||
(list (list name `("tag" ,type) 4 2)))
|
||||
(list (list name `(tag ,type) 4 2)))
|
||||
|
||||
((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
|
||||
(list (list name `("tag" ,type) 4 1)))
|
||||
(list (list name `(tag ,type) 4 1)))
|
||||
|
||||
((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ident ,name))))
|
||||
(let ((size (ast-type->size info `("tag" ,type))))
|
||||
(list (list name `("tag" ,type) size 0))))
|
||||
(let ((size (ast-type->size info `(tag ,type))))
|
||||
(list (list name `(tag ,type) size 0))))
|
||||
|
||||
((comp-decl (decl-spec-list (type-spec (struct-def (field-list . ,fields)))))
|
||||
(list `(struct ,@(append-map (struct-field info) fields))))
|
||||
|
||||
((comp-decl (decl-spec-list (type-spec (union-ref (ident ,type)))) (comp-declr-list (comp-declr (ident ,name))))
|
||||
(let ((size (ast-type->size info `("tag" ,type))))
|
||||
(list (list name `("tag" ,type) size 0))))
|
||||
(let ((size (ast-type->size info `(tag ,type))))
|
||||
(list (list name `(tag ,type) size 0))))
|
||||
|
||||
((comp-decl (decl-spec-list (type-spec (union-def (field-list . ,fields)))))
|
||||
(list `(union ,@(append-map (struct-field info) fields))))
|
||||
|
|
@ -1552,12 +1567,12 @@
|
|||
(define (local-var? o) ;; formals < 0, locals > 0
|
||||
(positive? (local:id o)))
|
||||
|
||||
(define (ptr-declr->pointer o)
|
||||
(define (ptr-declr->rank o)
|
||||
(pmatch o
|
||||
((pointer) 1)
|
||||
((pointer (pointer)) 2)
|
||||
((pointer (pointer (pointer))) 3)
|
||||
(_ (error "ptr-declr->pointer not supported: " o))))
|
||||
(_ (error "ptr-declr->rank not supported: " o))))
|
||||
|
||||
(define (statements->clauses statements)
|
||||
(let loop ((statements statements) (clauses '()))
|
||||
|
|
@ -1829,14 +1844,14 @@
|
|||
(define (decl->info info o)
|
||||
(pmatch o
|
||||
(((decl-spec-list (type-spec ,type)) (init-declr-list . ,inits))
|
||||
(let* ((info (type->info info type))
|
||||
(let* ((info (type->info type #f info))
|
||||
(type (ast->type info type))
|
||||
(pointer 0)) ; FIXME
|
||||
(fold (cut init-declr->info type pointer <> <>) info (map cdr inits))))
|
||||
(((decl-spec-list (type-spec ,type)))
|
||||
(type->info info type))
|
||||
(type->info type #f info))
|
||||
(((decl-spec-list (stor-spec (typedef)) (type-spec ,type)) (init-declr-list (init-declr (ident ,name))))
|
||||
(let* ((info (type->info info type))
|
||||
(let* ((info (type->info type name info))
|
||||
(type (ast->type info type)))
|
||||
(clone info #:types (acons name type (.types info)))))
|
||||
(((decl-spec-list (stor-spec (,store)) (type-spec ,type)) (init-declr-list . ,inits))
|
||||
|
|
@ -1920,9 +1935,7 @@
|
|||
((initzer-list ,init)
|
||||
(init-local local init n info))
|
||||
((initzer-list . ,inits)
|
||||
(let* ((type ((compose type:type local:type) local))
|
||||
(struct? (or (and (pair? type) (equal? (car type) "tag"))
|
||||
(memq type '(struct union)))))
|
||||
(let ((struct? (pke 'struct? local '=> (structured-type? local))))
|
||||
(cond (struct?
|
||||
(let ((fields ((compose struct->fields local:type) local)))
|
||||
(fold (cut init-struct-field local <> <> <>) info fields (append inits (map (const '(p-expr (fixed "22"))) (iota (max 0 (- (length fields) (length inits)))))))))
|
||||
|
|
@ -1940,10 +1953,7 @@
|
|||
(local (make-local-entry name type pointer array id))
|
||||
(struct? (and (or (zero? pointer)
|
||||
(= -1 pointer))
|
||||
(or (and (pair? type)
|
||||
(equal? (car type) "tag"))
|
||||
(and (type? type)
|
||||
(memq (type:type type) '(struct union))))))
|
||||
(structured-type? type)))
|
||||
(size (or (and (zero? pointer) (type? type) (type:size type))
|
||||
(and struct? (and=> (ast->type info type) struct:size))
|
||||
4))
|
||||
|
|
@ -2008,8 +2018,7 @@
|
|||
(info (if (null? strings) info
|
||||
(clone info #:globals (append (.globals info) strings))))
|
||||
(struct? (and (zero? pointer)
|
||||
(or (and (pair? type) (equal? (car type) "tag"))
|
||||
(memq (type:type type) '(struct union)))))
|
||||
(structured-type? type)))
|
||||
(pointer (if struct? (- (1+ (abs pointer))) pointer)))
|
||||
(if (.function info) (local->info type pointer #f name o init info)
|
||||
(global->info type pointer #f name o init info))))
|
||||
|
|
@ -2118,8 +2127,9 @@
|
|||
(append-map (cut init->strings <> info) init))
|
||||
(_ '()))))
|
||||
|
||||
(define (type->info info o)
|
||||
(define (type->info o name info)
|
||||
(pmatch o
|
||||
|
||||
((enum-def (ident ,name) (enum-def-list . ,fields))
|
||||
(mescc:trace name " <t>")
|
||||
(let* ((type-entry (enum->type-entry name fields))
|
||||
|
|
@ -2127,21 +2137,45 @@
|
|||
(clone info
|
||||
#:types (cons type-entry (.types info))
|
||||
#:constants (append constants (.constants info)))))
|
||||
|
||||
((enum-def (enum-def-list . ,fields))
|
||||
(mescc:trace name " <t>")
|
||||
(let* ((type-entry (enum->type-entry name fields))
|
||||
(constants (enum-def-list->constants (.constants info) fields)))
|
||||
(clone info
|
||||
#:types (cons type-entry (.types info))
|
||||
#:constants (append constants (.constants info)))))
|
||||
|
||||
((struct-def (field-list . ,fields))
|
||||
(mescc:trace name " <t>")
|
||||
(let ((type-entry (struct->type-entry name (append-map (struct-field info) fields))))
|
||||
(clone info #:types (cons type-entry (.types info)))))
|
||||
|
||||
((struct-def (ident ,name) (field-list . ,fields))
|
||||
(mescc:trace name " <t>")
|
||||
(let ((type-entry (struct->type-entry name (append-map (struct-field info) fields))))
|
||||
(clone info #:types (cons type-entry (.types info)))))
|
||||
((struct-ref . _)
|
||||
info)
|
||||
|
||||
((union-def (ident ,name) (field-list . ,fields))
|
||||
(mescc:trace name " <t>")
|
||||
(let ((type-entry (union->type-entry name (append-map (struct-field info) fields))))
|
||||
(clone info #:types (cons type-entry (.types info)))))
|
||||
((union-ref . _)
|
||||
info)
|
||||
(_
|
||||
|
||||
((union-def (field-list . ,fields))
|
||||
(mescc:trace name " <t>")
|
||||
(let ((type-entry (union->type-entry name (append-map (struct-field info) fields))))
|
||||
(clone info #:types (cons type-entry (.types info)))))
|
||||
|
||||
((struct-ref . _) info)
|
||||
((typename ,name) info)
|
||||
((union-ref . _) info)
|
||||
((fixed-type . _) info)
|
||||
((void) info)
|
||||
|
||||
(_ ;;(error "type->info: not supported:" o)
|
||||
(stderr "type->info: not supported: ~s\n" o)
|
||||
info)))
|
||||
info
|
||||
)))
|
||||
|
||||
;;; fctn-defn
|
||||
(define (param-decl:get-name o)
|
||||
|
|
@ -2215,12 +2249,10 @@
|
|||
(define (fctn-defn:get-type info o)
|
||||
(pmatch o
|
||||
(((decl-spec-list (type-spec ,type)) (ptr-declr ,pointer . _) ,statement)
|
||||
(let ((type (ast->type info type))
|
||||
(pointer (ptr-declr->pointer pointer)))
|
||||
(make-type (type:type type)
|
||||
(type:size type)
|
||||
(+ (type:pointer type) pointer)
|
||||
(type:description type))))
|
||||
(let* ((type (ast->type info type))
|
||||
(rank (ptr-declr->rank pointer)))
|
||||
(if (zero? rank) type
|
||||
(make-pointer type rank))))
|
||||
(((decl-spec-list (type-spec ,type)) . ,rest)
|
||||
(ast->type info type))
|
||||
(((decl-spec-list (stor-spec ,store) (type-spec ,type)) (ftn-declr (ident _) _) _)
|
||||
|
|
|
|||
|
|
@ -51,13 +51,32 @@
|
|||
type:pointer
|
||||
type:description
|
||||
|
||||
<c-array>
|
||||
make-c-array
|
||||
c-array?
|
||||
c-array:type
|
||||
c-array:count
|
||||
|
||||
<pointer>
|
||||
make-pointer
|
||||
pointer?
|
||||
pointer:type
|
||||
pointer:rank
|
||||
|
||||
<var>
|
||||
var:name
|
||||
var:type
|
||||
var:pointer
|
||||
var:c-array
|
||||
|
||||
<global>
|
||||
make-global
|
||||
global?
|
||||
global:name
|
||||
global:type
|
||||
global:pointer
|
||||
global:array
|
||||
global:c-array
|
||||
global:var
|
||||
global:value
|
||||
global:function
|
||||
global->string
|
||||
|
|
@ -67,7 +86,8 @@
|
|||
local?
|
||||
local:type
|
||||
local:pointer
|
||||
local:array
|
||||
local:c-array
|
||||
local:var
|
||||
local:id
|
||||
|
||||
<function>
|
||||
|
|
@ -75,7 +95,13 @@
|
|||
function?
|
||||
function:name
|
||||
function:type
|
||||
function:text))
|
||||
function:text
|
||||
|
||||
-><type>
|
||||
->rank
|
||||
rank--
|
||||
rank++
|
||||
structured-type?))
|
||||
|
||||
(cond-expand
|
||||
(guile-2)
|
||||
|
|
@ -102,35 +128,69 @@
|
|||
(define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (statics '()) (function #f) (text '()) (break '()) (continue '()))
|
||||
(make-<info> types constants functions globals locals statics function text break continue))
|
||||
|
||||
;; ("int" . ,(make-type 'builtin 4 #f 0 #f))
|
||||
;; (make-type 'enum 4 0 fields)
|
||||
;; (make-type 'struct (apply + (map field:size fields)) 0 fields)
|
||||
|
||||
(define-immutable-record-type <type>
|
||||
(make-type type size pointer description)
|
||||
(make-type type size description)
|
||||
type?
|
||||
(type type:type)
|
||||
(size type:size)
|
||||
(pointer type:pointer)
|
||||
(description type:description))
|
||||
|
||||
(define-immutable-record-type <c-array>
|
||||
(make-c-array type count)
|
||||
c-array?
|
||||
(type c-array:type)
|
||||
(count c-array:count))
|
||||
|
||||
(define-immutable-record-type <pointer>
|
||||
(make-pointer type rank)
|
||||
pointer?
|
||||
(type pointer:type)
|
||||
(rank pointer:rank))
|
||||
|
||||
(define-immutable-record-type <var>
|
||||
(make-var name type function id value)
|
||||
var?
|
||||
(name var:name)
|
||||
(type var:type) ; <type>
|
||||
(function var:function)
|
||||
(id var:id)
|
||||
(value var:value))
|
||||
|
||||
(define-immutable-record-type <global>
|
||||
(make-global name type pointer array value function)
|
||||
(make-global- name type var pointer c-array value function)
|
||||
global?
|
||||
(name global:name)
|
||||
(type global:type)
|
||||
(var global:var) ; <var>
|
||||
|
||||
(pointer global:pointer)
|
||||
(array global:array)
|
||||
(c-array global:c-array)
|
||||
(value global:value)
|
||||
(function global:function))
|
||||
|
||||
(define (make-global name type pointer c-array value function)
|
||||
(make-global- name type (make-var name type function #f value) pointer c-array value function))
|
||||
|
||||
(define (global->string o)
|
||||
(or (and=> (global:function o) (cut string-append <> "-" (global:name o)))
|
||||
(global:name o)))
|
||||
|
||||
(define-immutable-record-type <local>
|
||||
(make-local type pointer array id)
|
||||
(make-local- type var id pointer c-array)
|
||||
local?
|
||||
(type local:type)
|
||||
(var local:var) ; <var>
|
||||
|
||||
(id local:id)
|
||||
(pointer local:pointer)
|
||||
(array local:array)
|
||||
(id local:id))
|
||||
(c-array local:c-array))
|
||||
|
||||
(define (make-local name type pointer c-array id)
|
||||
(make-local- type (make-var name type #f id #f) id pointer c-array))
|
||||
|
||||
(define-immutable-record-type <function>
|
||||
(make-function name type text)
|
||||
|
|
@ -138,3 +198,43 @@
|
|||
(name function:name)
|
||||
(type function:type)
|
||||
(text function:text))
|
||||
|
||||
(define (structured-type? o)
|
||||
(cond ((type? o) (memq (type:type o) '(struct union)))
|
||||
((global? o) ((compose structured-type? global:type) o))
|
||||
((local? o) ((compose structured-type? local:type) o))
|
||||
((and (pair? o) (eq? (car o) 'tag))) ;; FIXME: enum?
|
||||
(else #f)))
|
||||
|
||||
(define (-><type> o)
|
||||
(cond ((type? o) o)
|
||||
((pointer? o) (pointer:type o))
|
||||
((c-array? o) (c-array:type o))
|
||||
((and (pair? o) (eq? (car o) 'tag)) o)
|
||||
;; FIXME
|
||||
(#t
|
||||
(format (current-error-port) "->type--: not a <type>: ~s\n" o)
|
||||
(make-type 'builtin 4 #f))
|
||||
(else (error "-><type>: not a <type>:" o))))
|
||||
|
||||
(define (->rank o)
|
||||
(cond ((type? o) 0)
|
||||
((pointer? o) (pointer:rank o))
|
||||
((c-array? o) ((compose ->rank c-array:type) o))
|
||||
;; FIXME
|
||||
(#t
|
||||
(format (current-error-port) "->rank--: not a type: ~s\n" o)
|
||||
0)
|
||||
(else (error "->rank: not a <type>:" o))))
|
||||
|
||||
(define (rank-- o)
|
||||
(cond ((and (pointer? o) (zero? (pointer:rank o))) (pointer:type o))
|
||||
((pointer? o) (set-field o (pointer:rank) (1- (pointer:rank o))))
|
||||
;; FIXME
|
||||
(#t (format (current-error-port) "rank--: not a pointer: ~s\n" o)
|
||||
o)
|
||||
(else (error "rank--: not a pointer" o))))
|
||||
|
||||
(define (rank++ o)
|
||||
(cond ((pointer? o) (set-field o (pointer:rank) (1+ (pointer:rank o))))
|
||||
(else (make-pointer o 1))))
|
||||
|
|
|
|||
|
|
@ -86,25 +86,25 @@ main (int argc, char* argv[])
|
|||
return 17;
|
||||
struct foo g = {4, "baar"};
|
||||
if (g.length != 4)
|
||||
return 16;
|
||||
if (strcmp (g.string, "baar"))
|
||||
return 18;
|
||||
if (strcmp (g.string, "baar"))
|
||||
return 19;
|
||||
struct foo f = {3, "foo"};
|
||||
g_foes[0] = f;
|
||||
g_foes[1] = f;
|
||||
if (g_foe)
|
||||
return 19;
|
||||
return 20;
|
||||
char *strings[] = { "one\n", "two\n", "three\n", 0 };
|
||||
char **p = strings;
|
||||
while (*p) puts (*p++);
|
||||
if (strcmp (strings[1], "two\n"))
|
||||
return 20;
|
||||
return 21;
|
||||
p = list;
|
||||
struct anon a = {3,4};
|
||||
eputs ("bar:"); eputs (itoa (a.bar)); eputs ("\n");
|
||||
eputs ("baz:"); eputs (itoa (a.baz)); eputs ("\n");
|
||||
if (a.bar != 3) return 1;
|
||||
if (a.baz != 4) return 2;
|
||||
if (a.bar != 3) return 22;
|
||||
if (a.baz != 4) return 23;
|
||||
|
||||
i = 1;
|
||||
int lst[6] = {-1, 1 - 1, i, 2, 3};
|
||||
|
|
@ -112,7 +112,7 @@ main (int argc, char* argv[])
|
|||
{
|
||||
puts ("i: "); puts (itoa (lst[i])); puts ("\n");
|
||||
if (lst[i+1] != i)
|
||||
return i;
|
||||
return 30 + i;
|
||||
}
|
||||
|
||||
return 0;
|
||||
|
|
|
|||
Loading…
Reference in a new issue