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

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

Use of srfi-12 procs rather than underlying impl.

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
306;;; Tagged-pointers:
307
308(define (tag-pointer ptr tag)
309  (let ([tp (##sys#make-tagged-pointer tag)])
310    (if (%special-block? ptr)
311        (##core#inline "C_copy_pointer" ptr tp)
312        (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'tag-pointer ptr) )
313    tp) )
314
315(define (tagged-pointer? x #!optional tag)
316  (and (##core#inline "C_blockp" x)  (##core#inline "C_taggedpointerp" x)
317       (or (not tag)
318           (equal? tag (##sys#slot x 1)) ) ) )
319
320(define (pointer-tag x)
321  (if (%special-block? x)
322      (and (##core#inline "C_taggedpointerp" x)
323           (##sys#slot x 1) )
324      (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'pointer-tag x) ) )
325
326
327;;; locatives:
328
329;; Locative layout:
330;
331; 0     Object-address + Byte-offset (address)
332; 1     Byte-offset (fixnum)
333; 2     Type (fixnum)
334;       0       vector or pair          (C_SLOT_LOCATIVE)
335;       1       string                  (C_CHAR_LOCATIVE)
336;       2       u8vector or blob        (C_U8_LOCATIVE)
337;       3       s8vector                (C_S8_LOCATIVE)
338;       4       u16vector               (C_U16_LOCATIVE)
339;       5       s16vector               (C_S16_LOCATIVE)
340;       6       u32vector               (C_U32_LOCATIVE)
341;       7       s32vector               (C_S32_LOCATIVE)
342;       8       f32vector               (C_F32_LOCATIVE)
343;       9       f64vector               (C_F64_LOCATIVE)
344; 3     Object or #f, if weak (C_word)
345
346(define (make-locative obj . index)
347  (##sys#make-locative obj (optional index 0) #f 'make-locative) )
348
349(define (make-weak-locative obj . index)
350  (##sys#make-locative obj (optional index 0) #t 'make-weak-locative) )
351
352(define (locative-set! x y) (##core#inline "C_i_locative_set" x y))
353(define locative-ref (getter-with-setter (##core#primitive "C_locative_ref") locative-set!))
354(define (locative->object x) (##core#inline "C_i_locative_to_object" x))
355(define (locative? x) (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x)))
356
357
358;;; SRFI-4 number-vector:
359
360(define pointer-u8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned char *)p) = n;"))
361(define pointer-s8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((char *)p) = n;"))
362(define pointer-u16-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned short *)p) = n;"))
363(define pointer-s16-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((short *)p) = n;"))
364(define pointer-u32-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((C_u32 *)p) = n;"))
365(define pointer-s32-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((C_s32 *)p) = n;"))
366(define pointer-f32-set! (foreign-lambda* void ([c-pointer p] [double n]) "*((float *)p) = n;"))
367(define pointer-f64-set! (foreign-lambda* void ([c-pointer p] [float n]) "*((double *)p) = n;"))
368
369(define pointer-u8-ref
370  (getter-with-setter
371   (foreign-lambda* int ([c-pointer p]) "return(*((unsigned char *)p));")
372   pointer-u8-set!) )
373
374(define pointer-s8-ref
375  (getter-with-setter
376   (foreign-lambda* int ([c-pointer p]) "return(*((char *)p));")
377   pointer-s8-set!) )
378
379(define pointer-u16-ref
380  (getter-with-setter
381   (foreign-lambda* int ([c-pointer p]) "return(*((unsigned short *)p));")
382   pointer-u16-set!) )
383
384(define pointer-s16-ref
385  (getter-with-setter
386   (foreign-lambda* int ([c-pointer p]) "return(*((short *)p));")
387   pointer-s6-set!) )
388
389(define pointer-u32-ref
390  (getter-with-setter
391   (foreign-lambda* integer ([c-pointer p]) "return(*((C_u32 *)p));")
392   pointer-u32-set!) )
393
394(define pointer-s32-ref
395  (getter-with-setter
396   (foreign-lambda* integer ([c-pointer p]) "return(*((C_s32 *)p));")
397   pointer-s32-set!) )
398
399(define pointer-f32-ref
400  (getter-with-setter
401   (foreign-lambda* float ([c-pointer p]) "return(*((float *)p));")
402   pointer-f32-set!) )
403
404(define pointer-f64-ref
405  (getter-with-setter
406   (foreign-lambda* double ([c-pointer p]) "return(*((double *)p));")
407   pointer-f64-set!) )
408
409
410;;; Procedures extended with data:
411
412; Unique id for extended-procedures
413(define xproc-tag (vector 'extended))
414
415(define (extend-procedure proc data)
416  (##sys#check-closure proc 'extend-procedure)
417  (##sys#decorate-lambda
418   proc
419   (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0)))) 
420   (lambda (x i) (##sys#setslot x i (cons xproc-tag data)) x) ) )
421
422(define-inline (%procedure-data proc)
423  (##sys#lambda-decoration proc (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0))))) )
424
425(define (extended-procedure? x)
426  (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
427       (%procedure-data x)
428       #t) )
429
430(define (procedure-data x)
431  (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
432       (and-let* ([d (%procedure-data x)])
433         (##sys#slot d 1) ) ) )
434
435(define set-procedure-data!
436  (let ((extend-procedure extend-procedure))
437    (lambda (proc x)
438      (let ((p2 (extend-procedure proc x)))
439        (if (eq? p2 proc)
440            proc
441            (##sys#signal-hook
442             #:type-error 'set-procedure-data!
443             "bad argument type - not an extended procedure" proc) ) ) ) ) )
444
445
446;;; Bytevector stuff:
447
448(define byte-vector? blob?)             ; DEPRECATED
449
450(define (byte-vector-fill! bv n)        ; DEPRECATED
451  (##sys#check-byte-vector bv 'byte-vector-fill!)
452  (##sys#check-exact n 'byte-vector-fill!)
453  (let ([len (##sys#size bv)])
454    (do ([i 0 (fx+ i 1)])
455        ((fx>= i len))
456      (##sys#setbyte bv i n) ) ) )
457
458(define make-byte-vector                ; DEPRECATED
459    (lambda (size . init)
460      (let ([bv (make-blob size)])
461        (when (pair? init) (byte-vector-fill! bv (car init)))
462        bv) ) )
463
464(define byte-vector                     ; DEPRECATED
465    (lambda bytes
466      (let* ([n (length bytes)]
467             [bv (make-byte-vector n)] )
468        (do ([i 0 (fx+ i 1)]
469             [bytes bytes (##sys#slot bytes 1)] )
470            ((fx>= i n) bv)
471          (##sys#setbyte bv i (##sys#slot bytes 0)) ) ) ) )
472
473(define byte-vector-set!                ; DEPRECATED
474  (lambda (bv i x)
475    (##sys#check-byte-vector bv 'byte-vector-set!)
476    (##sys#check-exact i 'byte-vector-set!)
477    (##sys#check-exact x 'byte-vector-set!)
478    (let ([n (##sys#size bv)])
479      (if (or (fx< i 0) (fx>= i n))
480          (##sys#error 'byte-vector-set! "out of range" bv i)
481          (##sys#setbyte bv i x) ) ) ) )
482
483(define byte-vector-ref                 ; DEPRECATED
484  (getter-with-setter
485   (lambda (bv i)
486     (##sys#check-byte-vector bv 'byte-vector-ref)
487     (##sys#check-exact i 'byte-vector-ref)
488     (let ([n (##sys#size bv)])
489       (if (or (fx< i 0) (fx>= i n))
490           (##sys#error 'byte-vector-ref "out of range" bv i)
491           (##sys#byte bv i) ) ) )
492   byte-vector-set!) )
493
494(define (byte-vector->list bv)          ; DEPRECATED
495  (##sys#check-byte-vector bv 'byte-vector->list)
496  (let ([len (##sys#size bv)])
497    (let loop ([i 0])
498      (if (fx>= i len)
499          '()
500          (cons (##sys#byte bv i) 
501                (loop (fx+ i 1)) ) ) ) ) )
502
503(define list->byte-vector               ; DEPRECATED
504    (lambda (lst)
505      (##sys#check-list lst 'list->byte-vector)
506      (let* ([n (length lst)]
507             [v (make-byte-vector n)] )
508        (do ([p lst (##sys#slot p 1)]
509             [i 0 (fx+ i 1)] )
510            ((eq? p '()) v)
511          (if (pair? p)
512              (let ([b (##sys#slot p 0)])
513                (##sys#check-exact b 'list->byte-vector)
514                (##sys#setbyte v i b) )
515              (##sys#error-not-a-proper-list lst) ) ) ) ) )
516
517(define string->byte-vector string->blob) ; DEPRECATED
518
519(define byte-vector->string blob->string) ; DEPRECATED
520
521(define byte-vector-length blob-size) ; DEPRECATED
522
523(define-foreign-variable _c_header_size_mask int "C_HEADER_SIZE_MASK")
524
525(let ([malloc
526       (foreign-lambda* scheme-object ((int size))
527         "char *bv;
528           if((bv = (char *)C_malloc(size + 3 + sizeof(C_header))) == NULL) return(C_SCHEME_FALSE);
529           bv = (char *)C_align((C_word)bv);
530           ((C_SCHEME_BLOCK *)bv)->header = C_BYTEVECTOR_TYPE | size;
531           return((C_word)bv);") ] )
532  (define (make size init alloc loc)
533    (##sys#check-exact size loc)
534    (if (fx> size _c_header_size_mask)
535        (error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int) loc size _c_header_size_mask)
536        (let ([bv (alloc size)])
537          (cond [bv
538                 (when (pair? init) (byte-vector-fill! bv (##sys#slot init 0)))
539                 bv]
540                [else (##sys#signal-hook #:runtime-error "cannot allocate statically allocated bytevector" size)] ) ) ) )
541  (set! make-static-byte-vector         ; DEPRECATED
542    (lambda (size . init) (make size init malloc 'make-static-byte-vector))))
543
544(define static-byte-vector->pointer             ; DEPRECATED
545  (lambda (bv)
546    (##sys#check-byte-vector bv 'static-byte-vector->pointer)
547    (if (##core#inline "C_permanentp" bv)
548        (let ([p (##sys#make-pointer)])
549          (##core#inline "C_pointer_to_block" p bv)
550          p)
551        (##sys#error 'static-byte-vector->pointer "cannot coerce non-static blob" bv) ) ) )
552
553(define (byte-vector-move! src src-start src-end dst dst-start) ; DEPRECATED
554  (let ((from (make-locative src src-start))
555        (to   (make-locative dst dst-start)) )
556    (move-memory! from to (- src-end src-start)) ) )
557
558(define (byte-vector-append . vectors)          ; DEPRECATED
559  (define (append-rest-at i vectors)
560    (if (pair? vectors)
561        (let* ((src (car vectors))
562               (len (byte-vector-length src))
563               (dst (append-rest-at (+ i len) (cdr vectors))) )
564          (byte-vector-move! src 0 len dst i)
565          dst )
566        (make-byte-vector i) ) )
567  (append-rest-at 0 vectors) )
568
569
570;;; Accessors for arbitrary vector-like block objects:
571
572(define block-set! ##sys#block-set!)
573(define block-ref (getter-with-setter ##sys#block-ref ##sys#block-set!))
574
575(define (vector-like? x)
576  (%generic-vector? x) )
577
578(define (number-of-slots x)
579  (##sys#check-generic-vector x 'number-of-slots)
580  (##sys#size x) )
581
582(define (number-of-bytes x)
583  (cond [(not (##core#inline "C_blockp" x))
584         (##sys#signal-hook
585          #:type-error 'number-of-bytes
586          "cannot compute number of bytes of immediate object" x) ]
587        [(##core#inline "C_byteblockp" x)
588         (##sys#size x)]
589        [else
590         (##core#inline "C_w2b" (##sys#size x))] ) )
591
592
593;;; Record objects:
594
595;; Record layout:
596;
597; 0     Tag (symbol)
598; 1..N  Slot (object)
599
600(define (make-record-instance type . args)
601  (##sys#check-symbol type 'make-record-instance)
602  (apply ##sys#make-structure type args) )
603
604(define (record-instance? x #!optional type)
605  (and (%record-structure? x)
606       (or (not type)
607           (eq? type (##sys#slot x 0)))) )
608
609(define (record-instance-type x)
610  (##sys#check-generic-structure x 'record-instance-type)
611  (##sys#slot x 0) )
612
613(define (record-instance-length x)
614  (##sys#check-generic-structure x 'record-instance-length)
615  (fx- (##sys#size x) 1) )
616
617(define (record-instance-slot-set! x i y)
618  (##sys#check-generic-structure x 'record-instance-slot-set!)
619  (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot-set!)
620  (##sys#setslot x (fx+ i 1) y) )
621
622(define record-instance-slot
623  (getter-with-setter
624   (lambda (x i)
625     (##sys#check-generic-structure x 'record-instance-slot)
626     (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot)
627     (##sys#slot x (fx+ i 1)) )
628   record-instance-slot-set!))
629
630(define (record->vector x)
631  (##sys#check-generic-structure x 'record->vector)
632  (let* ([n (##sys#size x)]
633         [v (##sys#make-vector n)] )
634    (do ([i 0 (fx+ i 1)])
635         [(fx>= i n) v]
636      (##sys#setslot v i (##sys#slot x i)) ) ) )
637
638
639;;; Evict objects into static memory:
640
641(define-constant evict-table-size 301)
642
643(define (object-evicted? x) (##core#inline "C_permanentp" x))
644
645(define (object-evict x . allocator)
646  (let ([allocator 
647         (if (pair? allocator) (car allocator) (foreign-lambda c-pointer "C_malloc" int) ) ] 
648        [tab (##sys#make-vector evict-table-size '())] )
649    (##sys#check-closure allocator 'object-evict)
650    (let evict ([x x])
651      (cond [(not (##core#inline "C_blockp" x)) x ]
652            [(##sys#hash-table-ref tab x) ]
653            [else
654             (let* ([n (##sys#size x)]
655                    [bytes (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))]
656                    [y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))] )
657               (when (symbol? x) (##sys#setislot y 0 (void)))
658               (##sys#hash-table-set! tab x y)
659               (unless (##core#inline "C_byteblockp" x)
660                 (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
661                     [(fx>= i n)]
662                   ;; Note the use of `##sys#setislot' to avoid an entry in the mutations-table:
663                   (##sys#setislot y i (evict (##sys#slot x i))) ) )
664               y ) ] ) ) ) )
665
666(define (object-evict-to-location x ptr . limit)
667  (cond-expand [(not unsafe) (##sys#check-special ptr 'object-evict-to-location)] [else])
668  (let* ([limit (and (pair? limit)
669                     (let ([limit (car limit)])
670                       (##sys#check-exact limit 'object-evict-to-location)
671                       limit)) ]
672         [ptr2 (##sys#address->pointer (##sys#pointer->address ptr))]
673         [tab (##sys#make-vector evict-table-size '())]
674         [x2
675          (let evict ([x x])
676            (cond [(not (##core#inline "C_blockp" x)) x ]
677                  [(##sys#hash-table-ref tab x) ]
678                  [else
679                   (let* ([n (##sys#size x)]
680                          [bytes 
681                           (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
682                                (##core#inline "C_bytes" 1) ) ] )
683                     (when limit
684                       (set! limit (fx- limit bytes))
685                       (when (fx< limit 0) 
686                         (signal
687                          (make-composite-condition
688                           (make-property-condition
689                            'exn
690                            'location 'object-evict-to-location
691                            'message "cannot evict object - limit exceeded" 
692                            'arguments (list x limit))
693                           (make-property-condition 'evict 'limit limit) ) ) ) )
694                   (let ([y (##core#inline "C_evict_block" x ptr2)])
695                     (when (symbol? x) (##sys#setislot y 0 (void)))
696                     (##sys#set-pointer-address! ptr2 (+ (##sys#pointer->address ptr2) bytes))
697                     (##sys#hash-table-set! tab x y)
698                     (unless (##core#inline "C_byteblockp" x)
699                       (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)] )
700                           [(fx>= i n)]
701                         (##sys#setislot y i (evict (##sys#slot x i))) ) ) ; see above
702                     y) ) ] ) ) ] )
703    (values x2 ptr2) ) )
704
705(define (object-release x . releaser)
706  (let ([free (if (pair? releaser) 
707                  (car releaser) 
708                  (foreign-lambda void "C_free" c-pointer) ) ]
709        [released '() ] )
710    (let release ([x x])
711      (cond [(not (##core#inline "C_blockp" x)) x ]
712            [(not (##core#inline "C_permanentp" x)) x ]
713            [(memq x released) x ]
714            [else
715             (let ([n (##sys#size x)])
716               (set! released (cons x released))
717               (unless (##core#inline "C_byteblockp" x)
718                 (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
719                     [(fx>= i n)]
720                   (release (##sys#slot x i))) )
721               (free (##sys#address->pointer (##core#inline_allocate ("C_block_address" 4) x))) ) ] ) ) ) )
722
723(define (object-size x)
724  (let ([tab (##sys#make-vector evict-table-size '())])
725    (let evict ([x x])
726      (cond [(not (##core#inline "C_blockp" x)) 0 ]
727            [(##sys#hash-table-ref tab x) 0 ]
728            [else
729             (let* ([n (##sys#size x)]
730                    [bytes
731                     (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
732                          (##core#inline "C_bytes" 1) ) ] )
733               (##sys#hash-table-set! tab x #t)
734               (unless (##core#inline "C_byteblockp" x)
735                 (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
736                     [(fx>= i n)]
737                   (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
738               bytes) ] ) ) ) )
739
740(define (object-unevict x #!optional full)
741  (let ([tab (##sys#make-vector evict-table-size '())])
742    (let copy ([x x])
743    (cond [(not (##core#inline "C_blockp" x)) x ]
744          [(not (##core#inline "C_permanentp" x)) x ]
745          [(##sys#hash-table-ref tab x) ]
746          [(##core#inline "C_byteblockp" x) 
747           (if full
748               (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
749                 (##sys#hash-table-set! tab x y)
750                 y) 
751               x) ]
752          [(symbol? x) 
753           (let ([y (##sys#intern-symbol (##sys#slot x 1))])
754             (##sys#hash-table-set! tab x y)
755             y) ]
756          [else
757           (let* ([words (##sys#size x)]
758                  [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
759             (##sys#hash-table-set! tab x y)
760             (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
761                 ((fx>= i words))
762               (##sys#setslot y i (copy (##sys#slot y i))) )
763             y) ] ) ) ) )
764
765
766;;; `become':
767
768(define (object-become! alst)
769  (cond-expand [(not unsafe) (##sys#check-become-alist alst 'object-become!)] [else])
770  (##sys#become! alst) )
771
772(define (mutate-procedure old proc)
773  (##sys#check-closure old 'mutate-procedure)
774  (##sys#check-closure proc 'mutate-procedure)
775  (let* ([n (##sys#size old)]
776         [words (##core#inline "C_words" n)]
777         [new (##core#inline "C_copy_block" old (##sys#make-vector words))] )
778    (##sys#become! (list (cons old (proc new))))
779    new ) )
780
781
782;;; Hooks:
783
784(define ipc-hook-0 #f)                  ; we need this because `##sys#invalid-procedure-call-hook' may not have free variables.
785
786(define (set-invalid-procedure-call-handler! proc)
787  (##sys#check-closure proc 'set-invalid-procedure-call-handler!)
788  (set! ipc-hook-0 proc)
789  (set! ##sys#invalid-procedure-call-hook 
790    (lambda args
791      (ipc-hook-0 ##sys#last-invalid-procedure args) ) ) )
792
793(define (unbound-variable-value . val)
794  (set! ##sys#unbound-variable-value-hook 
795    (and (pair? val)
796         (vector (car val)))) )
797
798
799;;; Access computed globals:
800
801(define (global-ref sym)
802  (##sys#check-symbol sym 'global-ref)
803  (##core#inline "C_retrieve" sym) )
804
805(define (global-set! sym x)
806  (##sys#check-symbol sym 'global-set!)
807  (##sys#setslot sym 0 x) )
808
809(define (global-bound? sym)
810  (##sys#check-symbol sym 'global-bound?)
811  (##sys#symbol-has-toplevel-binding? sym) )
812
813(define (global-make-unbound! sym)
814  (##sys#check-symbol sym 'global-make-unbound!)
815  (##sys#setslot sym 0 (##sys#slot '##sys#arbitrary-unbound-symbol 0))
816  sym )
Note: See TracBrowser for help on using the repository browser.