File: theme-d-builtin-type-finalization.scm

package info (click to toggle)
theme-d 1.4.0-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 12,784 kB
  • sloc: lisp: 47,684; sh: 4,200; makefile: 455; ansic: 319
file content (65 lines) | stat: -rw-r--r-- 2,743 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
;; Copyright (C) 2008-2013 Tommi Höynälänmaa
;; Distributed under GNU General Public License version 3,
;; see file doc/GPL-3.



;; *** Finalization of builtin types ***


(import (rnrs exceptions)
	(srfi srfi-1)
	(th-scheme-utilities stdutils)
	(th-scheme-utilities hrecord))


(define tt-type-list (make-tt-uniform-list tt-type))
(define tt-tvar-list
  (make-tt-uniform-list tc-type-variable))
(define tt-gen-type (make-union-expression0
		     (list tt-type tc-type-variable)))
(define tt-gen-type-list
  (make-tt-uniform-list tt-gen-type))
(define tt-module-name (make-union-expression0
			(list
			 (make-tt-uniform-list tc-symbol)
			 tc-symbol)))
(define tt-signature-member
  (make-tpci-pair tc-object tt-type))
(define tt-signature-member-list
  (make-tt-uniform-list tt-signature-member))
(define tt-field-list (make-tt-uniform-list tc-field))
(define tt-maybe-type (make-union-expression0
		       (list tt-type tc-nil)))
(define tt-maybe-procedure (make-union-expression0
			    (list tc-procedure tc-nil)))
(define tt-maybe-symbol (make-union-expression0
			 (list tc-symbol tc-nil)))


(set-field-desc-type! tc-class-fields 'l-fields tt-field-list)
(set-field-desc-type! tc-class-fields 'l-all-fields tt-field-list)
(set-field-desc-type! tc-class-fields 'type-constructor tt-maybe-type)
(set-field-desc-type! tc-class-fields 'proc-constructor tt-maybe-procedure)
(set-field-desc-type! tc-class-fields 'module tt-module-name)
(set-field-desc-type! t-param-class-fields 'l-tvars tt-tvar-list)
(set-field-desc-type! t-param-class-fields 'l-instance-fields tt-field-list)
(set-field-desc-type! t-param-class-fields 'l-instance-all-fields tt-field-list)
(set-field-desc-type! t-param-class-fields 'proc-instance-zero
		      tt-maybe-procedure)
(set-field-desc-type! t-param-logical-type-fields 'l-tvars tt-tvar-list)
(set-field-desc-type! t-param-logical-type-fields 'x-value-expr tt-gen-type)
(set-field-desc-type! tpc-param-proc-fields 'l-tvars tt-tvar-list)
(set-field-desc-type! tpc-param-proc-fields 'type-contents tt-gen-type)
(set-field-desc-type! t-param-proc-fields 's-name tt-maybe-symbol)
(set-field-desc-type! param-class-inst-fields 'l-tvar-values tt-gen-type-list)
(set-field-desc-type! param-logical-type-inst-fields 'l-tvar-values
		      tt-gen-type-list)
(set-field-desc-type! union-fields 'l-member-types tt-gen-type-list)
(set-field-desc-type! tmt-procedure-class-fields 'type-arglist tt-gen-type)
(set-field-desc-type! tmt-procedure-class-fields 'type-result tt-gen-type)
(set-field-desc-type! tpc-simple-proc-class-fields 'type-arglist tt-gen-type)
(set-field-desc-type! tpc-simple-proc-class-fields 'type-result tt-gen-type)
(set-field-desc-type! tc-signature-fields 'l-members tt-signature-member-list)