source: project/chicken/branches/chicken-3/lolevel.scm @ 13147

Last change on this file since 13147 was 13147, checked in by Kon Lovett, 11 years ago

lolevel.scm : check-pointer not in library.scm yet
chicken.h : grouped like, note that swig pointer is now special
chicken-primitive-object-inlines.scm : wrong unbound value C predicate name
Unit lolevel : rmvd empty line

File size: 27.9 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  (usual-integrations)
31  (disable-warning var redef)
32  (hide ipc-hook-0 xproc-tag
33   ##sys#check-block
34   ##sys#check-become-alist
35   ##sys#check-generic-structure
36   ##sys#check-generic-vector )
37  (foreign-declare #<<EOF
38#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__)
39# include <sys/types.h>
40#endif
41#ifndef C_NONUNIX
42# include <sys/mman.h>
43#endif
44
45#define C_w2b(x)                   C_fix(C_wordstobytes(C_unfix(x)))
46#define C_pointer_eqp(x, y)        C_mk_bool(C_c_pointer_nn(x) == C_c_pointer_nn(y))
47#define C_memmove_o(to, from, n, toff, foff) C_memmove((char *)(to) + (toff), (char *)(from) + (foff), (n))
48EOF
49) )
50
51(cond-expand
52 [paranoia]
53 [else
54  (declare
55    (no-bound-checks)
56    (no-procedure-checks-for-usual-bindings)
57    (bound-to-procedure
58     ##sys#check-pointer ##sys#check-closure ##sys#check-integer ##sys#check-special
59     ##sys#error ##sys#signal-hook 
60     ##sys#error-not-a-proper-list
61     ##sys#hash-table-ref ##sys#hash-table-set!
62     ##sys#make-pointer ##sys#make-tagged-pointer ##sys#make-locative ##sys#locative?
63     ##sys#become!
64     ##sys#make-string ##sys#make-vector ##sys#vector->closure!
65     make-property-condition make-composite-condition signal
66     ##sys#generic-structure?
67     ##sys#set-pointer-address! ##sys#address->pointer ##sys#pointer->address
68     ##sys#lambda-decoration ##sys#decorate-lambda
69     extend-procedure ) ) ] )
70
71(register-feature! 'lolevel)
72
73
74;;; Helpers:
75
76(define-inline (%pointer? x)
77  (and (##core#inline "C_blockp" x) (##core#inline "C_anypointerp" x)) )
78
79(define-inline (%generic-pointer? x)
80  (or (%pointer? x)
81      (##core#inline "C_locativep" x) ) )
82
83(define-inline (%special-block? x)
84  ; generic-pointer, port, closure
85  (and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x)) )
86
87(define-inline (%generic-vector? x)
88  (and (##core#inline "C_blockp" x)
89       (not (or (##core#inline "C_specialp" x)
90                (##core#inline "C_byteblockp" x)))) )
91
92(define-inline (%record-structure? x)
93  (and (##core#inline "C_blockp" x) (##core#inline "C_structurep" x)) )
94
95
96;;; Argument checking:
97
98(define (##sys#check-block x . loc)
99  (unless (##core#inline "C_blockp" x)
100    (##sys#error-hook
101     (foreign-value "C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR" int) (and (pair? loc) (car loc))
102     x) ) )
103
104(define (##sys#check-become-alist x loc)
105  (##sys#check-list x loc)
106  (let loop ([lst x])
107    (cond [(null? lst) ]
108          [(pair? lst)
109           (let ([a (car lst)])
110             (##sys#check-pair a loc)
111             (##sys#check-block (car a) loc)
112             (##sys#check-block (cdr a) loc)
113             (loop (cdr lst)) ) ]
114          [else
115           (##sys#signal-hook
116            #:type-error loc
117            "bad argument type - not an a-list of non-immediate objects" x) ] ) ) )
118
119(define (##sys#check-generic-structure x . loc)
120  (unless (%record-structure? x)
121    (##sys#signal-hook
122     #:type-error (and (pair? loc) (car loc))
123     "bad argument type - not a structure" x) ) )
124
125;; Vector, Structure, Pair, and Symbol
126
127(define (##sys#check-generic-vector x . loc)
128  (unless (%generic-vector? x)
129    (##sys#signal-hook
130     #:type-error (and (pair? loc) (car loc))
131     "bad argument type - not a vector-like object" x) ) )
132
133(define (##sys#check-pointer x . loc)
134  (unless (%pointer? x)
135    (##sys#error-hook
136     (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int)
137     (and (pair? loc) (car loc))
138     "bad argument type - not a pointer" x) ) )
139
140(cond-expand
141 [unsafe
142  (eval-when (compile)
143    (define-macro (##sys#check-block . _) '(##core#undefined))
144    (define-macro (##sys#check-become-alist . _) '(##core#undefined))
145    (define-macro (##sys#check-generic-structure . _) '(##core#undefined))
146    (define-macro (##sys#check-generic-vector . _) '(##core#undefined))
147    (define-macro (##sys#check-structure . _) '(##core#undefined))
148    (define-macro (##sys#check-blob . _) '(##core#undefined))
149    (define-macro (##sys#check-byte-vector . _) '(##core#undefined))
150    (define-macro (##sys#check-pair . _) '(##core#undefined))
151    (define-macro (##sys#check-list . _) '(##core#undefined))
152    (define-macro (##sys#check-string . _) '(##core#undefined))
153    (define-macro (##sys#check-number . _) '(##core#undefined))
154    (define-macro (##sys#check-integer . _) '(##core#undefined))
155    (define-macro (##sys#check-exact . _) '(##core#undefined))
156    (define-macro (##sys#check-inexact . _) '(##core#undefined))
157    (define-macro (##sys#check-symbol . _) '(##core#undefined))
158    (define-macro (##sys#check-vector . _) '(##core#undefined))
159    (define-macro (##sys#check-char . _) '(##core#undefined))
160    (define-macro (##sys#check-closure . _) '(##core#undefined))
161    (define-macro (##sys#check-port . _) '(##core#undefined))
162    (define-macro (##sys#check-pointer . _) '(##core#undefined))
163    (define-macro (##sys#check-special . _) '(##core#undefined))
164    (define-macro (##sys#check-range . _) '(##core#undefined))
165    (define-macro (##sys#check-port-open . _) '(##core#undefined))
166    (define-macro (##sys#check-port-mode . _) '(##core#undefined))
167    (define-macro (##sys#check-port/open . _) '(##core#undefined))
168    (define-macro (##sys#check-port/open-in-mode . _) '(##core#undefined)) ) ]
169 [else
170  (declare (emit-exports "lolevel.exports"))] )
171
172
173;;; Move arbitrary blocks of memory around:
174
175(define move-memory!
176  (let ([memmove1 (foreign-lambda void "C_memmove_o" c-pointer c-pointer int int int)]
177        [memmove2 (foreign-lambda void "C_memmove_o" c-pointer scheme-pointer int int int)]
178        [memmove3 (foreign-lambda void "C_memmove_o" scheme-pointer c-pointer int int int)]
179        [memmove4 (foreign-lambda void "C_memmove_o" scheme-pointer scheme-pointer int int int)]
180        [typerr (lambda (x)
181                  (##sys#error-hook
182                   (foreign-value "C_BAD_ARGUMENT_TYPE_ERROR" int)
183                   'move-memory! x))]
184        [slot1structs '(mmap
185                        u8vector u16vector u32vector s8vector s16vector s32vector
186                        f32vector f64vector)] )
187    (lambda (from to #!optional n (foffset 0) (toffset 0))
188      ;
189      (define (nosizerr)
190        (##sys#error 'move-memory! "need number of bytes to move" from to))
191      ;
192      (define (sizerr . args)
193        (apply ##sys#error 'move-memory! "number of bytes to move too large" from to args)
194      ;
195      (define (checkn1 n nmax off)
196        (if (cond-expand [unsafe #t] [else (fx<= n (fx- nmax off))])
197            n
198            (sizerr n nmax) ) )
199      ;
200      (define (checkn2 n nmax nmax2 off1 off2)
201        (if (cond-expand [unsafe #t] [else (and (fx<= n (fx- nmax off1)) (fx<= n (fx- nmax2 off2)))])
202            n
203            (sizerr n nmax nmax2) ) )
204      ;
205      (##sys#check-block from 'move-memory!)
206      (##sys#check-block to 'move-memory!)
207      (let move ([from from] [to to])
208        (cond [(##sys#generic-structure? from)
209               (if (memq (##sys#slot from 0) slot1structs)
210                   (move (##sys#slot from 1) to)
211                   (typerr from) ) ]
212              [(##sys#generic-structure? to)
213               (if (memq (##sys#slot to 0) slot1structs)
214                   (move from (##sys#slot to 1))
215                   (typerr to) ) ]
216              [(%generic-pointer? from)
217               (cond [(%generic-pointer? to)
218                      (memmove1 to from (or n (nosizerr)) toffset foffset)]
219                     [(or (##sys#bytevector? to) (string? to))
220                      (memmove3 to from (checkn1 (or n (nosizerr)) (##sys#size to) toffset) toffset foffset) ]
221                     [else
222                      (typerr to)] ) ]
223              [(or (##sys#bytevector? from) (string? from))
224               (let ([nfrom (##sys#size from)])
225                 (cond [(%generic-pointer? to)
226                        (memmove2 to from (checkn1 (or n nfrom) nfrom foffset) toffset foffset)]
227                       [(or (##sys#bytevector? to) (string? to))
228                        (memmove4 to from (checkn2 (or n nfrom) nfrom (##sys#size to) foffset toffset)
229                                  toffset foffset) ]
230                       [else
231                        (typerr to)] ) ) ]
232              [else
233               (typerr from)] ) ) ) ) ) )
234
235
236;;; Copy arbitrary object:
237
238(define (object-copy x)
239  (let copy ([x x])
240    (cond [(not (##core#inline "C_blockp" x)) x]
241          [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
242          [else
243            (let* ([n (##sys#size x)]
244                   [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)]
245                   [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
246              (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
247                (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
248                    [(fx>= i n)]
249                  (##sys#setslot y i (copy (##sys#slot y i))) ) )
250              y) ] ) ) )
251
252
253;;; Pointer operations:
254
255(define allocate (foreign-lambda c-pointer "C_malloc" int))
256(define free (foreign-lambda void "C_free" c-pointer))
257
258(define (pointer? x) (%pointer? x))
259
260(define (pointer-like? x) (%special-block? x))
261
262(define (address->pointer addr)
263  (##sys#check-integer addr 'address->pointer)
264  (##sys#address->pointer addr) )
265
266(define (pointer->address ptr)
267  (##sys#check-special ptr 'pointer->address)
268  (##sys#pointer->address ptr) )
269
270(define null-pointer ##sys#null-pointer)
271
272(define (null-pointer? ptr)
273  (##sys#check-special ptr 'null-pointer?)
274  (eq? 0 (##sys#pointer->address ptr) ) )
275
276(define (object->pointer x)
277  (and (##core#inline "C_blockp" x)
278       ((foreign-lambda* nonnull-c-pointer ((scheme-object x)) "return((void *)x);") x) ) )
279
280(define (pointer->object ptr)
281  (##sys#check-pointer ptr 'pointer->object)
282  (##core#inline "C_pointer_to_object" ptr) )
283
284(define (pointer=? p1 p2)
285  (##sys#check-special p1 'pointer=?)
286  (##sys#check-special p2 'pointer=?)
287  (##core#inline "C_pointer_eqp" p1 p2) )
288
289(define pointer-offset
290  (foreign-lambda* nonnull-c-pointer ([c-pointer ptr] [integer off])
291    "return((unsigned char *)ptr + off);") )
292
293(define align-to-word
294  (let ([align (foreign-lambda integer "C_align" integer)])
295    (lambda (x)
296      (cond [(integer? x)
297             (align x)]
298            [(%special-block? x)
299             (##sys#address->pointer (align (##sys#pointer->address x))) ]
300            [else
301             (##sys#signal-hook
302              #:type-error 'align-to-word
303              "bad argument type - not a pointer or integer" x)] ) ) ) )
304
305(define pointer-u8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned char *)p) = n;"))
306(define pointer-s8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((char *)p) = n;"))
307(define pointer-u16-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned short *)p) = n;"))
308(define pointer-s16-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((short *)p) = n;"))
309(define pointer-u32-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((C_u32 *)p) = n;"))
310(define pointer-s32-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((C_s32 *)p) = n;"))
311(define pointer-f32-set! (foreign-lambda* void ([c-pointer p] [double n]) "*((float *)p) = n;"))
312(define pointer-f64-set! (foreign-lambda* void ([c-pointer p] [float n]) "*((double *)p) = n;"))
313
314(define pointer-u8-ref
315  (getter-with-setter
316   (foreign-lambda* int ([c-pointer p]) "return(*((unsigned char *)p));")
317   pointer-u8-set!) )
318
319(define pointer-s8-ref
320  (getter-with-setter
321   (foreign-lambda* int ([c-pointer p]) "return(*((char *)p));")
322   pointer-s8-set!) )
323
324(define pointer-u16-ref
325  (getter-with-setter
326   (foreign-lambda* int ([c-pointer p]) "return(*((unsigned short *)p));")
327   pointer-u16-set!) )
328
329(define pointer-s16-ref
330  (getter-with-setter
331   (foreign-lambda* int ([c-pointer p]) "return(*((short *)p));")
332   pointer-s6-set!) )
333
334(define pointer-u32-ref
335  (getter-with-setter
336   (foreign-lambda* integer ([c-pointer p]) "return(*((C_u32 *)p));")
337   pointer-u32-set!) )
338
339(define pointer-s32-ref
340  (getter-with-setter
341   (foreign-lambda* integer ([c-pointer p]) "return(*((C_s32 *)p));")
342   pointer-s32-set!) )
343
344(define pointer-f32-ref
345  (getter-with-setter
346   (foreign-lambda* float ([c-pointer p]) "return(*((float *)p));")
347   pointer-f32-set!) )
348
349(define pointer-f64-ref
350  (getter-with-setter
351   (foreign-lambda* double ([c-pointer p]) "return(*((double *)p));")
352   pointer-f64-set!) )
353
354
355;;; Tagged-pointers:
356
357(define (tag-pointer ptr tag)
358  (let ([tp (##sys#make-tagged-pointer tag)])
359    (if (%special-block? ptr)
360        (##core#inline "C_copy_pointer" ptr tp)
361        (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'tag-pointer ptr) )
362    tp) )
363
364(define (tagged-pointer? x #!optional tag)
365  (and (##core#inline "C_blockp" x)  (##core#inline "C_taggedpointerp" x)
366       (or (not tag)
367           (equal? tag (##sys#slot x 1)) ) ) )
368
369(define (pointer-tag x)
370  (if (%special-block? x)
371      (and (##core#inline "C_taggedpointerp" x)
372           (##sys#slot x 1) )
373      (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'pointer-tag x) ) )
374
375
376;;; locatives:
377
378;; Locative layout:
379;
380; 0     Object-address + Byte-offset (address)
381; 1     Byte-offset (fixnum)
382; 2     Type (fixnum)
383;       0       vector or pair          (C_SLOT_LOCATIVE)
384;       1       string                  (C_CHAR_LOCATIVE)
385;       2       u8vector                (C_U8_LOCATIVE)
386;       3       s8vector or blob        (C_U8_LOCATIVE)
387;       4       u16vector               (C_U16_LOCATIVE)
388;       5       s16vector               (C_S16_LOCATIVE)
389;       6       u32vector               (C_U32_LOCATIVE)
390;       7       s32vector               (C_S32_LOCATIVE)
391;       8       f32vector               (C_F32_LOCATIVE)
392;       9       f64vector               (C_F64_LOCATIVE)
393; 3     Object or #f, if weak (C_word)
394
395(define (make-locative obj . index)
396  (##sys#make-locative obj (optional index 0) #f 'make-locative) )
397
398(define (make-weak-locative obj . index)
399  (##sys#make-locative obj (optional index 0) #t 'make-weak-locative) )
400
401(define (locative-set! x y) (##core#inline "C_i_locative_set" x y))
402(define locative-ref (getter-with-setter (##core#primitive "C_locative_ref") locative-set!))
403(define (locative->object x) (##core#inline "C_i_locative_to_object" x))
404(define (locative? x) (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x)))
405
406
407;;; Procedures extended with data:
408
409; Unique id for extended-procedures
410(define xproc-tag (vector 'extended))
411
412(define (extend-procedure proc data)
413  (##sys#check-closure proc 'extend-procedure)
414  (##sys#decorate-lambda
415   proc
416   (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0)))) 
417   (lambda (x i) (##sys#setslot x i (cons xproc-tag data)) x) ) )
418
419(define-inline (%procedure-data proc)
420  (##sys#lambda-decoration proc (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0))))) )
421
422(define (extended-procedure? x)
423  (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
424       (%procedure-data x)
425       #t) )
426
427(define (procedure-data x)
428  (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
429       (and-let* ([d (%procedure-data x)])
430         (##sys#slot d 1) ) ) )
431
432(define set-procedure-data!
433  (let ((extend-procedure extend-procedure))
434    (lambda (proc x)
435      (let ((p2 (extend-procedure proc x)))
436        (if (eq? p2 proc)
437            proc
438            (##sys#signal-hook
439             #:type-error 'set-procedure-data!
440             "bad argument type - not an extended procedure" proc) ) ) ) ) )
441
442
443;;; Bytevector stuff:
444
445(define byte-vector? blob?)             ; DEPRECATED
446
447(define (byte-vector-fill! bv n)        ; DEPRECATED
448  (##sys#check-byte-vector bv 'byte-vector-fill!)
449  (##sys#check-exact n 'byte-vector-fill!)
450  (let ([len (##sys#size bv)])
451    (do ([i 0 (fx+ i 1)])
452        ((fx>= i len))
453      (##sys#setbyte bv i n) ) ) )
454
455(define make-byte-vector                ; DEPRECATED
456    (lambda (size . init)
457      (let ([bv (make-blob size)])
458        (when (pair? init) (byte-vector-fill! bv (car init)))
459        bv) ) )
460
461(define byte-vector                     ; DEPRECATED
462    (lambda bytes
463      (let* ([n (length bytes)]
464             [bv (make-byte-vector n)] )
465        (do ([i 0 (fx+ i 1)]
466             [bytes bytes (##sys#slot bytes 1)] )
467            ((fx>= i n) bv)
468          (##sys#setbyte bv i (##sys#slot bytes 0)) ) ) ) )
469
470(define byte-vector-set!                ; DEPRECATED
471  (lambda (bv i x)
472    (##sys#check-byte-vector bv 'byte-vector-set!)
473    (##sys#check-exact i 'byte-vector-set!)
474    (##sys#check-exact x 'byte-vector-set!)
475    (let ([n (##sys#size bv)])
476      (if (or (fx< i 0) (fx>= i n))
477          (##sys#error 'byte-vector-set! "out of range" bv i)
478          (##sys#setbyte bv i x) ) ) ) )
479
480(define byte-vector-ref                 ; DEPRECATED
481  (getter-with-setter
482   (lambda (bv i)
483     (##sys#check-byte-vector bv 'byte-vector-ref)
484     (##sys#check-exact i 'byte-vector-ref)
485     (let ([n (##sys#size bv)])
486       (if (or (fx< i 0) (fx>= i n))
487           (##sys#error 'byte-vector-ref "out of range" bv i)
488           (##sys#byte bv i) ) ) )
489   byte-vector-set!) )
490
491(define (byte-vector->list bv)          ; DEPRECATED
492  (##sys#check-byte-vector bv 'byte-vector->list)
493  (let ([len (##sys#size bv)])
494    (let loop ([i 0])
495      (if (fx>= i len)
496          '()
497          (cons (##sys#byte bv i) 
498                (loop (fx+ i 1)) ) ) ) ) )
499
500(define list->byte-vector               ; DEPRECATED
501    (lambda (lst)
502      (##sys#check-list lst 'list->byte-vector)
503      (let* ([n (length lst)]
504             [v (make-byte-vector n)] )
505        (do ([p lst (##sys#slot p 1)]
506             [i 0 (fx+ i 1)] )
507            ((eq? p '()) v)
508          (if (pair? p)
509              (let ([b (##sys#slot p 0)])
510                (##sys#check-exact b 'list->byte-vector)
511                (##sys#setbyte v i b) )
512              (##sys#error-not-a-proper-list lst) ) ) ) ) )
513
514(define string->byte-vector string->blob) ; DEPRECATED
515
516(define byte-vector->string blob->string) ; DEPRECATED
517
518(define byte-vector-length blob-size) ; DEPRECATED
519
520(define-foreign-variable _c_header_size_mask int "C_HEADER_SIZE_MASK")
521
522(let ([malloc
523       (foreign-lambda* scheme-object ((int size))
524         "char *bv;
525           if((bv = (char *)C_malloc(size + 3 + sizeof(C_header))) == NULL) return(C_SCHEME_FALSE);
526           bv = (char *)C_align((C_word)bv);
527           ((C_SCHEME_BLOCK *)bv)->header = C_BYTEVECTOR_TYPE | size;
528           return((C_word)bv);") ] )
529  (define (make size init alloc loc)
530    (##sys#check-exact size loc)
531    (if (fx> size _c_header_size_mask)
532        (error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int) loc size _c_header_size_mask)
533        (let ([bv (alloc size)])
534          (cond [bv
535                 (when (pair? init) (byte-vector-fill! bv (##sys#slot init 0)))
536                 bv]
537                [else (##sys#signal-hook #:runtime-error "cannot allocate statically allocated bytevector" size)] ) ) ) )
538  (set! make-static-byte-vector         ; DEPRECATED
539    (lambda (size . init) (make size init malloc 'make-static-byte-vector))))
540
541(define static-byte-vector->pointer             ; DEPRECATED
542  (lambda (bv)
543    (##sys#check-byte-vector bv 'static-byte-vector->pointer)
544    (if (##core#inline "C_permanentp" bv)
545        (let ([p (##sys#make-pointer)])
546          (##core#inline "C_pointer_to_block" p bv)
547          p)
548        (##sys#error 'static-byte-vector->pointer "cannot coerce non-static blob" bv) ) ) )
549
550(define (byte-vector-move! src src-start src-end dst dst-start) ; DEPRECATED
551  (let ((from (make-locative src src-start))
552        (to   (make-locative dst dst-start)) )
553    (move-memory! from to (- src-end src-start)) ) )
554
555(define (byte-vector-append . vectors)          ; DEPRECATED
556  (define (append-rest-at i vectors)
557    (if (pair? vectors)
558        (let* ((src (car vectors))
559               (len (byte-vector-length src))
560               (dst (append-rest-at (+ i len) (cdr vectors))) )
561          (byte-vector-move! src 0 len dst i)
562          dst )
563        (make-byte-vector i) ) )
564  (append-rest-at 0 vectors) )
565
566
567;;; Accessors for arbitrary vector-like block objects:
568
569(define block-set! ##sys#block-set!)
570(define block-ref (getter-with-setter ##sys#block-ref ##sys#block-set!))
571
572(define (vector-like? x)
573  (%generic-vector? x) )
574
575(define (number-of-slots x)
576  (##sys#check-generic-vector x 'number-of-slots)
577  (##sys#size x) )
578
579(define (number-of-bytes x)
580  (cond [(not (##core#inline "C_blockp" x))
581         (##sys#signal-hook
582          #:type-error 'number-of-bytes
583          "cannot compute number of bytes of immediate object" x) ]
584        [(##core#inline "C_byteblockp" x)
585         (##sys#size x)]
586        [else
587         (##core#inline "C_w2b" (##sys#size x))] ) )
588
589
590;;; Record objects:
591
592;; Record layout:
593;
594; 0     Tag (symbol)
595; 1..N  Slot (object)
596
597(define (make-record-instance type . args)
598  (##sys#check-symbol type 'make-record-instance)
599  (apply ##sys#make-structure type args) )
600
601(define (record-instance? x #!optional type)
602  (and (%record-structure? x)
603       (or (not type)
604           (eq? type (##sys#slot x 0)))) )
605
606(define (record-instance-type x)
607  (##sys#check-generic-structure x 'record-instance-type)
608  (##sys#slot x 0) )
609
610(define (record-instance-length x)
611  (##sys#check-generic-structure x 'record-instance-length)
612  (fx- (##sys#size x) 1) )
613
614(define (record-instance-slot-set! x i y)
615  (##sys#check-generic-structure x 'record-instance-slot-set!)
616  (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot-set!)
617  (##sys#setslot x (fx+ i 1) y) )
618
619(define record-instance-slot
620  (getter-with-setter
621   (lambda (x i)
622     (##sys#check-generic-structure x 'record-instance-slot)
623     (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot)
624     (##sys#slot x (fx+ i 1)) )
625   record-instance-slot-set!))
626
627(define (record->vector x)
628  (##sys#check-generic-structure x 'record->vector)
629  (let* ([n (##sys#size x)]
630         [v (##sys#make-vector n)] )
631    (do ([i 0 (fx+ i 1)])
632         [(fx>= i n) v]
633      (##sys#setslot v i (##sys#slot x i)) ) ) )
634
635
636;;; Evict objects into static memory:
637
638(define-constant evict-table-size 301)
639
640(define (object-evicted? x) (##core#inline "C_permanentp" x))
641
642(define (object-evict x . allocator)
643  (let ([allocator 
644         (if (pair? allocator) (car allocator) (foreign-lambda c-pointer "C_malloc" int) ) ] 
645        [tab (##sys#make-vector evict-table-size '())] )
646    (##sys#check-closure allocator 'object-evict)
647    (let evict ([x x])
648      (cond [(not (##core#inline "C_blockp" x)) x ]
649            [(##sys#hash-table-ref tab x) ]
650            [else
651             (let* ([n (##sys#size x)]
652                    [bytes (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))]
653                    [y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))] )
654               (when (symbol? x) (##sys#setislot y 0 (void)))
655               (##sys#hash-table-set! tab x y)
656               (unless (##core#inline "C_byteblockp" x)
657                 (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
658                     [(fx>= i n)]
659                   ;; Note the use of `##sys#setislot' to avoid an entry in the mutations-table:
660                   (##sys#setislot y i (evict (##sys#slot x i))) ) )
661               y ) ] ) ) ) )
662
663(define (object-evict-to-location x ptr . limit)
664  (cond-expand [(not unsafe) (##sys#check-special ptr 'object-evict-to-location)] [else])
665  (let* ([limit (and (pair? limit)
666                     (let ([limit (car limit)])
667                       (##sys#check-exact limit 'object-evict-to-location)
668                       limit)) ]
669         [ptr2 (##sys#address->pointer (##sys#pointer->address ptr))]
670         [tab (##sys#make-vector evict-table-size '())]
671         [x2
672          (let evict ([x x])
673            (cond [(not (##core#inline "C_blockp" x)) x ]
674                  [(##sys#hash-table-ref tab x) ]
675                  [else
676                   (let* ([n (##sys#size x)]
677                          [bytes 
678                           (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
679                                (##core#inline "C_bytes" 1) ) ] )
680                     (when limit
681                       (set! limit (fx- limit bytes))
682                       (when (fx< limit 0) 
683                         (signal
684                          (make-composite-condition
685                           (make-property-condition
686                            'exn 'location 'object-evict-to-location
687                            'message "cannot evict object - limit exceeded" 
688                            'arguments (list x limit))
689                           (make-property-condition 'evict 'limit limit) ) ) ) )
690                   (let ([y (##core#inline "C_evict_block" x ptr2)])
691                     (when (symbol? x) (##sys#setislot y 0 (void)))
692                     (##sys#set-pointer-address! ptr2 (+ (##sys#pointer->address ptr2) bytes))
693                     (##sys#hash-table-set! tab x y)
694                     (unless (##core#inline "C_byteblockp" x)
695                       (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)] )
696                           [(fx>= i n)]
697                         (##sys#setislot y i (evict (##sys#slot x i))) ) ) ; see above
698                     y) ) ] ) ) ] )
699    (values x2 ptr2) ) )
700
701(define (object-release x . releaser)
702  (let ([free (if (pair? releaser) 
703                  (car releaser) 
704                  (foreign-lambda void "C_free" c-pointer) ) ]
705        [released '() ] )
706    (let release ([x x])
707      (cond [(not (##core#inline "C_blockp" x)) x ]
708            [(not (##core#inline "C_permanentp" x)) x ]
709            [(memq x released) x ]
710            [else
711             (let ([n (##sys#size x)])
712               (set! released (cons x released))
713               (unless (##core#inline "C_byteblockp" x)
714                 (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
715                     [(fx>= i n)]
716                   (release (##sys#slot x i))) )
717               (free (##sys#address->pointer (##core#inline_allocate ("C_block_address" 4) x))) ) ] ) ) ) )
718
719(define (object-size x)
720  (let ([tab (##sys#make-vector evict-table-size '())])
721    (let evict ([x x])
722      (cond [(not (##core#inline "C_blockp" x)) 0 ]
723            [(##sys#hash-table-ref tab x) 0 ]
724            [else
725             (let* ([n (##sys#size x)]
726                    [bytes
727                     (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
728                          (##core#inline "C_bytes" 1) ) ] )
729               (##sys#hash-table-set! tab x #t)
730               (unless (##core#inline "C_byteblockp" x)
731                 (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
732                     [(fx>= i n)]
733                   (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
734               bytes) ] ) ) ) )
735
736(define (object-unevict x #!optional full)
737  (let ([tab (##sys#make-vector evict-table-size '())])
738    (let copy ([x x])
739    (cond [(not (##core#inline "C_blockp" x)) x ]
740          [(not (##core#inline "C_permanentp" x)) x ]
741          [(##sys#hash-table-ref tab x) ]
742          [(##core#inline "C_byteblockp" x) 
743           (if full
744               (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
745                 (##sys#hash-table-set! tab x y)
746                 y) 
747               x) ]
748          [(symbol? x) 
749           (let ([y (##sys#intern-symbol (##sys#slot x 1))])
750             (##sys#hash-table-set! tab x y)
751             y) ]
752          [else
753           (let* ([words (##sys#size x)]
754                  [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
755             (##sys#hash-table-set! tab x y)
756             (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
757                 ((fx>= i words))
758               (##sys#setslot y i (copy (##sys#slot y i))) )
759             y) ] ) ) ) )
760
761
762;;; `become':
763
764(define (object-become! alst)
765  (cond-expand [(not unsafe) (##sys#check-become-alist alst 'object-become!)] [else])
766  (##sys#become! alst) )
767
768(define (mutate-procedure old proc)
769  (##sys#check-closure old 'mutate-procedure)
770  (##sys#check-closure proc 'mutate-procedure)
771  (let* ([n (##sys#size old)]
772         [words (##core#inline "C_words" n)]
773         [new (##core#inline "C_copy_block" old (##sys#make-vector words))] )
774    (##sys#become! (list (cons old (proc new))))
775    new ) )
776
777
778;;; Hooks:
779
780(define ipc-hook-0 #f)                  ; we need this because `##sys#invalid-procedure-call-hook' may not have free variables.
781
782(define (set-invalid-procedure-call-handler! proc)
783  (##sys#check-closure proc 'set-invalid-procedure-call-handler!)
784  (set! ipc-hook-0 proc)
785  (set! ##sys#invalid-procedure-call-hook 
786    (lambda args
787      (ipc-hook-0 ##sys#last-invalid-procedure args) ) ) )
788
789(define (unbound-variable-value . val)
790  (set! ##sys#unbound-variable-value-hook 
791    (and (pair? val)
792         (vector (car val)))) )
793
794
795;;; Access computed globals:
796
797(define (global-ref sym)
798  (##sys#check-symbol sym 'global-ref)
799  (##core#inline "C_retrieve" sym) )
800
801(define (global-set! sym x)
802  (##sys#check-symbol sym 'global-set!)
803  (##sys#setslot sym 0 x) )
804
805(define (global-bound? sym)
806  (##sys#check-symbol sym 'global-bound?)
807  (##sys#symbol-has-toplevel-binding? sym) )
808
809(define (global-make-unbound! sym)
810  (##sys#check-symbol sym 'global-make-unbound!)
811  (##sys#setslot sym 0 (##sys#slot '##sys#arbitrary-unbound-symbol 0))
812  sym )
Note: See TracBrowser for help on using the repository browser.