mescc: Tinycc support: Support bit-fields.
[mes.git] / module / language / c99 / info.scm
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of Mes.
7 ;;;
8 ;;; Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
12 ;;;
13 ;;; Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; info.scm defines [Guile] record data types for compiler.mes
22
23 ;;; Code:
24
25 (define-module (language c99 info)
26   #:use-module (ice-9 optargs)
27   #:use-module (srfi srfi-9)
28   #:use-module (srfi srfi-9 gnu)
29   #:use-module (srfi srfi-26)
30   #:export (<info>
31             make
32             make-<info>
33             info?
34
35             .types
36             .constants
37             .functions
38             .globals
39             .locals
40             .function
41             .statics
42             .text
43             .post
44             .break
45             .continue
46
47             <type>
48             make-type
49             type?
50             type:type
51             type:size
52             type:pointer
53             type:description
54
55             <c-array>
56             make-c-array
57             c-array?
58             c-array:type
59             c-array:count
60
61             <pointer>
62             make-pointer
63             pointer?
64             pointer:type
65             pointer:rank
66
67             <bit-field>
68             make-bit-field
69             bit-field?
70             bit-field:type
71             bit-field:bit
72             bit-field:bits
73
74             <var>
75             var:name
76             var:type
77             var:pointer
78             var:c-array
79
80             <global>
81             make-global
82             global?
83             global:name
84             global:type
85             global:pointer
86             global:c-array
87             global:var
88             global:value
89             global:function
90             global->string
91
92             <local>
93             make-local
94             local?
95             local:type
96             local:pointer
97             local:c-array
98             local:var
99             local:id
100
101             <function>
102             make-function
103             function?
104             function:name
105             function:type
106             function:text
107             function->string
108
109             ->type
110             ->rank
111             rank--
112             rank++
113             rank+=
114             structured-type?))
115
116 (cond-expand
117  (guile-2)
118  (guile
119   (use-modules (ice-9 syncase))
120   (use-modules (ice-9 optargs)))
121  (mes
122   (mes-use-module (mes optargs))))
123
124 (define-immutable-record-type <info>
125   (make-<info> types constants functions globals locals statics function text post break continue)
126   info?
127   (types .types)
128   (constants .constants)
129   (functions .functions)
130   (globals .globals)
131   (locals .locals)
132   (statics .statics)
133   (function .function)
134   (text .text)
135   (post .post)
136   (break .break)
137   (continue .continue))
138
139 (define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (statics '()) (function #f) (text '()) (post '()) (break '()) (continue '()))
140   (make-<info> types constants functions globals locals statics function text post break continue))
141
142 ;; ("int" . ,(make-type 'builtin 4 #f 0 #f))
143 ;;           (make-type 'enum 4 0 fields)
144 ;;           (make-type 'struct (apply + (map field:size fields)) 0 fields)
145
146 (define-immutable-record-type <type>
147   (make-type type size description)
148   type?
149   (type type:type)
150   (size type:size)
151   (description type:description))
152
153 (define-immutable-record-type <c-array>
154   (make-c-array type count)
155   c-array?
156   (type c-array:type)
157   (count c-array:count))
158
159 (define-immutable-record-type <pointer>
160   (make-pointer type rank)
161   pointer?
162   (type pointer:type)
163   (rank pointer:rank))
164
165 (define-immutable-record-type <bit-field>
166   (make-bit-field type bit bits)
167   bit-field?
168   (type bit-field:type)
169   (bit bit-field:bit)
170   (bits bit-field:bits))
171
172 (define-immutable-record-type <var>
173   (make-var name type function id value)
174   var?
175   (name var:name)
176   (type var:type)                       ; <type>
177   (function var:function)
178   (id var:id)
179   (value var:value))
180
181 (define-immutable-record-type <global>
182   (make-global- name type var value function)
183   global?
184   (name global:name)
185   (type global:type)
186   (var global:var)                      ; <var>
187
188   (value global:value)
189   (function global:function))
190
191 (define (make-global name type value function)
192   (make-global- name type (make-var name type function #f value) value function))
193
194 (define (global->string o)
195   (or (and=> (global:function o) (cut string-append <> "-" (global:name o)))
196       (global:name o)))
197
198 (define-immutable-record-type <local>
199   (make-local- type var id)
200   local?
201   (type local:type)
202   (var local:var)                       ; <var>
203
204   (id local:id))
205
206 (define (make-local name type id)
207   (make-local- type (make-var name type #f id #f) id))
208
209 (define-immutable-record-type <function>
210   (make-function name type text)
211   function?
212   (name function:name)
213   (type function:type)
214   (text function:text))
215
216 (define (function->string o)
217   (function:name o))
218
219 (define (structured-type? o)
220   (cond ((type? o) (memq (type:type o) '(struct union)))
221         ((global? o) ((compose structured-type? global:type) o))
222         ((local? o) ((compose structured-type? local:type) o))
223         ((and (pair? o) (eq? (car o) 'tag))) ;; FIXME: enum?
224         (else #f)))
225
226 (define (->type o)
227   (cond ((type? o) o)
228         ((bit-field? o) o)
229         ((pointer? o) (pointer:type o))
230         ((c-array? o) (c-array:type o))
231         ((and (pair? o) (eq? (car o) 'tag)) o)
232         ;; FIXME
233         (#t
234          (format (current-error-port) "->type--: not a <type>: ~s\n" o)
235          (make-type 'builtin 4 #f))
236         (else (error "->type: not a <type>:" o))))
237
238 (define (->rank o)
239   (cond ((type? o) 0)
240         ((pointer? o) (pointer:rank o))
241         ((c-array? o) (1+ ((compose ->rank c-array:type) o)))
242         ((local? o) ((compose ->rank local:type) o))
243         ((global? o) ((compose ->rank global:type) o))
244         ((bit-field? o) 0)
245         ;; FIXME
246         (#t
247          (format (current-error-port) "->rank: not a type: ~s\n" o)
248          0)
249         (else (error "->rank: not a <type>:" o))))
250
251 (define (rank-- o)
252   (cond ((and (pointer? o) (= (pointer:rank o) 1)) (pointer:type o))
253         ((pointer? o) (set-field o (pointer:rank) (1- (pointer:rank o))))
254         ((c-array? o) (c-array:type o))
255         ;; FIXME
256         (#t (format (current-error-port) "rank--: not a pointer: ~s\n" o)
257               o)
258         (else (error "rank--: not a pointer" o))))
259
260 (define (rank+= o i)
261   (cond ((pointer? o) (set-field o (pointer:rank) (+ i (pointer:rank o))))
262         (else (make-pointer o i))))
263
264 (define (rank++ o)
265   (rank+= o 1))