000b364e72c8f57b96e00a439c873dfbd4b9ff13
[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             <var>
68             var:name
69             var:type
70             var:pointer
71             var:c-array
72
73             <global>
74             make-global
75             global?
76             global:name
77             global:type
78             global:pointer
79             global:c-array
80             global:var
81             global:value
82             global:function
83             global->string
84
85             <local>
86             make-local
87             local?
88             local:type
89             local:pointer
90             local:c-array
91             local:var
92             local:id
93
94             <function>
95             make-function
96             function?
97             function:name
98             function:type
99             function:text
100             function->string
101
102             ->type
103             ->rank
104             rank--
105             rank++
106             rank+=
107             structured-type?))
108
109 (cond-expand
110  (guile-2)
111  (guile
112   (use-modules (ice-9 syncase))
113   (use-modules (ice-9 optargs)))
114  (mes
115   (mes-use-module (mes optargs))))
116
117 (define-immutable-record-type <info>
118   (make-<info> types constants functions globals locals statics function text post break continue)
119   info?
120   (types .types)
121   (constants .constants)
122   (functions .functions)
123   (globals .globals)
124   (locals .locals)
125   (statics .statics)
126   (function .function)
127   (text .text)
128   (post .post)
129   (break .break)
130   (continue .continue))
131
132 (define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (statics '()) (function #f) (text '()) (post '()) (break '()) (continue '()))
133   (make-<info> types constants functions globals locals statics function text post break continue))
134
135 ;; ("int" . ,(make-type 'builtin 4 #f 0 #f))
136 ;;           (make-type 'enum 4 0 fields)
137 ;;           (make-type 'struct (apply + (map field:size fields)) 0 fields)
138
139 (define-immutable-record-type <type>
140   (make-type type size description)
141   type?
142   (type type:type)
143   (size type:size)
144   (description type:description))
145
146 (define-immutable-record-type <c-array>
147   (make-c-array type count)
148   c-array?
149   (type c-array:type)
150   (count c-array:count))
151
152 (define-immutable-record-type <pointer>
153   (make-pointer type rank)
154   pointer?
155   (type pointer:type)
156   (rank pointer:rank))
157
158 (define-immutable-record-type <var>
159   (make-var name type function id value)
160   var?
161   (name var:name)
162   (type var:type)                       ; <type>
163   (function var:function)
164   (id var:id)
165   (value var:value))
166
167 (define-immutable-record-type <global>
168   (make-global- name type var value function)
169   global?
170   (name global:name)
171   (type global:type)
172   (var global:var)                      ; <var>
173
174   (value global:value)
175   (function global:function))
176
177 (define (make-global name type value function)
178   (make-global- name type (make-var name type function #f value) value function))
179
180 (define (global->string o)
181   (or (and=> (global:function o) (cut string-append <> "-" (global:name o)))
182       (global:name o)))
183
184 (define-immutable-record-type <local>
185   (make-local- type var id)
186   local?
187   (type local:type)
188   (var local:var)                       ; <var>
189
190   (id local:id))
191
192 (define (make-local name type id)
193   (make-local- type (make-var name type #f id #f) id))
194
195 (define-immutable-record-type <function>
196   (make-function name type text)
197   function?
198   (name function:name)
199   (type function:type)
200   (text function:text))
201
202 (define (function->string o)
203   (function:name o))
204
205 (define (structured-type? o)
206   (cond ((type? o) (memq (type:type o) '(struct union)))
207         ((global? o) ((compose structured-type? global:type) o))
208         ((local? o) ((compose structured-type? local:type) o))
209         ((and (pair? o) (eq? (car o) 'tag))) ;; FIXME: enum?
210         (else #f)))
211
212 (define (->type o)
213   (cond ((type? o) o)
214         ((pointer? o) (pointer:type o))
215         ((c-array? o) (c-array:type o))
216         ((and (pair? o) (eq? (car o) 'tag)) o)
217         ;; FIXME
218         (#t
219          (format (current-error-port) "->type--: not a <type>: ~s\n" o)
220          (make-type 'builtin 4 #f))
221         (else (error "->type: not a <type>:" o))))
222
223 (define (->rank o)
224   (cond ((type? o) 0)
225         ((pointer? o) (pointer:rank o))
226         ((c-array? o) (1+ ((compose ->rank c-array:type) o)))
227         ((local? o) ((compose ->rank local:type) o))
228         ((global? o) ((compose ->rank global:type) o))
229         ;; FIXME
230         (#t
231          (format (current-error-port) "->rank: not a type: ~s\n" o)
232          0)
233         (else (error "->rank: not a <type>:" o))))
234
235 (define (rank-- o)
236   (cond ((and (pointer? o) (= (pointer:rank o) 1)) (pointer:type o))
237         ((pointer? o) (set-field o (pointer:rank) (1- (pointer:rank o))))
238         ((c-array? o) (c-array:type o))
239         ;; FIXME
240         (#t (format (current-error-port) "rank--: not a pointer: ~s\n" o)
241               o)
242         (else (error "rank--: not a pointer" o))))
243
244 (define (rank+= o i)
245   (cond ((pointer? o) (set-field o (pointer:rank) (+ i (pointer:rank o))))
246         (else (make-pointer o i))))
247
248 (define (rank++ o)
249   (rank+= o 1))