1;;; back.ss
2;;; Copyright 1984-2017 Cisco Systems, Inc.
3;;;
4;;; Licensed under the Apache License, Version 2.0 (the "License");
5;;; you may not use this file except in compliance with the License.
6;;; You may obtain a copy of the License at
7;;;
8;;; http://www.apache.org/licenses/LICENSE-2.0
9;;;
10;;; Unless required by applicable law or agreed to in writing, software
11;;; distributed under the License is distributed on an "AS IS" BASIS,
12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13;;; See the License for the specific language governing permissions and
14;;; limitations under the License.
15
16(begin
17(define-who trace-output-port
18   ($make-thread-parameter
19      (console-output-port)
20      (lambda (x)
21         (unless (and (output-port? x) (textual-port? x))
22            ($oops who "~s is not a textual output port" x))
23         x)))
24
25(define-who trace-print
26  ($make-thread-parameter
27    pretty-print
28    (lambda (x)
29      (unless (procedure? x)
30        ($oops who "~s is not a procedure" x))
31      x)))
32
33(define suppress-greeting (make-parameter #f (lambda (x) (and x #t))))
34
35(define-who eval-syntax-expanders-when
36   ($make-thread-parameter '(compile load eval)
37      (lambda (x)
38         (unless (let check ([x x] [l '(compile load eval visit revisit)])
39                    (or (null? x)
40                        (and (pair? x)
41                             (memq (car x) l)
42                             (check (cdr x) (remq (car x) l)))))
43            ($oops who "invalid eval-when list ~s" x))
44         x)))
45
46(define-who collect-maximum-generation
47  (let ([$get-maximum-generation (foreign-procedure "(cs)maxgen" () int)]
48        [$set-maximum-generation! (foreign-procedure "(cs)set_maxgen" (int) void)])
49    (case-lambda
50      [() ($get-maximum-generation)]
51      [(g)
52       (unless (and (fixnum? g) (fx>= g 0)) ($oops who "invalid generation ~s" g))
53       (when (fx= g 0) ($oops who "new maximum generation must be at least 1"))
54       (let ([limit (fx- (constant static-generation) 1)])
55         (when (fx> g limit) ($oops who "~s exceeds maximum supported value ~s" g limit)))
56       ($set-maximum-generation! g)])))
57
58(define-who release-minimum-generation
59  (let ([$get-release-minimum-generation (foreign-procedure "(cs)minfreegen" () int)]
60        [$set-release-minimum-generation! (foreign-procedure "(cs)set_minfreegen" (int) void)])
61    (case-lambda
62      [() ($get-release-minimum-generation)]
63      [(g)
64       (unless (and (fixnum? g) (fx>= g 0)) ($oops who "invalid generation ~s" g))
65       (unless (fx<= g (collect-maximum-generation))
66         ($oops who "new release minimum generation must not be be greater than collect-maximum-generation"))
67       ($set-release-minimum-generation! g)])))
68
69(define-who in-place-minimum-generation
70  (let ([$get-mark-minimum-generation (foreign-procedure "(cs)minmarkgen" () int)]
71        [$set-mark-minimum-generation! (foreign-procedure "(cs)set_minmarkgen" (int) void)])
72    (case-lambda
73      [() ($get-mark-minimum-generation)]
74      [(g)
75       (unless (and (fixnum? g) (fx>= g 0)) ($oops who "invalid generation ~s" g))
76       (let ([limit (fx- (constant static-generation) 1)])
77         (when (fx> g limit) ($oops who "~s exceeds maximum supported value ~s" g limit)))
78       ($set-mark-minimum-generation! g)])))
79
80(define-who enable-object-counts
81  (let ([$get-enable-object-counts (foreign-procedure "(cs)enable_object_counts" () boolean)]
82        [$set-enable-object-counts (foreign-procedure "(cs)set_enable_object_counts" (boolean) void)])
83    (case-lambda
84      [() ($get-enable-object-counts)]
85      [(b) ($set-enable-object-counts b)])))
86
87(define-who enable-object-backreferences
88  (let ([$get-enable-object-backreferences (foreign-procedure "(cs)enable_object_backreferences" () boolean)]
89        [$set-enable-object-backreferences (foreign-procedure "(cs)set_enable_object_backreferences" (boolean) void)])
90    (case-lambda
91      [() ($get-enable-object-backreferences)]
92      [(b) ($set-enable-object-backreferences b)])))
93
94(define-who collect-trip-bytes
95   (make-parameter
96      (constant default-collect-trip-bytes)
97      (lambda (x)
98         (unless (and (fixnum? x) (fx< 0 x))
99            ($oops who "~s is not a positive fixnum" x))
100            ($set-collect-trip-bytes x)
101            x)))
102
103(define-who heap-reserve-ratio
104  (case-lambda
105    [() $heap-reserve-ratio]
106    [(x) (unless (number? x)
107           ($oops who "~s is not a number" x))
108         (let ([y (inexact x)])
109           (unless (and (flonum? y) (>= y 0))
110             ($oops who "invalid heap reserve ratio ~s" x))
111           (set! $heap-reserve-ratio y))]))
112
113(define-who $assembly-output
114  ($make-thread-parameter #f
115    (lambda (x)
116      (cond
117        [(or (not x) (and (output-port? x) (textual-port? x))) x]
118        [(eq? x #t) (current-output-port)]
119        [else ($oops who "~s is not a textual output port or #f" x)]))))
120
121(define-who expand-output
122  ($make-thread-parameter #f
123    (lambda (x)
124      (unless (or (not x) (and (output-port? x) (textual-port? x)))
125        ($oops who "~s is not a textual output port or #f" x))
126      x)))
127
128(define-who expand/optimize-output
129  ($make-thread-parameter #f
130    (lambda (x)
131      (unless (or (not x) (and (output-port? x) (textual-port? x)))
132        ($oops who "~s is not a textual output port or #f" x))
133      x)))
134
135(define generate-wpo-files
136  ($make-thread-parameter #f
137    (lambda (x)
138      (and x #t))))
139
140(define-who generate-covin-files
141  ($make-thread-parameter #f
142    (lambda (x)
143      (and x #t))))
144
145(define $enable-check-prelex-flags
146  ($make-thread-parameter #f
147    (lambda (x)
148      (and x #t))))
149
150(define-who run-cp0
151  ($make-thread-parameter
152    (default-run-cp0)
153    (lambda (x)
154      (unless (procedure? x)
155        ($oops who "~s is not a procedure" x))
156      x)))
157
158(define fasl-compressed
159  ($make-thread-parameter #t (lambda (x) (and x #t))))
160
161(define compile-file-message
162  ($make-thread-parameter #t (lambda (x) (and x #t))))
163
164(define compile-imported-libraries
165  ($make-thread-parameter #f (lambda (x) (and x #t))))
166
167(define-who compile-library-handler
168  ($make-thread-parameter
169    (lambda (ifn ofn) (compile-library ifn ofn))
170    (lambda (x)
171      (unless (procedure? x) ($oops who "~s is not a procedure" x))
172      x)))
173
174(define-who compile-program-handler
175  ($make-thread-parameter
176    (lambda (ifn ofn) (compile-program ifn ofn))
177    (lambda (x)
178      (unless (procedure? x) ($oops who "~s is not a procedure" x))
179      x)))
180
181(define-who compress-format
182  (case-lambda
183    [()
184     (let ([x ($tc-field 'compress-format ($tc))])
185       (cond
186         [(eqv? x (constant COMPRESS-GZIP)) 'gzip]
187         [(eqv? x (constant COMPRESS-LZ4)) 'lz4]
188         [else ($oops who "unexpected $compress-format value ~s" x)]))]
189    [(x)
190     ($tc-field 'compress-format ($tc)
191       (case x
192         [(gzip) (constant COMPRESS-GZIP)]
193         [(lz4) (constant COMPRESS-LZ4)]
194         [else ($oops who "~s is not a supported format" x)]))]))
195
196(define-who compress-level
197  (case-lambda
198    [()
199     (let ([x ($tc-field 'compress-level ($tc))])
200       (cond
201         [(eqv? x (constant COMPRESS-MIN)) 'minimum]
202         [(eqv? x (constant COMPRESS-LOW)) 'low]
203         [(eqv? x (constant COMPRESS-MEDIUM)) 'medium]
204         [(eqv? x (constant COMPRESS-HIGH)) 'high]
205         [(eqv? x (constant COMPRESS-MAX)) 'maximum]
206         [else ($oops who "unexpected $compress-level value ~s" x)]))]
207    [(x)
208     ($tc-field 'compress-level ($tc)
209       (case x
210         [(minimum) (constant COMPRESS-MIN)]
211         [(low) (constant COMPRESS-LOW)]
212         [(medium) (constant COMPRESS-MEDIUM)]
213         [(high) (constant COMPRESS-HIGH)]
214         [(maximum) (constant COMPRESS-MAX)]
215         [else ($oops who "~s is not a supported level" x)]))]))
216
217(define-who compile-omit-concatenate-support
218  ($make-thread-parameter #f (lambda (x) (and x #t))))
219
220(define-who debug-level
221  ($make-thread-parameter
222    1
223    (lambda (x)
224      (unless (and (fixnum? x) (<= 0 x 3))
225        ($oops who "invalid level ~s" x))
226      x)))
227
228(define internal-defines-as-letrec*
229  ($make-thread-parameter #t (lambda (x) (and x #t))))
230
231(set! $scheme-version (string->symbol ($format-scheme-version (constant scheme-version))))
232)
233