File: theme-d-cycles.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 (166 lines) | stat: -rw-r--r-- 5,389 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
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
;; Copyright (C) 2015 Tommi Höynälänmaa
;; Distributed under GNU General Public License version 3,
;; see file doc/GPL-3.


;; *** Handling cyclic objects ***


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


(define gl-flag2? #f)
(define gl-ctr12 0)


(define cycle-fields
  (list
   (make-field 'address tc-object 'public 'hidden #f '())
   (make-field 'object tc-object 'public 'hidden #f '())))


(define tc-cycle
  (make-builtin-target-class '<cycle>
			     tc-object cycle-fields #f #t #f 'public))


(define is-t-cycle? (make-t-predicate0 tc-cycle))


(define (make-cycle address obj)
  (assert (or (null? address) (is-address? address)))
  (assert (is-type0? obj))
  (make-target-object
   tc-cycle
   #f
   #f
   '()
   #f
   #f
   (list (cons 'address address)
	 (cons 'object obj))
   '()))


(define (detect-cycles binder expr ht-cycles lst-visited)
  (assert (is-binder? binder))
  (assert (hash-table? ht-cycles))
  (assert (list? lst-visited))
  
  ;; (if gl-flag16?
  ;;     (begin
  ;; 	(dwi "det ")
  ;; 	(dwc gl-counter12)
  ;; 	(dwc " ")
  ;; 	(dwc gl-indent)
  ;; 	(dwc " ")
  ;; 	(if (hrecord? expr)
  ;; 	    (dwc (hrecord-type-name-of expr))
  ;; 	    (dwc "?"))
  ;; 	(if (is-target-object? expr)
  ;; 	    (begin
  ;; 	      (dwc " ")
  ;; 	      (dwc (target-object-as-string expr))))
  ;; 	(dwc " ")
  ;; 	(dwc (hashq expr 10000000))
  ;; 	(dwli-newline)))
	
  (let ((old-indent gl-indent))
    (set! gl-indent (+ gl-indent 1))
    (let ((cycle (hashq-ref ht-cycles expr)))
      (cond
       ((not (eqv? cycle #f)) '())
       ((null? expr) '())
       ((eqv? expr tc-class) '())
       ((memq expr lst-visited)
	(let* ((alloc-var (hfield-ref binder 'allocate-variable))
	       (address (alloc-var 'cycle-1 #f))
	       (obj (make-incomplete-object-with-address address tc-object #f))
	       (cycle (make-cycle address obj)))
	  (dwli2 "cycle HEP")
	  (hashq-set! ht-cycles expr cycle)))
       ((pair? expr)
       	(let ((lst-new-visited (cons expr lst-visited)))
       	  (detect-cycles binder (car expr) ht-cycles lst-new-visited)
       	  (detect-cycles binder (cdr expr) ht-cycles lst-new-visited)))
       ((is-tc-pair? expr)
       	(let ((lst-new-visited (cons expr lst-visited)))
       	  (detect-cycles binder (get-pair-first-type expr) ht-cycles
       			 lst-new-visited)
       	  (detect-cycles binder (get-pair-second-type expr) ht-cycles
       			 lst-new-visited)))
       ((and
	 (not (is-t-primitive-object? expr))
	 (is-known-object? expr)
       	 (is-tc-pair? (get-entity-type expr)))
       	(let ((lst-new-visited (cons expr lst-visited)))
       	  (detect-cycles binder (tno-field-ref expr 'first) ht-cycles
       			 lst-new-visited)
       	  (detect-cycles binder (tno-field-ref expr 'second) ht-cycles
       			 lst-new-visited)))
       ((is-normal-variable? expr) '())
       ((hrecord-is-instance? expr <proc-appl>)
	(let* ((lst-new-visited (cons expr lst-visited))
	       (det (lambda (expr1) (detect-cycles binder expr1 ht-cycles
						   lst-new-visited))))
	  (det (hfield-ref expr 'type))
	  (det (hfield-ref expr 'proc))
	  (for-each det (hfield-ref expr 'arglist))
	  (for-each det (hfield-ref expr 'params))
	  (for-each det (hfield-ref expr 'static-arg-types))))
       ((is-t-param-class-instance? expr)
       	(let* ((lst-new-visited (cons expr lst-visited))
       	       (det (lambda (expr1) (detect-cycles binder expr1 ht-cycles
       						   lst-new-visited))))
       	  (det (tno-field-ref expr 'cl-superclass))
       	  (for-each det
       	  	    (map (lambda (fld) (tno-field-ref fld 'type))
       	  		 (tno-field-ref expr 'l-all-fields)))
       	  (for-each det
		    (tno-field-ref expr 'l-tvar-values))))
       ;; Subclasses of <variable-definition> are not handled here.
       ((hrecord-type=? (hrecord-type-of expr) <variable-definition>)
       	(let ((lst-new-visited (cons expr lst-visited)))
	  (detect-cycles binder (get-entity-type expr) ht-cycles
			 lst-new-visited)
	  (detect-cycles binder (hfield-ref expr 'type-decl) ht-cycles
			 lst-new-visited)
	  (detect-cycles binder (hfield-ref expr 'value-expr) ht-cycles
			 lst-new-visited)))
       ((hrecord-is-instance? expr <procedure-expression>)
	(let* ((lst-new-visited (cons expr lst-visited))
	       (det (lambda (expr1) (detect-cycles binder expr1 ht-cycles
       						   lst-new-visited)))
	       (lst-arg-types (map get-entity-type
				   (hfield-ref expr 'arg-variables))))
	  (det (hfield-ref expr 'type))
	  (for-each det (hfield-ref expr 'arg-descs))
	  (for-each det lst-arg-types)
	  (det (hfield-ref expr 'result-type))
	  (det (hfield-ref expr 'body))))
       (else
	(let* ((lst-subexprs (get-subexpressions expr))
	       (lst-new-visited (cons expr lst-visited)))
	  (detect-cycles binder (hfield-ref expr 'type) ht-cycles
			 lst-new-visited)
	  (for-each (lambda (expr1) (detect-cycles binder expr1 ht-cycles
						   lst-new-visited))
		    lst-subexprs))))
      (set! gl-indent old-indent))))


(define (make-cycle-object obj)
  (assert (is-target-object? obj))
  (make-incomplete-object (get-expr-type obj) #f))


(define (update-cycle-object! sgt element)
  (assert (is-target-object? sgt))
  (assert (is-target-object? element))
  (set-object1! sgt element)
  (hfield-set! sgt 'address
	       (hfield-ref element 'address)))