source: project/chicken/branches/hygienic/lolevel.scm @ 10788

Last change on this file since 10788 was 10788, checked in by felix winkelmann, 12 years ago
  • added remaining import libraries
  • csi uses srfi-69 now to avoid bootstrapping problem
  • csi: renamed "-se" to "-sx"
  • global assigns get variable name in comment in generated C code
  • import libs are compiled to .so's (likely to be not complete for windoze builds - that would be too easy)
  • removed a lot of deprecated stuff
  • it really seems to work...
File size: 20.7 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  (foreign-declare #<<EOF
34#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__)
35# include <sys/types.h>
36#endif
37#ifndef C_NONUNIX
38# include <sys/mman.h>
39#endif
40
41#define C_pointer_to_object(ptr)   ((C_word*)C_block_item(ptr, 0))
42#define C_w2b(x)                   C_fix(C_wordstobytes(C_unfix(x)))
43#define C_pointer_eqp(x, y)        C_mk_bool(C_c_pointer_nn(x) == C_c_pointer_nn(y))
44#define C_memmove_o(to, from, n, toff, foff) C_memmove((char *)(to) + (toff), (char *)(from) + (foff), (n))
45EOF
46) )
47
48(cond-expand
49 [paranoia]
50 [else
51  (declare
52    (no-bound-checks)
53    (no-procedure-checks-for-usual-bindings)
54    (bound-to-procedure
55     ##sys#hash-table-ref ##sys#hash-table-set!
56     ##sys#make-locative ##sys#become!
57     ##sys#make-string
58     make-property-condition make-composite-condition signal ##sys#set-pointer-address! ##sys#make-vector
59     ##sys#make-pointer make-string make-byte-vector ##sys#not-a-proper-list-error ##sys#check-pointer
60     ##sys#locative? ##sys#bytevector?
61     extend-procedure ##sys#lambda-decoration ##sys#decorate-lambda ##sys#make-tagged-pointer ##sys#check-special
62     ##sys#vector->closure! ##sys#error ##sys#signal-hook ##sys#address->pointer ##sys#pointer->address) ) ] )
63
64(include "unsafe-declarations.scm")
65
66(register-feature! 'lolevel)
67
68
69;;; Move arbitrary blocks of memory around:
70
71(define move-memory!
72  (let ([memmove1 (foreign-lambda void "C_memmove_o" c-pointer c-pointer int int int)]
73        [memmove2 (foreign-lambda void "C_memmove_o" c-pointer scheme-pointer int int int)]
74        [memmove3 (foreign-lambda void "C_memmove_o" scheme-pointer c-pointer int int int)]
75        [memmove4 (foreign-lambda void "C_memmove_o" scheme-pointer scheme-pointer int int int)]
76        [slot1structs '(mmap u8vector u16vector u32vector s8vector s16vector s32vector f32vector f64vector)] )
77    (lambda (from to #!optional n (foffset 0) (toffset 0))
78      (define (err) (##sys#error 'move-memory! "need number of bytes to move" from to))
79      (define (xerr x) (##sys#signal-hook #:type-error 'move-memory! "invalid argument type" x))
80      (define (checkn n nmax off)
81        (if (cond-expand [unsafe #t] [else (fx<= n (fx- nmax off))])
82            n
83            (##sys#error 'move-memory! "number of bytes to move too large" from to n nmax) ) )
84      (define (checkn2 n nmax nmax2 off1 off2)
85        (if (cond-expand [unsafe #t] [else (and (fx<= n (fx- nmax off1)) (fx<= n (fx- nmax2 off2)))])
86            n
87            (##sys#error 'move-memory! "number of bytes to move too large" from to n nmax nmax2) ) )
88      (let move ([from from] [to to])
89        (cond [(##sys#generic-structure? from)
90               (if (memq (##sys#slot from 0) slot1structs)
91                   (move (##sys#slot from 1) to)
92                   (xerr from) ) ]
93              [(##sys#generic-structure? to)
94               (if (memq (##sys#slot to 0) slot1structs)
95                   (move from (##sys#slot to 1))
96                   (xerr to) ) ]
97              [(or (##sys#pointer? from) (##sys#locative? from))
98               (cond [(or (##sys#pointer? to) (##sys#locative? to))
99                      (memmove1 to from (or n (err)) toffset foffset)]
100                     [(or (##sys#bytevector? to) (string? to))
101                      (memmove3 to from (checkn (or n (err)) (##sys#size to) toffset) toffset foffset) ]
102                     [else (xerr to)] ) ]
103              [(or (##sys#bytevector? from) (string? from))
104               (let ([nfrom (##sys#size from)])
105                 (cond [(or (##sys#pointer? to) (##sys#locative? to))
106                        (memmove2 to from (checkn (or n nfrom) nfrom foffset) toffset foffset)]
107                       [(or (##sys#bytevector? to) (string? to))
108                        (memmove4 to from (checkn2 (or n nfrom) nfrom (##sys#size to) foffset toffset)
109                                  toffset foffset) ]
110                       [else (xerr to)] ) ) ]
111              [else (xerr from)] ) ) ) ) )
112
113
114;;; Pointer operations:
115
116(define (##sys#check-pointer ptr loc)
117  (unless (and (##core#inline "C_blockp" ptr)
118               (or (##core#inline "C_pointerp" ptr)
119                   (##core#inline "C_swigpointerp" ptr)
120                   (##core#inline "C_taggedpointerp" ptr) ) )
121    (##sys#signal-hook #:type-error loc "bad argument type - not a pointer" ptr) ) )
122
123(define null-pointer ##sys#null-pointer)
124
125(define (pointer? x)
126  (and (##core#inline "C_blockp" x)
127       (or (##core#inline "C_pointerp" x)
128           (##core#inline "C_taggedpointerp" x) ) ) )
129
130(define (address->pointer addr)
131  (cond-expand
132   [(not unsafe)
133    (when (not (integer? addr))
134      (##sys#signal-hook #:type-error 'address->pointer "bad argument type - not an integer" addr) ) ]
135   [else] )
136  (##sys#address->pointer addr) )
137
138(define (pointer->address ptr)
139  (##sys#check-special ptr 'pointer->address)
140  (##sys#pointer->address ptr) )
141
142(define (null-pointer? ptr)
143  (##sys#check-special ptr 'null-pointer?)
144  (eq? 0 (##sys#pointer->address ptr) ) )
145
146(define (object->pointer x)
147  (and (##core#inline "C_blockp" x)
148       ((foreign-lambda* nonnull-c-pointer ((scheme-object x))
149          "return((void *)x);") 
150        x) ) )
151
152(define (pointer->object ptr)
153  (##sys#check-pointer ptr 'pointer->object)
154  (##core#inline "C_pointer_to_object" ptr) )
155
156(define (pointer=? p1 p2)
157  (##sys#check-special p1 'pointer=?)
158  (##sys#check-special p2 'pointer=?)
159  (##core#inline "C_pointer_eqp" p1 p2) )
160
161(define allocate (foreign-lambda c-pointer "C_malloc" int))
162(define free (foreign-lambda void "C_free" c-pointer))
163
164(define align-to-word
165  (let ([align (foreign-lambda integer "C_align" integer)])
166    (lambda (x)
167      (cond [(number? x) (align x)]
168            [(and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x))
169             (##sys#address->pointer (align (##sys#pointer->address x))) ]
170            [else (##sys#signal-hook #:type-error 'align-to-word "bad argument type - not a pointer or fixnum" x)] ) ) ) )
171
172(define pointer-offset
173  (foreign-lambda* nonnull-c-pointer ([c-pointer ptr] [integer off])
174    "return((unsigned char *)ptr + off);") )
175
176(define pointer-u8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned char *)p) = n;"))
177(define pointer-s8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((char *)p) = n;"))
178(define pointer-u16-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned short *)p) = n;"))
179(define pointer-s16-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((short *)p) = n;"))
180(define pointer-u32-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((C_u32 *)p) = n;"))
181(define pointer-s32-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((C_s32 *)p) = n;"))
182(define pointer-f32-set! (foreign-lambda* void ([c-pointer p] [double n]) "*((float *)p) = n;"))
183(define pointer-f64-set! (foreign-lambda* void ([c-pointer p] [float n]) "*((double *)p) = n;"))
184
185(define pointer-u8-ref
186  (getter-with-setter
187   (foreign-lambda* int ([c-pointer p]) "return(*((unsigned char *)p));")
188   pointer-u8-set!) )
189
190(define pointer-s8-ref
191  (getter-with-setter
192   (foreign-lambda* int ([c-pointer p]) "return(*((char *)p));")
193   pointer-s8-set!) )
194
195(define pointer-u16-ref
196  (getter-with-setter
197   (foreign-lambda* int ([c-pointer p]) "return(*((unsigned short *)p));")
198   pointer-u16-set!) )
199
200(define pointer-s16-ref
201  (getter-with-setter
202   (foreign-lambda* int ([c-pointer p]) "return(*((short *)p));")
203   pointer-s6-set!) )
204
205(define pointer-u32-ref
206  (getter-with-setter
207   (foreign-lambda* integer ([c-pointer p]) "return(*((C_u32 *)p));")
208   pointer-u32-set!) )
209
210(define pointer-s32-ref
211  (getter-with-setter
212   (foreign-lambda* integer ([c-pointer p]) "return(*((C_s32 *)p));")
213   pointer-s32-set!) )
214
215(define pointer-f32-ref
216  (getter-with-setter
217   (foreign-lambda* float ([c-pointer p]) "return(*((float *)p));")
218   pointer-f32-set!) )
219
220(define pointer-f64-ref
221  (getter-with-setter
222   (foreign-lambda* double ([c-pointer p]) "return(*((double *)p));")
223   pointer-f64-set!) )
224
225(define (tag-pointer ptr tag)
226  (let ([tp (##sys#make-tagged-pointer tag)])
227    (if (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr))
228        (##core#inline "C_copy_pointer" ptr tp)
229        (##sys#signal-hook #:type-error 'tag-pointer "bad argument type - not a pointer" ptr) )
230    tp) )
231
232(define (tagged-pointer? x tag)
233  (and (##core#inline "C_blockp" x) 
234       (##core#inline "C_taggedpointerp" x)
235       (equal? tag (##sys#slot x 1)) ) )
236
237(define (pointer-tag x)
238  (if (and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x))
239      (and (##core#inline "C_taggedpointerp" x)
240           (##sys#slot x 1) )
241      (##sys#signal-hook #:type-error 'pointer-tag "bad argument type - not a pointer" x) ) )
242
243
244;;; Procedures extended with data:
245
246(define xproc-tag (vector 'extended))
247
248(define (extend-procedure proc data)
249  #+(not unsafe)
250  (unless (##core#inline "C_closurep" proc)
251    (##sys#signal-hook #:type-error 'extend-procedure "bad argument type - not a procedure" proc) )
252  (##sys#decorate-lambda
253   proc
254   (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0)))) 
255   (lambda (x i)
256     (##sys#setslot x i (cons xproc-tag data))
257     x) ) )
258
259(define (extended-procedure? x)
260  (and (##core#inline "C_blockp" x)
261       (##core#inline "C_closurep" x)
262       (##sys#lambda-decoration x (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0)))))
263       #t) )
264
265(define (procedure-data x)
266  (and (##core#inline "C_blockp" x)
267       (##core#inline "C_closurep" x)
268       (and-let* ((d (##sys#lambda-decoration x (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0)))))))
269         (##sys#slot d 1) ) ) )
270
271(define set-procedure-data!
272  (let ((extend-procedure extend-procedure))
273    (lambda (proc x)
274      (let ((p2 (extend-procedure proc x)))
275        (if (eq? p2 proc)
276            proc
277            (##sys#signal-hook #:type-error 'set-procedure-data! "bad argument type - not an extended procedure" proc) ) ) ) ) )
278
279
280;;; Accessors for arbitrary block objects:
281
282(define block-set! ##sys#block-set!)
283(define block-ref (getter-with-setter ##sys#block-ref ##sys#block-set!))
284
285(define number-of-slots 
286  (lambda (x)
287    (when (or (not (##core#inline "C_blockp" x)) 
288              (##core#inline "C_specialp" x)
289              (##core#inline "C_byteblockp" x) )
290      (##sys#signal-hook #:type-error 'number-of-slots "slots not accessible" x) )
291    (##sys#size x) ) )
292
293(define (number-of-bytes x)
294  (cond [(not (##core#inline "C_blockp" x))
295         (##sys#signal-hook #:type-error 'number-of-bytes "can not compute number of bytes of immediate object" x) ]
296        [(##core#inline "C_byteblockp" x) (##sys#size x)]
297        [else (##core#inline "C_w2b" (##sys#size x))] ) )
298
299
300;;; Record objects:
301
302(define (make-record-instance type . args)
303  (##sys#check-symbol type 'make-record-instance)
304  (apply ##sys#make-structure type args) )
305
306(define (record-instance? x)
307  (and (##core#inline "C_blockp" x)
308       (##core#inline "C_structurep" x) ) )
309
310(define (record->vector x)
311  (if (and (not (##sys#immediate? x)) (##sys#generic-structure? x))
312      (let* ([n (##sys#size x)]
313             [v (##sys#make-vector n)] )
314        (do ([i 0 (fx+ i 1)])
315            ((fx>= i n) v)
316          (##sys#setslot v i (##sys#slot x i)) ) )
317      (##sys#signal-hook #:type-error 'record->vector "bad argument type - not a record structure" x) ) )
318
319
320;;; Copy arbitrary object:
321
322(define (object-copy x)
323  (let copy ([x x])
324    (cond [(not (##core#inline "C_blockp" x)) x]
325          [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
326          [else
327            (let* ([n (##sys#size x)]
328                   [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)]
329                   [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
330              (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
331                (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
332                    ((fx>= i n))
333                  (##sys#setslot y i (copy (##sys#slot y i))) ) )
334              y) ] ) ) )
335
336
337;;; Evict objects into static memory:
338
339(define-constant evict-table-size 301)
340
341(define (object-evicted? x) (##core#inline "C_permanentp" x))
342
343(define object-evict
344    (lambda (x . allocator)
345      (let ([allocator 
346             (if (pair? allocator) 
347                 (car allocator)
348                 (foreign-lambda c-pointer "C_malloc" int) ) ] 
349            [tab (##sys#make-vector evict-table-size '())] )
350        (let evict ([x x])
351          (cond [(not (##core#inline "C_blockp" x)) x]
352                [(##sys#hash-table-ref tab x)]
353                [else
354                 (let* ([n (##sys#size x)]
355                        [bytes (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))]
356                        [y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))] )
357                   (when (symbol? x) (##sys#setislot y 0 (##core#undefined)))
358                   (##sys#hash-table-set! tab x y)
359                   (unless (##core#inline "C_byteblockp" x)
360                     (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
361                         ((fx>= i n))
362                       ;; Note the use of `##sys#setislot' to avoid an entry in the mutations-table:
363                       (##sys#setislot y i (evict (##sys#slot x i))) ) )
364                   y) ] ) ) ) ) )
365
366(define object-release
367  (lambda (x . releaser)
368    (let ((free (if (pair? releaser) 
369                    (car releaser) 
370                    (foreign-lambda void "C_free" c-pointer) ) ) 
371          (released '()))
372      (let release ([x x])
373        (cond [(not (##core#inline "C_blockp" x)) x]
374              [(not (##core#inline "C_permanentp" x)) x]
375              ((memq x released) x)
376              [else
377               (let ([n (##sys#size x)])
378                 (set! released (cons x released))
379                 (unless (##core#inline "C_byteblockp" x)
380                   (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
381                       ((fx>= i n))
382                     (release (##sys#slot x i))) )
383                 (free (##sys#address->pointer (##core#inline_allocate ("C_block_address" 4) x))) ) ] ) ) ) ) )
384
385(define object-evict-to-location
386    (lambda (x ptr . limit)
387      (cond-expand
388       [(not unsafe)
389        (when (not (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr)))
390          (##sys#signal-hook #:type-error 'object-evict-to-location "bad argument type - not a pointer" ptr) ) ]
391       [else] )
392      (let* ([limit
393              (if (pair? limit)
394                  (let ([limit (car limit)])
395                    (##sys#check-exact limit 'object-evict-to-location)
396                    limit)
397                  #f) ]
398             [ptr2 (##sys#address->pointer (##sys#pointer->address ptr))]
399             [tab (##sys#make-vector evict-table-size '())]
400             [x2
401              (let evict ([x x])
402                (cond [(not (##core#inline "C_blockp" x)) x]
403                      [(##sys#hash-table-ref tab x)]
404                      [else
405                       (let* ([n (##sys#size x)]
406                              [bytes 
407                               (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
408                                    (##core#inline "C_bytes" 1) ) ] )
409                         (when limit
410                           (set! limit (fx- limit bytes))
411                           (when (fx< limit 0) 
412                             (signal
413                              (make-composite-condition
414                               (make-property-condition
415                                'exn 'location 'object-evict-to-location
416                                'message "can not evict object - limit exceeded" 
417                                'arguments (list x limit))
418                               (make-property-condition 'evict 'limit limit) ) ) ) )
419                         (let ([y (##core#inline "C_evict_block" x ptr2)])
420                           (when (symbol? x) (##sys#setislot y 0 (##core#undefined)))
421                           (##sys#set-pointer-address! ptr2 (+ (##sys#pointer->address ptr2) bytes))
422                           (##sys#hash-table-set! tab x y)
423                           (unless (##core#inline "C_byteblockp" x)
424                             (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
425                                         1
426                                         0)
427                                     (fx+ i 1) ] )
428                                 ((fx>= i n))
429                               (##sys#setislot y i (evict (##sys#slot x i))) ) ) ; see above
430                           y) ) ] ) ) ] )
431        (values x2 ptr2) ) ) )
432
433(define object-size
434    (lambda (x)
435      (let ([tab (##sys#make-vector evict-table-size '())])
436        (let evict ([x x])
437          (cond [(not (##core#inline "C_blockp" x)) 0]
438                [(##sys#hash-table-ref tab x) 0]
439                [else
440                 (let* ([n (##sys#size x)]
441                        [bytes
442                         (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
443                              (##core#inline "C_bytes" 1) ) ] )
444                   (##sys#hash-table-set! tab x #t)
445                   (unless (##core#inline "C_byteblockp" x)
446                     (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
447                                 1 
448                                 0)
449                             (fx+ i 1) ] )
450                         ((fx>= i n))
451                       (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
452                   bytes) ] ) ) ) ) )
453
454(define object-unevict
455    (lambda (x #!optional (full #f))
456      (define (err x)
457        (##sys#signal-hook #:type-error 'object-unevict "can not copy object" x) )
458      (let ([tab (##sys#make-vector evict-table-size '())])
459        (let copy ([x x])
460          (cond [(not (##core#inline "C_blockp" x)) x]
461                [(not (##core#inline "C_permanentp" x)) x]
462                [(##sys#hash-table-ref tab x)]
463                [(##core#inline "C_byteblockp" x) 
464                 (if full
465                     (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
466                       (##sys#hash-table-set! tab x y)
467                       y) 
468                     x) ]
469                [(symbol? x) 
470                 (let ([y (##sys#intern-symbol (##sys#slot x 1))])
471                   (##sys#hash-table-set! tab x y)
472                   y) ]
473                [else
474                 (let* ([words (##sys#size x)]
475                        [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
476                   (##sys#hash-table-set! tab x y)
477                   (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
478                       ((fx>= i words))
479                     (##sys#setslot y i (copy (##sys#slot y i))) )
480                   y) ] ) ) ) ) )
481
482
483;;; `become':
484
485(define object-become! 
486  (cond-expand
487   [unsafe ##sys#become!]
488   [else
489    (lambda (lst)
490      (##sys#check-list lst 'object-become!)
491      (let loop ([lst lst])
492        (cond [(null? lst)]
493              [(pair? lst)
494               (let ([a (##sys#slot lst 0)])
495                 (##sys#check-pair a 'object-become!)
496                 (unless (##core#inline "C_blockp" (##sys#slot a 0))
497                   (##sys#signal-hook #:type-error 'object-become! "bad argument type - old item is immediate" a) )
498                 (unless (##core#inline "C_blockp" (##sys#slot a 1))
499                   (##sys#signal-hook #:type-error 'object-become! "bad argument type - new item is immediate" a) )
500                 (loop (##sys#slot lst 1)) ) ]
501              [else (##sys#signal-hook #:type-error 'object-become! "bad argument type - not an a-list")] ) )
502      (##sys#become! lst) ) ] ) )
503
504(define (mutate-procedure old proc)
505  (unless (##core#check (procedure? old))
506    (##sys#signal-hook #:type-error 'mutate-procedure "bad argument type - not a procedure" old))
507  (let* ((n (##sys#size old))
508         (words (##core#inline "C_words" n))
509         (y (##core#inline "C_copy_block" old (##sys#make-vector words))) )
510    (##sys#become! (list (cons old (proc y))))
511    y) )
512
513
514;;; locatives:
515
516(define (make-locative obj . index)
517  (##sys#make-locative obj (optional index 0) #f 'make-locative) )
518
519(define (make-weak-locative obj . index)
520  (##sys#make-locative obj (optional index 0) #t 'make-weak-locative) )
521
522(define (locative-set! x y) (##core#inline "C_i_locative_set" x y))
523(define locative-ref (getter-with-setter (##core#primitive "C_locative_ref") locative-set!))
524(define (locative->object x) (##core#inline "C_i_locative_to_object" x))
525(define (locative? x) (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x)))
526
527
528;;; Hooks:
529
530(define ipc-hook-0 #f)                  ; we need this because `##sys#invalid-procedure-call-hook' may not have free variables.
531
532(define (set-invalid-procedure-call-handler! proc)
533  (unless (procedure? proc)
534    (##sys#signal-hook #:type-error 'set-invalid-procedure-call-handler! "bad argument type - not a procedure" proc) )
535  (set! ipc-hook-0 proc)
536  (set! ##sys#invalid-procedure-call-hook 
537    (lambda args
538      (ipc-hook-0 ##sys#last-invalid-procedure args) ) ) )
539
540(define (unbound-variable-value . val)
541  (set! ##sys#unbound-variable-value-hook 
542    (and (pair? val)
543         (vector (car val)) ) ) )
544
545
546;;; Access computed globals:
547
548(define (global-ref sym)
549  (##sys#check-symbol sym 'global-ref)
550  (##core#inline "C_retrieve" sym) )
551
552(define (global-set! sym x)
553  (##sys#check-symbol sym 'global-set!)
554  (##sys#setslot sym 0 x) )
555
556(define (global-bound? sym)
557  (##sys#check-symbol sym 'global-bound?)
558  (##sys#symbol-has-toplevel-binding? sym) )
559
560(define (global-make-unbound! sym)
561  (##sys#check-symbol sym 'global-make-unbound!)
562  (##sys#setslot sym 0 (##sys#slot '##sys#arbitrary-unbound-symbol 0))
563  sym)
Note: See TracBrowser for help on using the repository browser.