source: project/chicken/trunk/lolevel.scm @ 16102

Last change on this file since 16102 was 16102, checked in by Kon Lovett, 10 years ago

Added current value api for invalid procedure call hook & unbound variable hook.

File size: 23.4 KB
Line 
1;;;; lolevel.scm - Low-level routines for CHICKEN
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29  (unit lolevel)
30  (uses srfi-69)
31  (usual-integrations)
32  (disable-warning var redef)
33  (hide ipc-hook-0 *set-invalid-procedure-call-handler! xproc-tag
34   ##sys#check-block
35   ##sys#check-become-alist
36   ##sys#check-generic-structure
37   ##sys#check-generic-vector )
38  (not inline ipc-hook-0 ##sys#invalid-procedure-call-hook)
39  (foreign-declare #<<EOF
40#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__)
41# include <sys/types.h>
42#endif
43#ifndef C_NONUNIX
44# include <sys/mman.h>
45#endif
46
47#define C_w2b(x)                   C_fix(C_wordstobytes(C_unfix(x)))
48#define C_pointer_eqp(x, y)        C_mk_bool(C_c_pointer_nn(x) == C_c_pointer_nn(y))
49#define C_memmove_o(to, from, n, toff, foff) C_memmove((char *)(to) + (toff), (char *)(from) + (foff), (n))
50EOF
51) )
52
53(cond-expand
54 [paranoia]
55 [else
56  (declare
57    (no-bound-checks)
58    (no-procedure-checks-for-usual-bindings)
59    (bound-to-procedure
60     ##sys#check-pointer ##sys#check-closure ##sys#check-integer ##sys#check-special
61     ##sys#error ##sys#signal-hook ##sys#error-hook 
62     ##sys#error-not-a-proper-list
63     make-hash-table hash-table-ref/default hash-table-set!
64     ##sys#make-pointer ##sys#make-tagged-pointer ##sys#make-locative ##sys#locative?
65     ##sys#become!
66     ##sys#make-string ##sys#make-vector ##sys#vector->closure!
67     make-property-condition make-composite-condition signal
68     ##sys#generic-structure?
69     ##sys#set-pointer-address! ##sys#address->pointer ##sys#pointer->address
70     ##sys#lambda-decoration ##sys#decorate-lambda
71     extend-procedure ) ) ] )
72
73(include "unsafe-declarations.scm")
74
75(register-feature! 'lolevel)
76
77
78;;; Helpers:
79
80(define-inline (%pointer? x)
81  (and (##core#inline "C_blockp" x) (##core#inline "C_anypointerp" x)) )
82
83(define-inline (%generic-pointer? x)
84  (or (%pointer? x)
85      (##core#inline "C_locativep" x) ) )
86
87(define-inline (%special-block? x)
88  ; generic-pointer, port, closure
89  (and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x)) )
90
91(define-inline (%generic-vector? x)
92  (and (##core#inline "C_blockp" x)
93       (not (or (##core#inline "C_specialp" x)
94                (##core#inline "C_byteblockp" x)))) )
95
96(define-inline (%record-structure? x)
97  (and (##core#inline "C_blockp" x) (##core#inline "C_structurep" x)) )
98
99
100
101;;; Argument checking:
102
103(define (##sys#check-block x . loc)
104  (unless (##core#inline "C_blockp" x)
105    (##sys#error-hook
106     (foreign-value "C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR" int) (and (pair? loc) (car loc))
107     x) ) )
108
109(define (##sys#check-become-alist x loc)
110  (##sys#check-list x loc)
111  (let loop ([lst x])
112    (cond [(null? lst) ]
113          [(pair? lst)
114           (let ([a (car lst)])
115             (##sys#check-pair a loc)
116             (##sys#check-block (car a) loc)
117             (##sys#check-block (cdr a) loc)
118             (loop (cdr lst)) ) ]
119          [else
120           (##sys#signal-hook
121            #:type-error loc
122            "bad argument type - not an a-list of non-immediate objects" x) ] ) ) )
123
124(define (##sys#check-generic-structure x . loc)
125  (unless (%record-structure? x)
126    (##sys#signal-hook
127     #:type-error (and (pair? loc) (car loc))
128     "bad argument type - not a structure" x) ) )
129
130;; Vector, Structure, Pair, and Symbol
131
132(define (##sys#check-generic-vector x . loc)
133  (unless (%generic-vector? x)
134    (##sys#signal-hook
135     #:type-error (and (pair? loc) (car loc))
136     "bad argument type - not a vector-like object" x) ) )
137
138(define (##sys#check-pointer x . loc)
139  (unless (%pointer? x)
140    (##sys#error-hook
141     (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int)
142     (and (pair? loc) (car loc))
143     "bad argument type - not a pointer" x) ) )
144
145(cond-expand
146  [unsafe
147   (define-syntax ##sys#check-pointer
148     (syntax-rules ()
149       ((_ . _) (##core#undefined))))
150   (define-syntax ##sys#check-block
151     (syntax-rules ()
152       ((_ . _) (##core#undefined))))
153   (define-syntax ##sys#check-become-alist
154     (syntax-rules ()
155       ((_ . _) (##core#undefined))))
156   (define-syntax ##sys#check-generic-structure
157     (syntax-rules ()
158       ((_ . _) (##core#undefined))))
159   (define-syntax ##sys#check-generic-vector
160     (syntax-rules ()
161       ((_ . _) (##core#undefined)))) ]
162  [else] )
163
164
165;;; Move arbitrary blocks of memory around:
166
167(define move-memory!
168  (let ([memmove1 (foreign-lambda void "C_memmove_o" c-pointer c-pointer int int int)]
169        [memmove2 (foreign-lambda void "C_memmove_o" c-pointer scheme-pointer int int int)]
170        [memmove3 (foreign-lambda void "C_memmove_o" scheme-pointer c-pointer int int int)]
171        [memmove4 (foreign-lambda void "C_memmove_o" scheme-pointer scheme-pointer int int int)]
172        [typerr (lambda (x)
173                  (##sys#error-hook
174                   (foreign-value "C_BAD_ARGUMENT_TYPE_ERROR" int)
175                   'move-memory! x))]
176        [slot1structs '(mmap
177                        u8vector u16vector u32vector s8vector s16vector s32vector
178                        f32vector f64vector)] )
179    (lambda (from to #!optional n (foffset 0) (toffset 0))
180      ;
181      (define (nosizerr)
182        (##sys#error 'move-memory! "need number of bytes to move" from to))
183      ;
184      (define (sizerr . args)
185        (apply ##sys#error 'move-memory! "number of bytes to move too large" from to args))
186      ;
187      (define (checkn1 n nmax off)
188        (if (cond-expand [unsafe #t] [else (fx<= n (fx- nmax off))])
189            n
190            (sizerr n nmax) ) )
191      ;
192      (define (checkn2 n nmax nmax2 off1 off2)
193        (if (cond-expand [unsafe #t] [else (and (fx<= n (fx- nmax off1)) (fx<= n (fx- nmax2 off2)))])
194            n
195            (sizerr n nmax nmax2) ) )
196      ;
197      (##sys#check-block from 'move-memory!)
198      (##sys#check-block to 'move-memory!)
199      (let move ([from from] [to to])
200        (cond [(##sys#generic-structure? from)
201               (if (memq (##sys#slot from 0) slot1structs)
202                   (move (##sys#slot from 1) to)
203                   (typerr from) ) ]
204              [(##sys#generic-structure? to)
205               (if (memq (##sys#slot to 0) slot1structs)
206                   (move from (##sys#slot to 1))
207                   (typerr to) ) ]
208              [(%generic-pointer? from)
209               (cond [(%generic-pointer? to)
210                      (memmove1 to from (or n (nosizerr)) toffset foffset)]
211                     [(or (##sys#bytevector? to) (string? to))
212                      (memmove3 to from (checkn1 (or n (nosizerr)) (##sys#size to) toffset) toffset foffset) ]
213                     [else
214                      (typerr to)] ) ]
215              [(or (##sys#bytevector? from) (string? from))
216               (let ([nfrom (##sys#size from)])
217                 (cond [(%generic-pointer? to)
218                        (memmove2 to from (checkn1 (or n nfrom) nfrom foffset) toffset foffset)]
219                       [(or (##sys#bytevector? to) (string? to))
220                        (memmove4 to from (checkn2 (or n nfrom) nfrom (##sys#size to) foffset toffset)
221                                  toffset foffset) ]
222                       [else
223                        (typerr to)] ) ) ]
224              [else
225               (typerr from)] ) ) ) ) )
226
227
228;;; Copy arbitrary object:
229
230(define (object-copy x)
231  (let copy ([x x])
232    (cond [(not (##core#inline "C_blockp" x)) x]
233          [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
234          [else
235            (let* ([n (##sys#size x)]
236                   [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)]
237                   [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
238              (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
239                (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
240                    [(fx>= i n)]
241                  (##sys#setslot y i (copy (##sys#slot y i))) ) )
242              y) ] ) ) )
243
244
245;;; Pointer operations:
246
247(define allocate (foreign-lambda c-pointer "C_malloc" int))
248(define free (foreign-lambda void "C_free" c-pointer))
249
250(define (pointer? x) (%pointer? x))
251
252(define (pointer-like? x) (%special-block? x))
253
254(define (address->pointer addr)
255  (##sys#check-integer addr 'address->pointer)
256  (##sys#address->pointer addr) )
257
258(define (pointer->address ptr)
259  (##sys#check-special ptr 'pointer->address)
260  (##sys#pointer->address ptr) )
261
262(define null-pointer ##sys#null-pointer)
263
264(define (null-pointer? ptr)
265  (##sys#check-special ptr 'null-pointer?)
266  (eq? 0 (##sys#pointer->address ptr) ) )
267
268(define (object->pointer x)
269  (and (##core#inline "C_blockp" x)
270       ((foreign-lambda* nonnull-c-pointer ((scheme-object x)) "return((void *)x);") x) ) )
271
272(define (pointer->object ptr)
273  (##sys#check-pointer ptr 'pointer->object)
274  (##core#inline "C_pointer_to_object" ptr) )
275
276(define (pointer=? p1 p2)
277  (##sys#check-special p1 'pointer=?)
278  (##sys#check-special p2 'pointer=?)
279  (##core#inline "C_pointer_eqp" p1 p2) )
280
281(define pointer-offset
282  (foreign-lambda* nonnull-c-pointer ([c-pointer ptr] [integer off])
283    "return((unsigned char *)ptr + off);") )
284
285(define align-to-word
286  (let ([align (foreign-lambda integer "C_align" integer)])
287    (lambda (x)
288      (cond [(integer? x)
289             (align x)]
290            [(%special-block? x)
291             (##sys#address->pointer (align (##sys#pointer->address x))) ]
292            [else
293             (##sys#signal-hook
294              #:type-error 'align-to-word
295              "bad argument type - not a pointer or integer" x)] ) ) ) )
296
297
298;;; Tagged-pointers:
299
300(define (tag-pointer ptr tag)
301  (let ([tp (##sys#make-tagged-pointer tag)])
302    (if (%special-block? ptr)
303        (##core#inline "C_copy_pointer" ptr tp)
304        (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'tag-pointer ptr) )
305    tp) )
306
307(define (tagged-pointer? x #!optional tag)
308  (and (##core#inline "C_blockp" x)  (##core#inline "C_taggedpointerp" x)
309       (or (not tag)
310           (equal? tag (##sys#slot x 1)) ) ) )
311
312(define (pointer-tag x)
313  (if (%special-block? x)
314      (and (##core#inline "C_taggedpointerp" x)
315           (##sys#slot x 1) )
316      (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'pointer-tag x) ) )
317
318
319;;; locatives:
320
321;; Locative layout:
322;
323; 0     Object-address + Byte-offset (address)
324; 1     Byte-offset (fixnum)
325; 2     Type (fixnum)
326;       0       vector or pair          (C_SLOT_LOCATIVE)
327;       1       string                  (C_CHAR_LOCATIVE)
328;       2       u8vector or blob        (C_U8_LOCATIVE)
329;       3       s8vector                (C_S8_LOCATIVE)
330;       4       u16vector               (C_U16_LOCATIVE)
331;       5       s16vector               (C_S16_LOCATIVE)
332;       6       u32vector               (C_U32_LOCATIVE)
333;       7       s32vector               (C_S32_LOCATIVE)
334;       8       f32vector               (C_F32_LOCATIVE)
335;       9       f64vector               (C_F64_LOCATIVE)
336; 3     Object or #f, if weak (C_word)
337
338(define (make-locative obj . index)
339  (##sys#make-locative obj (optional index 0) #f 'make-locative) )
340
341(define (make-weak-locative obj . index)
342  (##sys#make-locative obj (optional index 0) #t 'make-weak-locative) )
343
344(define (locative-set! x y) (##core#inline "C_i_locative_set" x y))
345(define locative-ref (getter-with-setter (##core#primitive "C_locative_ref") locative-set!))
346(define (locative->object x) (##core#inline "C_i_locative_to_object" x))
347(define (locative? x) (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x)))
348
349
350;;; SRFI-4 number-vector:
351
352(define pointer-u8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned char *)p) = n;"))
353(define pointer-s8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((char *)p) = n;"))
354(define pointer-u16-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned short *)p) = n;"))
355(define pointer-s16-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((short *)p) = n;"))
356(define pointer-u32-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((C_u32 *)p) = n;"))
357(define pointer-s32-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((C_s32 *)p) = n;"))
358(define pointer-f32-set! (foreign-lambda* void ([c-pointer p] [double n]) "*((float *)p) = n;"))
359(define pointer-f64-set! (foreign-lambda* void ([c-pointer p] [float n]) "*((double *)p) = n;"))
360
361(define pointer-u8-ref
362  (getter-with-setter
363   (foreign-lambda* int ([c-pointer p]) "return(*((unsigned char *)p));")
364   pointer-u8-set!) )
365
366(define pointer-s8-ref
367  (getter-with-setter
368   (foreign-lambda* int ([c-pointer p]) "return(*((signed char *)p));")
369   pointer-s8-set!) )
370
371(define pointer-u16-ref
372  (getter-with-setter
373   (foreign-lambda* int ([c-pointer p]) "return(*((unsigned short *)p));")
374   pointer-u16-set!) )
375
376(define pointer-s16-ref
377  (getter-with-setter
378   (foreign-lambda* int ([c-pointer p]) "return(*((short *)p));")
379   pointer-s6-set!) )
380
381(define pointer-u32-ref
382  (getter-with-setter
383   (foreign-lambda* integer ([c-pointer p]) "return(*((C_u32 *)p));")
384   pointer-u32-set!) )
385
386(define pointer-s32-ref
387  (getter-with-setter
388   (foreign-lambda* integer ([c-pointer p]) "return(*((C_s32 *)p));")
389   pointer-s32-set!) )
390
391(define pointer-f32-ref
392  (getter-with-setter
393   (foreign-lambda* float ([c-pointer p]) "return(*((float *)p));")
394   pointer-f32-set!) )
395
396(define pointer-f64-ref
397  (getter-with-setter
398   (foreign-lambda* double ([c-pointer p]) "return(*((double *)p));")
399   pointer-f64-set!) )
400
401
402;;; Procedures extended with data:
403
404; Unique id for extended-procedures
405(define xproc-tag (vector 'extended))
406
407(define (extend-procedure proc data)
408  (##sys#check-closure proc 'extend-procedure)
409  (##sys#decorate-lambda
410   proc
411   (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0)))) 
412   (lambda (x i) (##sys#setslot x i (cons xproc-tag data)) x) ) )
413
414(define-inline (%procedure-data proc)
415  (##sys#lambda-decoration proc (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0))))) )
416
417(define (extended-procedure? x)
418  (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
419       (%procedure-data x)
420       #t) )
421
422(define (procedure-data x)
423  (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
424       (and-let* ([d (%procedure-data x)])
425         (##sys#slot d 1) ) ) )
426
427(define set-procedure-data!
428  (let ((extend-procedure extend-procedure))
429    (lambda (proc x)
430      (let ((p2 (extend-procedure proc x)))
431        (if (eq? p2 proc)
432            proc
433            (##sys#signal-hook
434             #:type-error 'set-procedure-data!
435             "bad argument type - not an extended procedure" proc) ) ) ) ) )
436
437
438;;; Accessors for arbitrary vector-like block objects:
439
440(define block-set! ##sys#block-set!)
441(define block-ref (getter-with-setter ##sys#block-ref ##sys#block-set!))
442
443(define (vector-like? x)
444  (%generic-vector? x) )
445
446(define (number-of-slots x)
447  (##sys#check-generic-vector x 'number-of-slots)
448  (##sys#size x) )
449
450(define (number-of-bytes x)
451  (cond [(not (##core#inline "C_blockp" x))
452         (##sys#signal-hook
453          #:type-error 'number-of-bytes
454          "cannot compute number of bytes of immediate object" x) ]
455        [(##core#inline "C_byteblockp" x)
456         (##sys#size x)]
457        [else
458         (##core#inline "C_w2b" (##sys#size x))] ) )
459
460
461;;; Record objects:
462
463;; Record layout:
464;
465; 0     Tag (symbol)
466; 1..N  Slot (object)
467
468(define (make-record-instance type . args)
469  (##sys#check-symbol type 'make-record-instance)
470  (apply ##sys#make-structure type args) )
471
472(define (record-instance? x #!optional type)
473  (and (%record-structure? x)
474       (or (not type)
475           (eq? type (##sys#slot x 0)))) )
476
477(define (record-instance-type x)
478  (##sys#check-generic-structure x 'record-instance-type)
479  (##sys#slot x 0) )
480
481(define (record-instance-length x)
482  (##sys#check-generic-structure x 'record-instance-length)
483  (fx- (##sys#size x) 1) )
484
485(define (record-instance-slot-set! x i y)
486  (##sys#check-generic-structure x 'record-instance-slot-set!)
487  (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot-set!)
488  (##sys#setslot x (fx+ i 1) y) )
489
490(define record-instance-slot
491  (getter-with-setter
492   (lambda (x i)
493     (##sys#check-generic-structure x 'record-instance-slot)
494     (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot)
495     (##sys#slot x (fx+ i 1)) )
496   record-instance-slot-set!))
497
498(define (record->vector x)
499  (##sys#check-generic-structure x 'record->vector)
500  (let* ([n (##sys#size x)]
501         [v (##sys#make-vector n)] )
502    (do ([i 0 (fx+ i 1)])
503         [(fx>= i n) v]
504      (##sys#setslot v i (##sys#slot x i)) ) ) )
505
506
507
508;;; Evict objects into static memory:
509
510(define-constant evict-table-size 301)
511
512(define (object-evicted? x) (##core#inline "C_permanentp" x))
513
514(define (object-evict x . allocator)
515  (let ([allocator 
516         (if (pair? allocator) (car allocator) (foreign-lambda c-pointer "C_malloc" int) ) ] 
517        [tab (make-hash-table eq?)] )
518    (##sys#check-closure allocator 'object-evict)
519    (let evict ([x x])
520      (cond [(not (##core#inline "C_blockp" x)) x ]
521            [(hash-table-ref/default tab x #f) ]
522            [else
523             (let* ([n (##sys#size x)]
524                    [bytes (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))]
525                    [y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))] )
526               (when (symbol? x) (##sys#setislot y 0 (void)))
527               (hash-table-set! tab x y)
528               (unless (##core#inline "C_byteblockp" x)
529                 (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
530                     [(fx>= i n)]
531                   ;; Note the use of `##sys#setislot' to avoid an entry in the mutations-table:
532                   (##sys#setislot y i (evict (##sys#slot x i))) ) )
533               y ) ] ) ) ) )
534
535(define (object-evict-to-location x ptr . limit)
536  (cond-expand [(not unsafe) (##sys#check-special ptr 'object-evict-to-location)] [else])
537  (let* ([limit (and (pair? limit)
538                     (let ([limit (car limit)])
539                       (##sys#check-exact limit 'object-evict-to-location)
540                       limit)) ]
541         [ptr2 (##sys#address->pointer (##sys#pointer->address ptr))]
542         [tab (make-hash-table eq?)]
543         [x2
544          (let evict ([x x])
545            (cond [(not (##core#inline "C_blockp" x)) x ]
546                  [(hash-table-ref/default tab x #f) ]
547                  [else
548                   (let* ([n (##sys#size x)]
549                          [bytes 
550                           (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
551                                (##core#inline "C_bytes" 1) ) ] )
552                     (when limit
553                       (set! limit (fx- limit bytes))
554                       (when (fx< limit 0) 
555                         (signal
556                          (make-composite-condition
557                           (make-property-condition
558                            'exn 'location 'object-evict-to-location
559                            'message "cannot evict object - limit exceeded" 
560                            'arguments (list x limit))
561                           (make-property-condition 'evict 'limit limit) ) ) ) )
562                   (let ([y (##core#inline "C_evict_block" x ptr2)])
563                     (when (symbol? x) (##sys#setislot y 0 (void)))
564                     (##sys#set-pointer-address! ptr2 (+ (##sys#pointer->address ptr2) bytes))
565                     (hash-table-set! tab x y)
566                     (unless (##core#inline "C_byteblockp" x)
567                       (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)] )
568                           [(fx>= i n)]
569                         (##sys#setislot y i (evict (##sys#slot x i))) ) ) ; see above
570                     y) ) ] ) ) ] )
571    (values x2 ptr2) ) )
572
573(define (object-release x . releaser)
574  (let ([free (if (pair? releaser) 
575                  (car releaser) 
576                  (foreign-lambda void "C_free" c-pointer) ) ]
577        [released '() ] )
578    (let release ([x x])
579      (cond [(not (##core#inline "C_blockp" x)) x ]
580            [(not (##core#inline "C_permanentp" x)) x ]
581            [(memq x released) x ]
582            [else
583             (let ([n (##sys#size x)])
584               (set! released (cons x released))
585               (unless (##core#inline "C_byteblockp" x)
586                 (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
587                     [(fx>= i n)]
588                   (release (##sys#slot x i))) )
589               (free (##sys#address->pointer (##core#inline_allocate ("C_block_address" 4) x))) ) ] ) ) ) )
590
591(define (object-size x)
592  (let ([tab (make-hash-table eq?)])
593    (let evict ([x x])
594      (cond [(not (##core#inline "C_blockp" x)) 0 ]
595            [(hash-table-ref/default tab x #f) 0 ]
596            [else
597             (let* ([n (##sys#size x)]
598                    [bytes
599                     (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
600                          (##core#inline "C_bytes" 1) ) ] )
601               (hash-table-set! tab x #t)
602               (unless (##core#inline "C_byteblockp" x)
603                 (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
604                     [(fx>= i n)]
605                   (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
606               bytes) ] ) ) ) )
607
608(define (object-unevict x #!optional full)
609  (let ([tab (make-hash-table eq?)])
610    (let copy ([x x])
611    (cond [(not (##core#inline "C_blockp" x)) x ]
612          [(not (##core#inline "C_permanentp" x)) x ]
613          [(hash-table-ref/default tab x #f) ]
614          [(##core#inline "C_byteblockp" x) 
615           (if full
616               (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
617                 (hash-table-set! tab x y)
618                 y) 
619               x) ]
620          [(symbol? x) 
621           (let ([y (##sys#intern-symbol (##sys#slot x 1))])
622             (hash-table-set! tab x y)
623             y) ]
624          [else
625           (let* ([words (##sys#size x)]
626                  [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
627             (hash-table-set! tab x y)
628             (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
629                 ((fx>= i words))
630               (##sys#setslot y i (copy (##sys#slot y i))) )
631             y) ] ) ) ) )
632
633
634;;; `become':
635
636(define (object-become! alst)
637  (cond-expand [(not unsafe) (##sys#check-become-alist alst 'object-become!)] [else])
638  (##sys#become! alst) )
639
640(define (mutate-procedure old proc)
641  (##sys#check-closure old 'mutate-procedure)
642  (##sys#check-closure proc 'mutate-procedure)
643  (let* ([n (##sys#size old)]
644         [words (##core#inline "C_words" n)]
645         [new (##core#inline "C_copy_block" old (##sys#make-vector words))] )
646    (##sys#become! (list (cons old (proc new))))
647    new ) )
648
649
650;;; Hooks:
651
652; we need this because `##sys#invalid-procedure-call-hook' cannot
653; have free variables.
654(define ipc-hook-0 #f)
655
656(define (invalid-procedure-call-handler) ipc-hook-0)
657
658(define (set-invalid-procedure-call-handler! proc)
659  (##sys#check-closure proc 'set-invalid-procedure-call-handler!)
660  (set! ipc-hook-0 proc)
661  (set! ##sys#invalid-procedure-call-hook
662        (lambda args (ipc-hook-0 ##sys#last-invalid-procedure args))) )
663
664(define (unbound-variable-signals-error?) (not ##sys#unbound-variable-value-hook))
665
666; result only trusted when (unbound-variable-signals-error?) is #f
667(define (unbound-variable-given-value)
668  (and ##sys#unbound-variable-value-hook
669       (vector-ref ##sys#unbound-variable-value-hook 0)) )
670
671(define (set-unbound-variable-value! val) (set! ##sys#unbound-variable-value-hook (vector val)))
672
673(define (clear-unbound-variable-value!) (set! ##sys#unbound-variable-value-hook #f))
674
675; this should be the current value procedure
676(define (unbound-variable-value . val)
677  (set! ##sys#unbound-variable-value-hook 
678    (and (pair? val)
679         (vector (car val)))) )
680
681
682;;; Access computed globals:
683
684(define (global-ref sym)
685  (##sys#check-symbol sym 'global-ref)
686  (##core#inline "C_retrieve" sym) )
687
688(define (global-set! sym x)
689  (##sys#check-symbol sym 'global-set!)
690  (##sys#setslot sym 0 x) )
691
692(define (global-bound? sym)
693  (##sys#check-symbol sym 'global-bound?)
694  (##sys#symbol-has-toplevel-binding? sym) )
695
696(define (global-make-unbound! sym)
697  (##sys#check-symbol sym 'global-make-unbound!)
698  (##sys#setslot sym 0 (##sys#slot '##sys#arbitrary-unbound-symbol 0))
699  sym )
Note: See TracBrowser for help on using the repository browser.