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