File: theme-d-translation-common.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 (147 lines) | stat: -rw-r--r-- 3,730 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
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
;; Copyright (C) 2008-2013 Tommi Höynälänmaa
;; Distributed under GNU General Public License version 3,
;; see file doc/GPL-3.



;; *** Translation procedures for both the compiler and the linker ***


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


;; Representation of fields in Theme-D source code.
(define i-field-name 0)
(define i-field-type 1)
(define i-field-read-access 2)
(define i-field-write-access 3)
(define i-source-field-init-value 4)


;; Make a union from expression types
;; rejecting those expressions which never return.
(define (get-union-type-from-expressions binder exprs)
  (let* ((proper-exprs (filter
			(lambda (expr) (not (entity-never-returns? expr)))
			exprs))
	 (types (map get-entity-type proper-exprs)))
    (get-union-of-types0 binder types)))


(define (translate-actual-arglist-type arglist)
  (let* ((arg-types (map
		     (lambda (arg) (get-entity-type arg))
		     arglist)))
    (if (not-null? arg-types)
      (apply make-tuple-type arg-types)
      ;; Formerly we had tt-none here.
      tc-nil)))


(define (get-arglist-type-from-list arg-types)
  (if (not-null? arg-types)
      (apply make-tuple-type arg-types)
      ;; Formerly we had tt-none here.
      tc-nil))


(define (check-arglist-types? binder tt-actual tt-declared)
  (assert (is-binder? binder))
  (let ((decl-none? (entity-is-none1? binder tt-declared)))
    (cond
     (decl-none?
      (entity-is-none1? binder tt-actual))
     ;; The following case should not occur
     ;; since the type of an empty argument list is <nil>.
     ((entity-is-none1? binder tt-actual)
      ;; Formerly we had:
      ;;    (is-t-subtype? binder tc-nil tt-declared))
      decl-none?)
     (else 
      (is-t-subtype? binder tt-actual tt-declared)))))


(define (contains-duplicate-field-names? p-superclass p-new-fields)
  (assert (is-target-object? p-superclass))
  (assert (list? p-new-fields))
  (let* ((existing-fields (tno-field-ref p-superclass 'l-all-fields))
	 (get-name (lambda (field) (tno-field-ref field 's-name)))
	 (existing-field-names (map get-name existing-fields))
	 (new-field-names (map get-name p-new-fields)))
    (or-map? (lambda (field-name)
	       (if (memv field-name existing-field-names) #t #f))
	     new-field-names)))


(set! contains-duplicate-field-names-fwd?
      contains-duplicate-field-names?)


(define (translate-quoted-expression expr)
  (let* ((type (get-primitive-type expr))
	 (to (make-primitive-object type expr)))
    to))


(define (make-new-gen-proc address exported?)
  (let* ((to-clas (make-gen-proc-class-object '()))
	 (name (hfield-ref address 'source-name))
	 (str-name (symbol->string name))
	 (to (make-gen-proc-object to-clas str-name '() address))
	 (var (make-normal-variable
	       address
	       to-clas
	       #t
	       #f
	       #f
	       to
	       exported?)))
    var))


(define (get-method-declaration-repr genproc method-obj static?)
  (assert (is-t-gen-proc? genproc))
  (assert (is-target-object? method-obj))
  (make-hrecord
   <method-declaration>
   tt-none #t #t '()
   #f #f #f '()
   genproc
   method-obj
   static?
   #f))


(define (get-method-definition-repr genproc procexpr static? declared?
				    old-address)
  (assert (is-target-object? genproc))
  (assert (is-entity? procexpr))
  (assert (boolean? declared?))
  (assert (or (null? old-address) (is-address? old-address)))
  (make-hrecord
   <method-definition>
   tt-none
   #t
   #t
   '()
   #f
   #f
   #f
   '()
   genproc
   procexpr
   static?
   declared?
   old-address
   #f))


(define (make-debug-output-expr x-message)
  (make-hrecord <debug-output-expr>
		tt-none #t #t '()
		#f #f #f '()
		#f #f
		x-message))