49ce33ab7800eb793e2afb3135368f0afbdbe8ca
[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:function
95             global->string
96
97             <local>
98             make-local
99             local?
100             local:type
101             local:pointer
102             local:c-array
103             local:var
104             local:id
105
106             <function>
107             make-function
108             function?
109             function:name
110             function:type
111             function:text
112             function->string
113
114             ->type
115             ->rank
116             rank--
117             rank++
118             rank+=
119             structured-type?))
120
121 (define-immutable-record-type <info>
122   (make-<info> types constants functions globals locals statics function text post break continue allocated pushed registers instructions)
123   info?
124   (types .types)
125   (constants .constants)
126   (functions .functions)
127   (globals .globals)
128   (locals .locals)
129   (statics .statics)
130   (function .function)
131   (text .text)
132   (post .post)
133   (break .break)
134   (continue .continue)
135   (allocated .allocated)
136   (pushed .pushed)
137   (registers .registers)
138   (instructions .instructions))
139
140 (define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (statics '()) (function #f) (text '()) (post '()) (break '()) (continue '()) (allocated '()) (pushed 0) (registers '()) (instructions '()))
141   (cond ((eq? o <info>)
142          (make-<info> types constants functions globals locals statics function text post break continue allocated  pushed registers instructions))))
143
144 (define (clone o . rest)
145   (cond ((info? o)
146          (let ((types (.types o))
147                (constants (.constants o))
148                (functions (.functions o))
149                (globals (.globals o))
150                (locals (.locals o))
151                (statics (.statics o))
152                (function (.function o))
153                (text (.text o))
154                (post (.post o))
155                (break (.break o))
156                (continue (.continue o))
157                (allocated (.allocated o))
158                (pushed (.pushed o))
159                (registers (.registers o))
160                (instructions (.instructions o)))
161            (let-keywords rest
162                          #f
163                          ((types types)
164                           (constants constants)
165                           (functions functions)
166                           (globals globals)
167                           (locals locals)
168                           (statics statics)
169                           (function function)
170                           (text text)
171                           (post post)
172                           (break break)
173                           (continue continue)
174                           (allocated allocated)
175                           (pushed pushed)
176                           (registers registers)
177                           (instructions instructions))
178                          (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))))))
179
180 ;; ("int" . ,(make-type 'builtin 4 #f 0 #f))
181 ;;           (make-type 'enum 4 0 fields)
182 ;;           (make-type 'struct (apply + (map field:size fields)) 0 fields)
183
184 (define-immutable-record-type <type>
185   (make-type type size description)
186   type?
187   (type type:type)
188   (size type:size)
189   (description type:description))
190
191 (define-immutable-record-type <c-array>
192   (make-c-array type count)
193   c-array?
194   (type c-array:type)
195   (count c-array:count))
196
197 (define-immutable-record-type <pointer>
198   (make-pointer type rank)
199   pointer?
200   (type pointer:type)
201   (rank pointer:rank))
202
203 (define-immutable-record-type <bit-field>
204   (make-bit-field type bit bits)
205   bit-field?
206   (type bit-field:type)
207   (bit bit-field:bit)
208   (bits bit-field:bits))
209
210 (define-immutable-record-type <var>
211   (make-var name type function id value)
212   var?
213   (name var:name)
214   (type var:type)                       ; <type>
215   (function var:function)
216   (id var:id)
217   (value var:value))
218
219 (define-immutable-record-type <global>
220   (make-global- name type var value function)
221   global?
222   (name global:name)
223   (type global:type)
224   (var global:var)                      ; <var>
225
226   (value global:value)
227   (function global:function))
228
229 (define (make-global name type value function)
230   (make-global- name type (make-var name type function #f value) value function))
231
232 (define (global->string o)
233   (or (and=> (global:function o) (cut string-append <> "-" (global:name o)))
234       (global:name o)))
235
236 (define-immutable-record-type <local>
237   (make-local- type var id)
238   local?
239   (type local:type)
240   (var local:var)                       ; <var>
241
242   (id local:id))
243
244 (define (make-local name type id)
245   (make-local- type (make-var name type #f id #f) id))
246
247 (define-immutable-record-type <function>
248   (make-function name type text)
249   function?
250   (name function:name)
251   (type function:type)
252   (text function:text))
253
254 (define (function->string o)
255   (function:name o))
256
257 (define (structured-type? o)
258   (cond ((type? o) (memq (type:type o) '(struct union)))
259         ((global? o) ((compose structured-type? global:type) o))
260         ((local? o) ((compose structured-type? local:type) o))
261         ((and (pair? o) (eq? (car o) 'tag))) ;; FIXME: enum?
262         (else #f)))
263
264 (define (->type o)
265   (cond ((type? o) o)
266         ((bit-field? o) o)
267         ((pointer? o) ((compose ->type pointer:type) o))
268         ((c-array? o) ((compose ->type c-array:type) o))
269         ((and (pair? o) (eq? (car o) 'tag)) o)
270         ;; FIXME
271         (#t
272          (format (current-error-port) "->type--: not a <type>: ~s\n" o)
273          (make-type 'builtin 4 #f))
274         (else (error "->type: not a <type>:" o))))
275
276 (define (->rank o)
277   (cond ((type? o) 0)
278         ((pointer? o) (pointer:rank o))
279         ((c-array? o) (1+ ((compose ->rank c-array:type) o)))
280         ((local? o) ((compose ->rank local:type) o))
281         ((global? o) ((compose ->rank global:type) o))
282         ((bit-field? o) 0)
283         ;; FIXME
284         (#t
285          (format (current-error-port) "->rank: not a type: ~s\n" o)
286          0)
287         (else (error "->rank: not a <type>:" o))))
288
289 (define (rank-- o)
290   (cond ((and (pointer? o) (= (pointer:rank o) 1)) (pointer:type o))
291         ((pointer? o) (set-field o (pointer:rank) (1- (pointer:rank o))))
292         ((c-array? o) (c-array:type o))
293         ;; FIXME
294         (#t (format (current-error-port) "rank--: not a pointer: ~s\n" o)
295               o)
296         (else (error "rank--: not a pointer" o))))
297
298 (define (rank+= o i)
299   (cond ((pointer? o) (set-field o (pointer:rank) (+ i (pointer:rank o))))
300         (else (make-pointer o i))))
301
302 (define (rank++ o)
303   (rank+= o 1))