Changeset 13134 in project for chicken


Ignore:
Timestamp:
01/29/09 21:14:21 (11 years ago)
Author:
Kon Lovett
Message:

manifest : added tests/lolevel-tests.scm
lolevel.scm : added local argument check procs, mvd 'C_pointer_to_object' to "chicken.h", made tagged-pointer a "pointer object", added 'pointer-like?' predicate, added block checks to 'move-memory!', combined like defines, 'align-to-word' takes integers & not numbers, use of common errmsgs, added layout comments, chgd use of '#+' to 'cond-expand', added 'record-instance' specific procs
extras.scm : use of '##sys#write-char-0' since types known, use of '(void)' instead of '(##core#undefined)'
chicken.h : added 'C_pointer_to_object' since used by a compiler rewrite
csi.scm : use of '(void)' instead of '(##core#undefined)'
manual/Unit lolevel : added discussion of "pointer" vs. "pointer-like', doc for new procs
manual/Data representation : no real change, going to expand
posixunix.scm : use of '(void)' instead of '(##core#undefined)'
support.scm : use of '(void)' instead of '(##core#undefined)'
scheduler.scm : use of '(void)' instead of '(##core#undefined)'
posixwin.scm : use of '(void)' instead of '(##core#undefined)'
tests/lolevel-tests.scm, tests/runtests.sh : added some Unit lolevel tests
srfi-18.scm : use of '(void)' instead of '(##core#undefined)'
srfi-4.scm : use of '##sys#write-char-0' since types known
tcp.scm : use of '(void)' instead of '(##core#undefined)'
eval.scm : use of '(void)' instead of '(##core#undefined)'
data-structures.scm : use of '(void)' instead of '(##core#undefined)'

Location:
chicken/branches/chicken-3
Files:
1 added
17 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/chicken-3/chicken.h

    r13055 r13134  
    914914#define C_update_pointer(p, ptr)        (C_set_block_item(ptr, 0, C_num_to_unsigned_int(p)), C_SCHEME_UNDEFINED)
    915915#define C_copy_pointer(from, to)        (C_set_block_item(to, 0, C_u_i_car(from)), C_SCHEME_UNDEFINED)
     916#define C_pointer_to_object(ptr)        ((C_word*)C_block_item(ptr, 0))
    916917
    917918#define C_direct_return(dk, x)          (C_kontinue(dk, x), C_SCHEME_UNDEFINED)
  • chicken/branches/chicken-3/csi.scm

    r10792 r13134  
    555555            (when (##sys#fudge 14) (display "interrupts are enabled\n"))
    556556            (when (##sys#fudge 15) (display "symbol gc is enabled\n"))
    557             (##core#undefined) ) ) ) ) ) )
     557            (void) ) ) ) ) ) )
    558558
    559559
  • chicken/branches/chicken-3/data-structures.scm

    r10509 r13134  
    867867          (else (##sys#setslot (##sys#slot q 2) 1 new-pair)) )
    868868    (##sys#setslot q 2 new-pair)
    869     (##core#undefined) ) )
     869    (void) ) )
    870870
    871871(define queue-remove!
  • chicken/branches/chicken-3/distribution/manifest

    r13014 r13134  
    226226tests/port-tests.scm
    227227tests/test-gc-hook.scm
     228tests/lolevel-tests.scm
    228229tweaks.scm
    229230utils.scm
  • chicken/branches/chicken-3/eval.scm

    r11833 r13134  
    12121212                                results) ) ) ) ) ) )
    12131213                    (lambda () (close-input-port in)) ) ) ) ) ) )
    1214         (##core#undefined) ) ) )
     1214        (void) ) ) )
    12151215  (set! load
    12161216    (lambda (filename . evaluator)
     
    21412141
    21422142      (define (write-results xs)
    2143         (unless (or (null? xs) (eq? (##core#undefined) (car xs)))
     2143        (unless (or (null? xs) (eq? (void) (car xs)))
    21442144          (for-each (cut ##sys#repl-print-hook <> ##sys#standard-output) xs) ) )
    21452145
  • chicken/branches/chicken-3/extras.scm

    r10827 r13134  
    256256                           (get-output-string str)
    257257                           (begin
    258                              (##sys#write-char/port c str)
     258                             (##sys#write-char-0 c str)
    259259                             (loop (and n (fx- n 1))) ) ) ) ) ) ) ) ) ) ) )
    260260
     
    628628  (let ((port (if (pair? opt) (car opt) (current-output-port))))
    629629    (generic-write obj #f (pretty-print-width) (lambda (s) (display s port) #t))
    630     (##core#undefined) ) )
     630    (void) ) )
    631631
    632632(define pp pretty-print)
  • chicken/branches/chicken-3/lolevel.scm

    r10004 r13134  
    3030  (usual-integrations)
    3131  (disable-warning var redef)
    32   (hide ipc-hook-0 xproc-tag)
     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   ##sys#tagged-pointer? )
    3338  (foreign-declare #<<EOF
    3439#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__)
     
    3944#endif
    4045
    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))
     46#define C_w2b(x)                   C_fix(C_wordstobytes(C_unfix(x)))
     47#define C_pointer_eqp(x, y)        C_mk_bool(C_c_pointer_nn(x) == C_c_pointer_nn(y))
    4448#define C_memmove_o(to, from, n, toff, foff) C_memmove((char *)(to) + (toff), (char *)(from) + (foff), (n))
    4549EOF
     
    5357    (no-procedure-checks-for-usual-bindings)
    5458    (bound-to-procedure
     59     ##sys#check-pointer ##sys#check-closure ##sys#check-integer ##sys#check-special
     60     ##sys#error ##sys#signal-hook
     61     ##sys#not-a-proper-list-error
    5562     ##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     ##sys#make-pointer ##sys#make-tagged-pointer ##sys#make-locative ##sys#locative?
     64     ##sys#become!
     65     ##sys#make-string ##sys#make-vector ##sys#vector->closure!
     66     make-property-condition make-composite-condition signal
     67     ##sys#generic-structure?
     68     ##sys#set-pointer-address! ##sys#address->pointer ##sys#pointer->address
     69     ##sys#lambda-decoration ##sys#decorate-lambda
     70     extend-procedure ) ) ] )
     71
     72(define (##sys#check-block x . loc)
     73  (unless (##core#inline "C_blockp" x)
     74    (##sys#error-hook
     75     (foreign-value "C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR" int) (and (pair? loc) (car loc))
     76     x) ) )
     77
     78(define (##sys#check-become-alist x loc)
     79  (##sys#check-list x loc)
     80  (let loop ([lst x])
     81    (cond [(null? lst) ]
     82          [(pair? lst)
     83           (let ([a (car lst)])
     84             (##sys#check-pair a loc)
     85             (##sys#check-block (car a) loc)
     86             (##sys#check-block (cdr a) loc)
     87             (loop (cdr lst)) ) ]
     88          [else
     89           (##sys#signal-hook
     90            #:type-error loc
     91            "bad argument type - not an a-list of non-immediate objects" x) ] ) ) )
     92
     93(define (##sys#check-generic-structure x . loc)
     94  (unless (and (##core#inline "C_blockp" x) (##core#inline "C_structurep" x) )
     95    (##sys#signal-hook
     96     #:type-error (and (pair? loc) (car loc))
     97     "bad argument type - not a structure" x) ) )
     98
     99;; Vector, Structure, Pair, and Symbol
     100
     101(define (##sys#check-generic-vector x . loc)
     102  (when (or (not (##core#inline "C_blockp" x))
     103            (##core#inline "C_specialp" x)
     104            (##core#inline "C_byteblockp" x) )
     105    (##sys#signal-hook
     106     #:type-error (and (pair? loc) (car loc))
     107     "bad argument type - not a vector-like object" x) ) )
    63108
    64109(cond-expand
    65110 [unsafe
    66111  (eval-when (compile)
     112    (define-macro (##sys#check-block . _) '(##core#undefined))
     113    (define-macro (##sys#check-alist . _) '(##core#undefined))
     114    (define-macro (##sys#check-generic-structure . _) '(##core#undefined))
     115    (define-macro (##sys#check-generic-vector . _) '(##core#undefined))
    67116    (define-macro (##sys#check-structure . _) '(##core#undefined))
    68     (define-macro (##sys#check-range . _) '(##core#undefined))
     117    (define-macro (##sys#check-blob . _) '(##core#undefined))
     118    (define-macro (##sys#check-byte-vector . _) '(##core#undefined))
    69119    (define-macro (##sys#check-pair . _) '(##core#undefined))
    70120    (define-macro (##sys#check-list . _) '(##core#undefined))
     121    (define-macro (##sys#check-string . _) '(##core#undefined))
     122    (define-macro (##sys#check-number . _) '(##core#undefined))
     123    (define-macro (##sys#check-integer . _) '(##core#undefined))
     124    (define-macro (##sys#check-exact . _) '(##core#undefined))
     125    (define-macro (##sys#check-inexact . _) '(##core#undefined))
    71126    (define-macro (##sys#check-symbol . _) '(##core#undefined))
    72     (define-macro (##sys#check-string . _) '(##core#undefined))
     127    (define-macro (##sys#check-vector . _) '(##core#undefined))
    73128    (define-macro (##sys#check-char . _) '(##core#undefined))
    74     (define-macro (##sys#check-exact . _) '(##core#undefined))
     129    (define-macro (##sys#check-closure . _) '(##core#undefined))
    75130    (define-macro (##sys#check-port . _) '(##core#undefined))
    76     (define-macro (##sys#check-number . _) '(##core#undefined))
    77131    (define-macro (##sys#check-pointer . _) '(##core#undefined))
    78132    (define-macro (##sys#check-special . _) '(##core#undefined))
    79     (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
     133    (define-macro (##sys#check-range . _) '(##core#undefined))
     134    (define-macro (##sys#check-port-open . _) '(##core#undefined))
     135    (define-macro (##sys#check-port-mode . _) '(##core#undefined))
     136    (define-macro (##sys#check-port/open . _) '(##core#undefined))
     137    (define-macro (##sys#check-port/open-in-mode . _) '(##core#undefined)) ) ]
    80138 [else
    81139  (declare (emit-exports "lolevel.exports"))] )
     
    85143
    86144;;; Move arbitrary blocks of memory around:
     145
     146(define (##sys#tagged-pointer? x) (##core#inline "C_taggedpointerp" x))
     147
     148(define-inline (%allocated-object-pointer? x)
     149  (or (##sys#pointer? x)
     150      (##sys#tagged-pointer? x)
     151      (##sys#locative? x) ) )
    87152
    88153(define move-memory!
     
    91156        [memmove3 (foreign-lambda void "C_memmove_o" scheme-pointer c-pointer int int int)]
    92157        [memmove4 (foreign-lambda void "C_memmove_o" scheme-pointer scheme-pointer int int int)]
    93         [slot1structs '(mmap u8vector u16vector u32vector s8vector s16vector s32vector f32vector f64vector)] )
     158        [typerr (lambda (x)
     159                  (##sys#error-hook
     160                   (foreign-value "C_BAD_ARGUMENT_TYPE_ERROR" int)
     161                   'move-memory! x))]
     162        [slot1structs '(mmap
     163                        u8vector u16vector u32vector s8vector s16vector s32vector
     164                        f32vector f64vector)] )
    94165    (lambda (from to #!optional n (foffset 0) (toffset 0))
    95       (define (err) (##sys#error 'move-memory! "need number of bytes to move" from to))
    96       (define (xerr x) (##sys#signal-hook #:type-error 'move-memory! "invalid argument type" x))
    97       (define (checkn n nmax off)
     166      ;
     167      (define (nosizerr)
     168        (##sys#error 'move-memory! "need number of bytes to move" from to))
     169      ;
     170      (define (sizerr . args)
     171        (apply ##sys#error 'move-memory! "number of bytes to move too large" from to args)
     172      ;
     173      (define (checkn1 n nmax off)
    98174        (if (cond-expand [unsafe #t] [else (fx<= n (fx- nmax off))])
    99175            n
    100             (##sys#error 'move-memory! "number of bytes to move too large" from to n nmax) ) )
     176            (sizerr n nmax) ) )
     177      ;
    101178      (define (checkn2 n nmax nmax2 off1 off2)
    102179        (if (cond-expand [unsafe #t] [else (and (fx<= n (fx- nmax off1)) (fx<= n (fx- nmax2 off2)))])
    103180            n
    104             (##sys#error 'move-memory! "number of bytes to move too large" from to n nmax nmax2) ) )
     181            (sizerr n nmax nmax2) ) )
     182      ;
     183      (##sys#check-block from 'move-memory!)
     184      (##sys#check-block to 'move-memory!)
    105185      (let move ([from from] [to to])
    106186        (cond [(##sys#generic-structure? from)
    107187               (if (memq (##sys#slot from 0) slot1structs)
    108188                   (move (##sys#slot from 1) to)
    109                    (xerr from) ) ]
     189                   (typerr from) ) ]
    110190              [(##sys#generic-structure? to)
    111191               (if (memq (##sys#slot to 0) slot1structs)
    112192                   (move from (##sys#slot to 1))
    113                    (xerr to) ) ]
    114               [(or (##sys#pointer? from) (##sys#locative? from))
    115                (cond [(or (##sys#pointer? to) (##sys#locative? to))
    116                       (memmove1 to from (or n (err)) toffset foffset)]
     193                   (typerr to) ) ]
     194              [(%allocated-object-pointer? from)
     195               (cond [(%allocated-object-pointer? to)
     196                      (memmove1 to from (or n (nosizerr)) toffset foffset)]
    117197                     [(or (##sys#bytevector? to) (string? to))
    118                       (memmove3 to from (checkn (or n (err)) (##sys#size to) toffset) toffset foffset) ]
    119                      [else (xerr to)] ) ]
     198                      (memmove3 to from (checkn1 (or n (nosizerr)) (##sys#size to) toffset) toffset foffset) ]
     199                     [else
     200                      (typerr to)] ) ]
    120201              [(or (##sys#bytevector? from) (string? from))
    121202               (let ([nfrom (##sys#size from)])
    122                  (cond [(or (##sys#pointer? to) (##sys#locative? to))
    123                         (memmove2 to from (checkn (or n nfrom) nfrom foffset) toffset foffset)]
     203                 (cond [(%allocated-object-pointer? to)
     204                        (memmove2 to from (checkn1 (or n nfrom) nfrom foffset) toffset foffset)]
    124205                       [(or (##sys#bytevector? to) (string? to))
    125206                        (memmove4 to from (checkn2 (or n nfrom) nfrom (##sys#size to) foffset toffset)
    126207                                  toffset foffset) ]
    127                        [else (xerr to)] ) ) ]
    128               [else (xerr from)] ) ) ) ) )
     208                       [else
     209                        (typerr to)] ) ) ]
     210              [else
     211               (typerr from)] ) ) ) ) ) )
     212
     213
     214;;; Copy arbitrary object:
     215
     216(define (object-copy x)
     217  (let copy ([x x])
     218    (cond [(not (##core#inline "C_blockp" x)) x]
     219          [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
     220          [else
     221            (let* ([n (##sys#size x)]
     222                   [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)]
     223                   [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
     224              (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
     225                (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
     226                    [(fx>= i n)]
     227                  (##sys#setslot y i (copy (##sys#slot y i))) ) )
     228              y) ] ) ) )
    129229
    130230
    131231;;; Pointer operations:
    132232
    133 (define (##sys#check-pointer ptr loc)
    134   (unless (and (##core#inline "C_blockp" ptr)
    135                (or (##core#inline "C_pointerp" ptr)
    136                    (##core#inline "C_swigpointerp" ptr)
    137                    (##core#inline "C_taggedpointerp" ptr) ) )
    138     (##sys#signal-hook #:type-error loc "bad argument type - not a pointer" ptr) ) )
    139 
    140 (define null-pointer ##sys#null-pointer)
     233(define allocate (foreign-lambda c-pointer "C_malloc" int))
     234(define free (foreign-lambda void "C_free" c-pointer))
    141235
    142236(define (pointer? x)
    143237  (and (##core#inline "C_blockp" x)
    144        (or (##core#inline "C_pointerp" x)
    145            (##core#inline "C_taggedpointerp" x) ) ) )
     238       (or (##core#inline "C_taggedpointerp" x)
     239           (##core#inline "C_pointerp" x) ) ) )
     240
     241(define (pointer-like? x)
     242  (and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x) ) )
    146243
    147244(define (address->pointer addr)
    148   (cond-expand
    149    [(not unsafe)
    150     (when (not (integer? addr))
    151       (##sys#signal-hook #:type-error 'address->pointer "bad argument type - not an integer" addr) ) ]
    152    [else] )
     245  (##sys#check-integer addr 'address->pointer)
    153246  (##sys#address->pointer addr) )
    154247
     
    157250  (##sys#pointer->address ptr) )
    158251
     252(define null-pointer ##sys#null-pointer)
     253
    159254(define (null-pointer? ptr)
    160255  (##sys#check-special ptr 'null-pointer?)
     
    163258(define (object->pointer x)
    164259  (and (##core#inline "C_blockp" x)
    165        ((foreign-lambda* nonnull-c-pointer ((scheme-object x))
    166           "return((void *)x);")
    167         x) ) )
     260       ((foreign-lambda* nonnull-c-pointer ((scheme-object x)) "return((void *)x);") x) ) )
    168261
    169262(define (pointer->object ptr)
     
    176269  (##core#inline "C_pointer_eqp" p1 p2) )
    177270
    178 (define allocate (foreign-lambda c-pointer "C_malloc" int))
    179 (define free (foreign-lambda void "C_free" c-pointer))
     271(define pointer-offset
     272  (foreign-lambda* nonnull-c-pointer ([c-pointer ptr] [integer off])
     273    "return((unsigned char *)ptr + off);") )
    180274
    181275(define align-to-word
    182276  (let ([align (foreign-lambda integer "C_align" integer)])
    183277    (lambda (x)
    184       (cond [(number? x) (align x)]
     278      (cond [(integer? x)
     279             (align x)]
    185280            [(and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x))
    186281             (##sys#address->pointer (align (##sys#pointer->address x))) ]
    187             [else (##sys#signal-hook #:type-error 'align-to-word "bad argument type - not a pointer or fixnum" x)] ) ) ) )
    188 
    189 (define pointer-offset
    190   (foreign-lambda* nonnull-c-pointer ([c-pointer ptr] [integer off])
    191     "return((unsigned char *)ptr + off);") )
     282            [else
     283             (##sys#signal-hook
     284              #:type-error 'align-to-word
     285              "bad argument type - not a pointer or integer" x)] ) ) ) )
    192286
    193287(define pointer-u8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned char *)p) = n;"))
     
    240334   pointer-f64-set!) )
    241335
     336;;; Tagged-pointers:
     337
    242338(define (tag-pointer ptr tag)
    243339  (let ([tp (##sys#make-tagged-pointer tag)])
    244340    (if (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr))
    245341        (##core#inline "C_copy_pointer" ptr tp)
    246         (##sys#signal-hook #:type-error 'tag-pointer "bad argument type - not a pointer" ptr) )
     342        (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'tag-pointer ptr) )
    247343    tp) )
    248344
    249 (define (tagged-pointer? x tag)
    250   (and (##core#inline "C_blockp" x)
    251        (##core#inline "C_taggedpointerp" x)
    252        (equal? tag (##sys#slot x 1)) ) )
     345(define (tagged-pointer? x #!optional tag)
     346  (and (##core#inline "C_blockp" x)  (##core#inline "C_taggedpointerp" x)
     347       (or (not tag)
     348           (equal? tag (##sys#slot x 1)) ) ) )
    253349
    254350(define (pointer-tag x)
     
    256352      (and (##core#inline "C_taggedpointerp" x)
    257353           (##sys#slot x 1) )
    258       (##sys#signal-hook #:type-error 'pointer-tag "bad argument type - not a pointer" x) ) )
     354      (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'pointer-tag x) ) )
     355
     356
     357;;; locatives:
     358
     359;; Locative layout:
     360;
     361; 0     Object-address + Byte-offset (address)
     362; 1     Byte-offset (fixnum)
     363; 2     Type (fixnum)
     364;       0       vector or pair          (C_SLOT_LOCATIVE)
     365;       1       string                  (C_CHAR_LOCATIVE)
     366;       2       u8vector                (C_U8_LOCATIVE)
     367;       3       s8vector or blob        (C_U8_LOCATIVE)
     368;       4       u16vector               (C_U16_LOCATIVE)
     369;       5       s16vector               (C_S16_LOCATIVE)
     370;       6       u32vector               (C_U32_LOCATIVE)
     371;       7       s32vector               (C_S32_LOCATIVE)
     372;       8       f32vector               (C_F32_LOCATIVE)
     373;       9       f64vector               (C_F64_LOCATIVE)
     374; 3     Object or #f, if weak (C_word)
     375
     376(define (make-locative obj . index)
     377  (##sys#make-locative obj (:optional index 0) #f 'make-locative) )
     378
     379(define (make-weak-locative obj . index)
     380  (##sys#make-locative obj (:optional index 0) #t 'make-weak-locative) )
     381
     382(define (locative-set! x y) (##core#inline "C_i_locative_set" x y))
     383(define locative-ref (getter-with-setter (##core#primitive "C_locative_ref") locative-set!))
     384(define (locative->object x) (##core#inline "C_i_locative_to_object" x))
     385(define (locative? x) (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x)))
    259386
    260387
    261388;;; Procedures extended with data:
    262389
     390; Unique id for extended-procedures
    263391(define xproc-tag (vector 'extended))
    264392
    265393(define (extend-procedure proc data)
    266   #+(not unsafe)
    267   (unless (##core#inline "C_closurep" proc)
    268     (##sys#signal-hook #:type-error 'extend-procedure "bad argument type - not a procedure" proc) )
     394  (##sys#check-closure proc 'extend-procedure)
    269395  (##sys#decorate-lambda
    270396   proc
    271397   (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0))))
    272    (lambda (x i)
    273      (##sys#setslot x i (cons xproc-tag data))
    274      x) ) )
     398   (lambda (x i) (##sys#setslot x i (cons xproc-tag data)) x) ) )
     399
     400(define-inline (%procedure-data proc)
     401  (##sys#lambda-decoration proc (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0))))) )
    275402
    276403(define (extended-procedure? x)
    277   (and (##core#inline "C_blockp" x)
    278        (##core#inline "C_closurep" x)
    279        (##sys#lambda-decoration x (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0)))))
     404  (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
     405       (%procedure-data x)
    280406       #t) )
    281407
    282408(define (procedure-data x)
    283   (and (##core#inline "C_blockp" x)
    284        (##core#inline "C_closurep" x)
    285        (and-let* ((d (##sys#lambda-decoration x (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0)))))))
     409  (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
     410       (and-let* ([d (%procedure-data x)])
    286411         (##sys#slot d 1) ) ) )
    287412
     
    292417        (if (eq? p2 proc)
    293418            proc
    294             (##sys#signal-hook #:type-error 'set-procedure-data! "bad argument type - not an extended procedure" proc) ) ) ) ) )
     419            (##sys#signal-hook
     420             #:type-error 'set-procedure-data!
     421             "bad argument type - not an extended procedure" proc) ) ) ) ) )
    295422
    296423
     
    377504       (foreign-lambda* scheme-object ((int size))
    378505         "char *bv;
    379            if((bv = (char *)C_malloc(size + 3 + sizeof(C_header))) == NULL) return(C_SCHEME_FALSE);
    380            bv = (char *)C_align((C_word)bv);
    381            ((C_SCHEME_BLOCK *)bv)->header = C_BYTEVECTOR_TYPE | size;
    382            return((C_word)bv);") ] )
     506           if((bv = (char *)C_malloc(size + 3 + sizeof(C_header))) == NULL) return(C_SCHEME_FALSE);
     507           bv = (char *)C_align((C_word)bv);
     508           ((C_SCHEME_BLOCK *)bv)->header = C_BYTEVECTOR_TYPE | size;
     509           return((C_word)bv);") ] )
    383510  (define (make size init alloc loc)
    384511    (##sys#check-exact size loc)
    385512    (if (fx> size _c_header_size_mask)
    386         (##sys#signal-hook #:bounds-error loc "out of range" size _c_header_size_mask)
     513        (error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int) loc size _c_header_size_mask)
    387514        (let ([bv (alloc size)])
    388515          (cond [bv
     
    390517                 bv]
    391518                [else (##sys#signal-hook #:runtime-error "can not allocate statically allocated bytevector" size)] ) ) ) )
    392   (set! make-static-byte-vector         ; DEPRECATED
     519  (set! make-static-byte-vector         ; DEPRECATED
    393520    (lambda (size . init) (make size init malloc 'make-static-byte-vector))))
    394521
    395 (define static-byte-vector->pointer             ; DEPRECATED
     522(define static-byte-vector->pointer             ; DEPRECATED
    396523  (lambda (bv)
    397524    (##sys#check-byte-vector bv 'static-byte-vector->pointer)
     
    404531(define (byte-vector-move! src src-start src-end dst dst-start) ; DEPRECATED
    405532  (let ((from (make-locative src src-start))
    406         (to   (make-locative dst dst-start)) )
     533        (to   (make-locative dst dst-start)) )
    407534    (move-memory! from to (- src-end src-start)) ) )
    408535
     
    410537  (define (append-rest-at i vectors)
    411538    (if (pair? vectors)
    412         (let* ((src (car vectors))
    413                (len (byte-vector-length src))
    414                (dst (append-rest-at (+ i len) (cdr vectors))) )
    415           (byte-vector-move! src 0 len dst i)
    416           dst )
    417         (make-byte-vector i) ) )
     539        (let* ((src (car vectors))
     540               (len (byte-vector-length src))
     541               (dst (append-rest-at (+ i len) (cdr vectors))) )
     542          (byte-vector-move! src 0 len dst i)
     543          dst )
     544        (make-byte-vector i) ) )
    418545  (append-rest-at 0 vectors) )
    419546
    420547
    421 ;;; Accessors for arbitrary block objects:
     548;;; Accessors for arbitrary vector-like block objects:
    422549
    423550(define block-set! ##sys#block-set!)
    424551(define block-ref (getter-with-setter ##sys#block-ref ##sys#block-set!))
    425552
    426 (define number-of-slots
    427   (lambda (x)
    428     (when (or (not (##core#inline "C_blockp" x))
    429               (##core#inline "C_specialp" x)
    430               (##core#inline "C_byteblockp" x) )
    431       (##sys#signal-hook #:type-error 'number-of-slots "slots not accessible" x) )
    432     (##sys#size x) ) )
     553(define (number-of-slots x)
     554  (##sys#check-generic-vector x 'number-of-slots)
     555  (##sys#size x) )
    433556
    434557(define (number-of-bytes x)
    435558  (cond [(not (##core#inline "C_blockp" x))
    436          (##sys#signal-hook #:type-error 'number-of-bytes "can not compute number of bytes of immediate object" x) ]
    437         [(##core#inline "C_byteblockp" x) (##sys#size x)]
    438         [else (##core#inline "C_w2b" (##sys#size x))] ) )
     559         (##sys#signal-hook
     560          #:type-error 'number-of-bytes
     561          "can not compute number of bytes of immediate object" x) ]
     562        [(##core#inline "C_byteblockp" x)
     563         (##sys#size x)]
     564        [else
     565         (##core#inline "C_w2b" (##sys#size x))] ) )
    439566
    440567
    441568;;; Record objects:
     569
     570;; Record layout:
     571;
     572; 0     Tag (symbol)
     573; 1..N  Slot (object)
    442574
    443575(define (make-record-instance type . args)
     
    445577  (apply ##sys#make-structure type args) )
    446578
    447 (define (record-instance? x)
    448   (and (##core#inline "C_blockp" x)
    449        (##core#inline "C_structurep" x) ) )
     579(define (record-instance? x #!optional type)
     580  (and (##core#inline "C_blockp" x) (##core#inline "C_structurep" x)
     581       (or (not type)
     582           (eq? type (##sys#slot x 0)) ) ) )
     583
     584(define (record-instance-type x)
     585  (##sys#check-generic-structure x 'record-instance-type)
     586  (##sys#slot x 0) )
     587
     588(define (record-instance-length x)
     589  (##sys#check-generic-structure x 'record-instance-length)
     590  (fx- (##sys#size x) 1) )
     591
     592(define (record-instance-slot-set! x i y)
     593  (##sys#check-generic-structure x 'record-instance-slot-set!)
     594  (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot-set!)
     595  (##sys#setslot x (fx+ i 1) y) )
     596
     597(define record-instance-slot
     598  (getter-with-setter
     599   (lambda (x i)
     600     (##sys#check-generic-structure x 'record-instance-slot)
     601     (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot)
     602     (##sys#slot x (fx+ i 1)) )
     603   record-instance-slot-set!))
    450604
    451605(define (record->vector x)
    452   (if (and (not (##sys#immediate? x)) (##sys#generic-structure? x))
    453       (let* ([n (##sys#size x)]
    454              [v (##sys#make-vector n)] )
    455         (do ([i 0 (fx+ i 1)])
    456             ((fx>= i n) v)
    457           (##sys#setslot v i (##sys#slot x i)) ) )
    458       (##sys#signal-hook #:type-error 'record->vector "bad argument type - not a record structure" x) ) )
    459 
    460 
    461 ;;; Copy arbitrary object:
    462 
    463 (define (object-copy x)
    464   (let copy ([x x])
    465     (cond [(not (##core#inline "C_blockp" x)) x]
    466           [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
     606  (##sys#check-generic-structure x 'record->vector)
     607  (let* ([n (##sys#size x)]
     608         [v (##sys#make-vector n)] )
     609    (do ([i 0 (fx+ i 1)])
     610         [(fx>= i n) v]
     611      (##sys#setslot v i (##sys#slot x i)) ) ) )
     612
     613
     614;;; Evict objects into static memory:
     615
     616(define-constant evict-table-size 301)
     617
     618(define (object-evicted? x) (##core#inline "C_permanentp" x))
     619
     620(define (object-evict x . allocator)
     621  (let ([allocator
     622         (if (pair? allocator) (car allocator) (foreign-lambda c-pointer "C_malloc" int) ) ]
     623        [tab (##sys#make-vector evict-table-size '())] )
     624    (##sys#check-closure allocator 'object-evict)
     625    (let evict ([x x])
     626      (cond [(not (##core#inline "C_blockp" x)) x ]
     627            [(##sys#hash-table-ref tab x) ]
     628            [else
     629             (let* ([n (##sys#size x)]
     630                    [bytes (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))]
     631                    [y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))] )
     632               (when (symbol? x) (##sys#setislot y 0 (void)))
     633               (##sys#hash-table-set! tab x y)
     634               (unless (##core#inline "C_byteblockp" x)
     635                 (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
     636                     [(fx>= i n)]
     637                   ;; Note the use of `##sys#setislot' to avoid an entry in the mutations-table:
     638                   (##sys#setislot y i (evict (##sys#slot x i))) ) )
     639               y ) ] ) ) ) )
     640
     641(define (object-evict-to-location x ptr . limit)
     642  (cond-expand [(not unsafe) (##sys#check-special ptr 'object-evict-to-location)] [else])
     643  (let* ([limit (and (pair? limit)
     644                     (let ([limit (car limit)])
     645                       (##sys#check-exact limit 'object-evict-to-location)
     646                       limit)) ]
     647         [ptr2 (##sys#address->pointer (##sys#pointer->address ptr))]
     648         [tab (##sys#make-vector evict-table-size '())]
     649         [x2
     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
     656                           (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
     657                                (##core#inline "C_bytes" 1) ) ] )
     658                     (when limit
     659                       (set! limit (fx- limit bytes))
     660                       (when (fx< limit 0)
     661                         (signal
     662                          (make-composite-condition
     663                           (make-property-condition
     664                            'exn 'location 'object-evict-to-location
     665                            'message "can not evict object - limit exceeded"
     666                            'arguments (list x limit))
     667                           (make-property-condition 'evict 'limit limit) ) ) ) )
     668                   (let ([y (##core#inline "C_evict_block" x ptr2)])
     669                     (when (symbol? x) (##sys#setislot y 0 (void)))
     670                     (##sys#set-pointer-address! ptr2 (+ (##sys#pointer->address ptr2) bytes))
     671                     (##sys#hash-table-set! tab x y)
     672                     (unless (##core#inline "C_byteblockp" x)
     673                       (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)] )
     674                           [(fx>= i n)]
     675                         (##sys#setislot y i (evict (##sys#slot x i))) ) ) ; see above
     676                     y) ) ] ) ) ] )
     677    (values x2 ptr2) ) )
     678
     679(define (object-release x . releaser)
     680  (let ([free (if (pair? releaser)
     681                  (car releaser)
     682                  (foreign-lambda void "C_free" c-pointer) ) ]
     683        [released '() ] )
     684    (let release ([x x])
     685      (cond [(not (##core#inline "C_blockp" x)) x ]
     686            [(not (##core#inline "C_permanentp" x)) x ]
     687            [(memq x released) x ]
     688            [else
     689             (let ([n (##sys#size x)])
     690               (set! released (cons x released))
     691               (unless (##core#inline "C_byteblockp" x)
     692                 (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
     693                     [(fx>= i n)]
     694                   (release (##sys#slot x i))) )
     695               (free (##sys#address->pointer (##core#inline_allocate ("C_block_address" 4) x))) ) ] ) ) ) )
     696
     697(define (object-size x)
     698  (let ([tab (##sys#make-vector evict-table-size '())])
     699    (let evict ([x x])
     700      (cond [(not (##core#inline "C_blockp" x)) 0 ]
     701            [(##sys#hash-table-ref tab x) 0 ]
     702            [else
     703             (let* ([n (##sys#size x)]
     704                    [bytes
     705                     (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
     706                          (##core#inline "C_bytes" 1) ) ] )
     707               (##sys#hash-table-set! tab x #t)
     708               (unless (##core#inline "C_byteblockp" x)
     709                 (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
     710                     [(fx>= i n)]
     711                   (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
     712               bytes) ] ) ) ) )
     713
     714(define (object-unevict x #!optional full)
     715  (let ([tab (##sys#make-vector evict-table-size '())])
     716    (let copy ([x x])
     717    (cond [(not (##core#inline "C_blockp" x)) x ]
     718          [(not (##core#inline "C_permanentp" x)) x ]
     719          [(##sys#hash-table-ref tab x) ]
     720          [(##core#inline "C_byteblockp" x)
     721           (if full
     722               (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
     723                 (##sys#hash-table-set! tab x y)
     724                 y)
     725               x) ]
     726          [(symbol? x)
     727           (let ([y (##sys#intern-symbol (##sys#slot x 1))])
     728             (##sys#hash-table-set! tab x y)
     729             y) ]
    467730          [else
    468             (let* ([n (##sys#size x)]
    469                    [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)]
    470                    [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
    471               (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
    472                 (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
    473                     ((fx>= i n))
    474                   (##sys#setslot y i (copy (##sys#slot y i))) ) )
    475               y) ] ) ) )
    476 
    477 
    478 ;;; Evict objects into static memory:
    479 
    480 (define-constant evict-table-size 301)
    481 
    482 (define (object-evicted? x) (##core#inline "C_permanentp" x))
    483 
    484 (define object-evict
    485     (lambda (x . allocator)
    486       (let ([allocator
    487              (if (pair? allocator)
    488                  (car allocator)
    489                  (foreign-lambda c-pointer "C_malloc" int) ) ]
    490             [tab (##sys#make-vector evict-table-size '())] )
    491         (let evict ([x x])
    492           (cond [(not (##core#inline "C_blockp" x)) x]
    493                 [(##sys#hash-table-ref tab x)]
    494                 [else
    495                  (let* ([n (##sys#size x)]
    496                         [bytes (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))]
    497                         [y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))] )
    498                    (when (symbol? x) (##sys#setislot y 0 (##core#undefined)))
    499                    (##sys#hash-table-set! tab x y)
    500                    (unless (##core#inline "C_byteblockp" x)
    501                      (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
    502                          ((fx>= i n))
    503                        ;; Note the use of `##sys#setislot' to avoid an entry in the mutations-table:
    504                        (##sys#setislot y i (evict (##sys#slot x i))) ) )
    505                    y) ] ) ) ) ) )
    506 
    507 (define object-release
    508   (lambda (x . releaser)
    509     (let ((free (if (pair? releaser)
    510                     (car releaser)
    511                     (foreign-lambda void "C_free" c-pointer) ) )
    512           (released '()))
    513       (let release ([x x])
    514         (cond [(not (##core#inline "C_blockp" x)) x]
    515               [(not (##core#inline "C_permanentp" x)) x]
    516               ((memq x released) x)
    517               [else
    518                (let ([n (##sys#size x)])
    519                  (set! released (cons x released))
    520                  (unless (##core#inline "C_byteblockp" x)
    521                    (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
    522                        ((fx>= i n))
    523                      (release (##sys#slot x i))) )
    524                  (free (##sys#address->pointer (##core#inline_allocate ("C_block_address" 4) x))) ) ] ) ) ) ) )
    525 
    526 (define object-evict-to-location
    527     (lambda (x ptr . limit)
    528       (cond-expand
    529        [(not unsafe)
    530         (when (not (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr)))
    531           (##sys#signal-hook #:type-error 'object-evict-to-location "bad argument type - not a pointer" ptr) ) ]
    532        [else] )
    533       (let* ([limit
    534               (if (pair? limit)
    535                   (let ([limit (car limit)])
    536                     (##sys#check-exact limit 'object-evict-to-location)
    537                     limit)
    538                   #f) ]
    539              [ptr2 (##sys#address->pointer (##sys#pointer->address ptr))]
    540              [tab (##sys#make-vector evict-table-size '())]
    541              [x2
    542               (let evict ([x x])
    543                 (cond [(not (##core#inline "C_blockp" x)) x]
    544                       [(##sys#hash-table-ref tab x)]
    545                       [else
    546                        (let* ([n (##sys#size x)]
    547                               [bytes
    548                                (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
    549                                     (##core#inline "C_bytes" 1) ) ] )
    550                          (when limit
    551                            (set! limit (fx- limit bytes))
    552                            (when (fx< limit 0)
    553                              (signal
    554                               (make-composite-condition
    555                                (make-property-condition
    556                                 'exn 'location 'object-evict-to-location
    557                                 'message "can not evict object - limit exceeded"
    558                                 'arguments (list x limit))
    559                                (make-property-condition 'evict 'limit limit) ) ) ) )
    560                          (let ([y (##core#inline "C_evict_block" x ptr2)])
    561                            (when (symbol? x) (##sys#setislot y 0 (##core#undefined)))
    562                            (##sys#set-pointer-address! ptr2 (+ (##sys#pointer->address ptr2) bytes))
    563                            (##sys#hash-table-set! tab x y)
    564                            (unless (##core#inline "C_byteblockp" x)
    565                              (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
    566                                          1
    567                                          0)
    568                                      (fx+ i 1) ] )
    569                                  ((fx>= i n))
    570                                (##sys#setislot y i (evict (##sys#slot x i))) ) ) ; see above
    571                            y) ) ] ) ) ] )
    572         (values x2 ptr2) ) ) )
    573 
    574 (define object-size
    575     (lambda (x)
    576       (let ([tab (##sys#make-vector evict-table-size '())])
    577         (let evict ([x x])
    578           (cond [(not (##core#inline "C_blockp" x)) 0]
    579                 [(##sys#hash-table-ref tab x) 0]
    580                 [else
    581                  (let* ([n (##sys#size x)]
    582                         [bytes
    583                          (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
    584                               (##core#inline "C_bytes" 1) ) ] )
    585                    (##sys#hash-table-set! tab x #t)
    586                    (unless (##core#inline "C_byteblockp" x)
    587                      (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
    588                                  1
    589                                  0)
    590                              (fx+ i 1) ] )
    591                          ((fx>= i n))
    592                        (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
    593                    bytes) ] ) ) ) ) )
    594 
    595 (define object-unevict
    596     (lambda (x #!optional (full #f))
    597       (define (err x)
    598         (##sys#signal-hook #:type-error 'object-unevict "can not copy object" x) )
    599       (let ([tab (##sys#make-vector evict-table-size '())])
    600         (let copy ([x x])
    601           (cond [(not (##core#inline "C_blockp" x)) x]
    602                 [(not (##core#inline "C_permanentp" x)) x]
    603                 [(##sys#hash-table-ref tab x)]
    604                 [(##core#inline "C_byteblockp" x)
    605                  (if full
    606                      (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
    607                        (##sys#hash-table-set! tab x y)
    608                        y)
    609                      x) ]
    610                 [(symbol? x)
    611                  (let ([y (##sys#intern-symbol (##sys#slot x 1))])
    612                    (##sys#hash-table-set! tab x y)
    613                    y) ]
    614                 [else
    615                  (let* ([words (##sys#size x)]
    616                         [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
    617                    (##sys#hash-table-set! tab x y)
    618                    (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
    619                        ((fx>= i words))
    620                      (##sys#setslot y i (copy (##sys#slot y i))) )
    621                    y) ] ) ) ) ) )
     731           (let* ([words (##sys#size x)]
     732                  [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
     733             (##sys#hash-table-set! tab x y)
     734             (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
     735                 ((fx>= i words))
     736               (##sys#setslot y i (copy (##sys#slot y i))) )
     737             y) ] ) ) ) )
    622738
    623739
    624740;;; `become':
    625741
    626 (define object-become!
    627   (cond-expand
    628    [unsafe ##sys#become!]
    629    [else
    630     (lambda (lst)
    631       (##sys#check-list lst 'object-become!)
    632       (let loop ([lst lst])
    633         (cond [(null? lst)]
    634               [(pair? lst)
    635                (let ([a (##sys#slot lst 0)])
    636                  (##sys#check-pair a 'object-become!)
    637                  (unless (##core#inline "C_blockp" (##sys#slot a 0))
    638                    (##sys#signal-hook #:type-error 'object-become! "bad argument type - old item is immediate" a) )
    639                  (unless (##core#inline "C_blockp" (##sys#slot a 1))
    640                    (##sys#signal-hook #:type-error 'object-become! "bad argument type - new item is immediate" a) )
    641                  (loop (##sys#slot lst 1)) ) ]
    642               [else (##sys#signal-hook #:type-error 'object-become! "bad argument type - not an a-list")] ) )
    643       (##sys#become! lst) ) ] ) )
     742(define (object-become! alst)
     743  (cond-expand [(not unsafe) (##sys#check-become-alist alst 'object-become!)] [else])
     744  (##sys#become! alst) )
    644745
    645746(define (mutate-procedure old proc)
    646   (unless (##core#check (procedure? old))
    647     (##sys#signal-hook #:type-error 'mutate-procedure "bad argument type - not a procedure" old))
    648   (let* ((n (##sys#size old))
    649          (words (##core#inline "C_words" n))
    650          (y (##core#inline "C_copy_block" old (##sys#make-vector words))) )
    651     (##sys#become! (list (cons old (proc y))))
    652     y) )
    653 
    654 
    655 ;;; locatives:
    656 
    657 (define (make-locative obj . index)
    658   (##sys#make-locative obj (:optional index 0) #f 'make-locative) )
    659 
    660 (define (make-weak-locative obj . index)
    661   (##sys#make-locative obj (:optional index 0) #t 'make-weak-locative) )
    662 
    663 (define (locative-set! x y) (##core#inline "C_i_locative_set" x y))
    664 (define locative-ref (getter-with-setter (##core#primitive "C_locative_ref") locative-set!))
    665 (define (locative->object x) (##core#inline "C_i_locative_to_object" x))
    666 (define (locative? x) (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x)))
     747  (##sys#check-closure old 'mutate-procedure)
     748  (##sys#check-closure proc 'mutate-procedure)
     749  (let* ([n (##sys#size old)]
     750         [words (##core#inline "C_words" n)]
     751         [new (##core#inline "C_copy_block" old (##sys#make-vector words))] )
     752    (##sys#become! (list (cons old (proc new))))
     753    new ) )
    667754
    668755
     
    672759
    673760(define (set-invalid-procedure-call-handler! proc)
    674   (unless (procedure? proc)
    675     (##sys#signal-hook #:type-error 'set-invalid-procedure-call-handler! "bad argument type - not a procedure" proc) )
     761  (##sys#check-closure proc 'set-invalid-procedure-call-handler!)
    676762  (set! ipc-hook-0 proc)
    677763  (set! ##sys#invalid-procedure-call-hook
     
    682768  (set! ##sys#unbound-variable-value-hook
    683769    (and (pair? val)
    684          (vector (car val)) ) ) )
     770         (vector (car val)))) )
    685771
    686772
     
    702788  (##sys#check-symbol sym 'global-make-unbound!)
    703789  (##sys#setslot sym 0 (##sys#slot '##sys#arbitrary-unbound-symbol 0))
    704   sym)
     790  sym )
  • chicken/branches/chicken-3/manual/Data representation

    r6691 r13134  
    1111=== Immediate objects
    1212
    13 Immediate objects are represented by a single machine word, which is usually of 32 bits length, or 64 bits
    14 on 64-bit architectures.   The immediate objects
     13Immediate objects are represented by a single machine word, which is usually of
     1432 bits length, or 64 bits on 64-bit architectures.   The immediate objects
    1515come in four different flavors:
    1616
     
    2525is one for #t and zero for #f.
    2626
    27 '''other values''': the empty list, the value of unbound identifiers,
    28 the undefined value (void), and end-of-file.  Bits 1-4 are equal to {{C_SPECIAL_BITS}}; bits 5 to 8 contain an identifying
    29 number for this type of object.  The following constants are
    30 defined: {{C_SCHEME_END_OF_LIST C_SCHEME_UNDEFINED C_SCHEME_UNBOUND
    31 C_SCHEME_END_OF_FILE}}
     27'''other values''': the empty list, the value of unbound identifiers, the
     28undefined value (void), and end-of-file.  Bits 1-4 are equal to
     29{{C_SPECIAL_BITS}}; bits 5 to 8 contain an identifying number for this type of
     30object.  The following constants are defined: {{C_SCHEME_END_OF_LIST
     31C_SCHEME_UNDEFINED C_SCHEME_UNBOUND C_SCHEME_END_OF_FILE}}
    3232
    33 Collectively, bits 1 and 2 are known as the ''immediate mark bits''.  When bit 1 is set, the object is a fixnum, as described above, and bit 2 is part of its value.  When bit 1 is clear but bit 2 is set, it is an immediate object other than a fixnum.  If neither bit 1 nor bit 2 is set, the object is non-immediate, as described below.
     33Collectively, bits 1 and 2 are known as the ''immediate mark bits''.  When bit
     341 is set, the object is a fixnum, as described above, and bit 2 is part of its
     35value.  When bit 1 is clear but bit 2 is set, it is an immediate object other
     36than a fixnum.  If neither bit 1 nor bit 2 is set, the object is non-immediate,
     37as described below.
    3438
    3539=== Non-immediate objects
    3640
    37 Non-immediate objects are blocks of data represented by a pointer into
    38 the heap.  The pointer's immediate mark bits (bits 1 and 2) must be zero to indicate the object is non-immediate;
    39 this guarantees the data block is aligned on a 4-byte boundary, at minimum.  Alignment of data words
    40 is required on modern architectures anyway, so we get the ability to distinguish between immediate and non-immediate objects for free.
     41Non-immediate objects are blocks of data represented by a pointer into the
     42heap.  The pointer's immediate mark bits (bits 1 and 2) must be zero to
     43indicate the object is non-immediate; this guarantees the data block is aligned
     44on a 4-byte boundary, at minimum.  Alignment of data words is required on
     45modern architectures anyway, so we get the ability to distinguish between
     46immediate and non-immediate objects for free.
    4147
    4248The first word of the data block contains a header, which gives
  • chicken/branches/chicken-3/manual/Unit lolevel

    r12553 r13134  
    1212This unit uses the {{srfi-4}} and {{extras}} units.
    1313
     14
     15
    1416=== Foreign pointers
    1517
     18The abstract class of pointers is divided into 2 major categories: {{pointer
     19objects}} and {{pointer-like objects}}.
     20
     21A {{pointer object}} is a foreign pointer object or a tagged foreign pointer
     22object (see {{Tagged pointers}}).
     23
     24A {{pointer-like object}} may be a closure, port, locative (see {{Locatives}},
     25or a {{pointer object}}.
     26
     27SWIG pointers are currently second class citizens due to "bitrot" in the SWIG
     28Chicken translator. While they qualify as a {{c-pointer}} for foreign lambda
     29argument conversion they are not supported by the foreign pointer operations.
    1630
    1731
     
    2842 [procedure] (allocate BYTES)
    2943
    30 Returns a pointer to a freshly allocated region of static memory.
     44Returns a foreign pointer object to a freshly allocated region of static
     45memory.
     46
    3147This procedure could be defined as follows:
    3248
     
    4056 [procedure] (free POINTER)
    4157
    42 Frees the memory pointed to by {{POINTER}}.  This procedure could
    43 be defined as follows:
    44 
    45 <enscript highlight=scheme>
    46 (define free (foreign-lambda c-pointer "free" integer))
     58Frees the memory pointed to by {{POINTER}}.
     59
     60This procedure could be defined as follows:
     61
     62<enscript highlight=scheme>
     63(define free (foreign-lambda void "free" c-pointer))
    4764</enscript>
    4865
     
    5774==== null-pointer?
    5875
    59  [procedure] (null-pointer? PTR)
    60 
    61 Returns {{#t}} if {{PTR}} contains a {{NULL}} pointer,
     76 [procedure] (null-pointer? PTR*)
     77
     78Returns {{#t}} if the pointer-like object {{PTR*}} contains a {{NULL}} pointer,
    6279or {{#f}} otherwise.
    6380
     
    6784 [procedure] (object->pointer X)
    6885
    69 Returns a pointer pointing to the Scheme object X, which should be a
    70 non-immediate object.  Note that data in the garbage collected heap
    71 moves during garbage collection.
    72 
     86Returns a foreign pointer object pointing to the Scheme object X, which should
     87be a non-immediate object. ("foreign" here is a bit of a misnomer.)
     88
     89Note that data in the garbage collected heap moves during garbage collection.
     90
     91
     92==== pointer->object
     93
     94 [procedure] (pointer->object PTR)
     95
     96Returns the Scheme object pointed to by the pointer object {{PTR}}.
     97
     98Whether the {{PTR}} actually points to a Scheme object is not guaranteed. Use
     99at your own risk.
    73100
    74101==== pointer?
     
    76103 [procedure] (pointer? X)
    77104
    78 Returns {{#t}} if {{X}} is a foreign pointer object, and
    79 {{#f}} otherwise.
     105Returns {{#t}} if {{X}} is a pointer object, or {{#f}} otherwise.
     106
     107
     108==== pointer-like?
     109
     110 [procedure] (pointer-like? X)
     111
     112Returns {{#t}} if {{X}} is a pointer-like object, or {{#f}} otherwise.
     113
    80114
    81115==== pointer=?
    82116
    83  [procedure] (pointer=? PTR1 PTR2)
    84 
    85 Returns {{#t}} if the pointer-like objects {{PTR1}} and {{PTR2}} point
    86 to the same address.
    87 
     117 [procedure] (pointer=? PTR*1 PTR*2)
     118
     119Returns {{#t}} if the pointer-like objects {{PTR*1}} and {{PTR*2}} point
     120to the same address, or {{#f}} otherwise.
    88121
    89122
    90123==== pointer->address
    91124
    92  [procedure] (pointer->address PTR)
    93 
    94 Returns the address, to which the pointer {{PTR}} points.
    95 
    96 
    97 ==== pointer->object
    98 
    99  [procedure] (pointer->object PTR)
    100 
    101 Returns the Scheme object pointed to by the pointer {{PTR}}.
     125 [procedure] (pointer->address PTR*)
     126
     127Returns the address, to which the pointer-like object {{PTR*}} points.
    102128
    103129
    104130==== pointer-offset
    105131
    106  [procedure] (pointer-offset PTR N)
    107 
    108 Returns a new pointer representing the pointer {{PTR}} increased
    109 by {{N}}.
    110 
     132 [procedure] (pointer-offset PTR* N)
     133
     134Returns a new foreign pointer object representing the pointer-like object
     135{{PTR*}} address value increased by the byte-offset {{N}}.
     136
     137Use of anything other than a pointer object as an argument is questionable.
     138
     139
     140==== align-to-word
     141
     142 [procedure] (align-to-word PTR*-OR-INT)
     143
     144Accepts either a pointer-like object or an integer as the argument and returns
     145a new foreign pointer or integer aligned to the native word size of the host
     146platform.
     147
     148Use of anything other than an integer or pointer object as an argument is
     149questionable.
     150
     151
     152
     153=== SRFI-4 Foreign pointers
     154
     155These procedures actually accept a pointer-like object as the {{PTR}} argument.
     156However, as usual, use of anything other than a pointer object is questionable.
    111157
    112158==== pointer-u8-ref
     
    230276
    231277
    232 ==== align-to-word
    233 
    234  [procedure] (align-to-word PTR-OR-INT)
    235 
    236 Accepts either a machine pointer or an integer as argument and returns
    237 a new pointer or integer aligned to the native word size of the host
    238 platform.
    239 
    240 
    241 
    242 
    243278
    244279=== Tagged pointers
     
    247282
    248283
    249 
    250284==== tag-pointer
    251285
    252  [procedure] (tag-pointer PTR TAG)
    253 
    254 Creates a new tagged pointer object from the foreign pointer {{PTR}} with the
    255 tag {{TAG}}, which may an arbitrary Scheme object.
    256 
     286 [procedure] (tag-pointer PTR* TAG)
     287
     288Creates a new tagged foreign pointer object from the pointer-like object
     289{{PTR*}} with the tag {{TAG}}, which may an arbitrary Scheme object.
     290
     291Use of anything other than a pointer object is questionable.
    257292
    258293==== tagged-pointer?
    259294
    260  [procedure] (tagged-pointer? X TAG)
    261 
    262 Returns {{#t}}, if {{X}} is a tagged pointer object with the tag {{TAG}}
    263 (using an {{eq?}} comparison), or {{#f}} otherwise.
     295 [procedure] (tagged-pointer? X [TAG])
     296
     297Returns {{#t}} if {{X}} is a tagged foreign pointer object, or {{#f}} otherwise.
     298
     299Further, returns {{#t}} when {{X}} has the optional tag {{TAG}} (using an
     300{{equal?}} comparison), or {{#f}} otherwise.
    264301
    265302
    266303==== pointer-tag
    267304
    268  [procedure] (pointer-tag PTR)
    269 
    270 If {{PTR}} is a tagged pointer object, its tag is returned. If {{PTR}} is a normal,
    271 untagged foreign pointer object {{#f}} is returned. Otherwise an error is signalled.
    272 
    273 
     305 [procedure] (pointer-tag PTR*)
     306
     307If {{PTR}} is a tagged foreign pointer object, its tag is returned. If {{PTR*}}
     308is any other kind of pointer-like object {{#f}} is returned. Otherwise an
     309error is signalled.
     310
     311
     312
     313=== Locatives
     314
     315
     316A ''locative'' is an object that points to an element of a containing object,
     317much like a ''pointer'' in low-level, imperative programming languages like ''C''. The element can
     318be accessed and changed indirectly, by performing access or change operations
     319on the locative. The container object can be computed by calling the
     320{{location->object}} procedure.
     321
     322Locatives may be passed to foreign procedures that expect pointer arguments.
     323The effect of creating locatives for evicted data (see {{object-evict}}) is undefined.
     324
     325
     326==== make-locative
     327
     328 [procedure] (make-locative OBJ [INDEX])
     329
     330Creates a locative that refers to the element of the non-immediate object
     331{{OBJ}} at position {{INDEX}}. {{OBJ}} may be a vector, pair, string, blob,
     332SRFI-4 number-vector, or record structure. {{INDEX}} should be a fixnum.
     333{{INDEX}} defaults to 0.
     334
     335
     336==== make-weak-locative
     337
     338 [procedure] (make-weak-locative OBJ [INDEX])
     339
     340Creates a ''weak'' locative. Even though the locative refers to an element of a container object,
     341the container object will still be reclaimed by garbage collection if no other references
     342to it exist.
     343
     344
     345==== locative?
     346
     347 [procedure] (locative? X)
     348
     349Returns {{#t}} if {{X}} is a locative, or {{#f}} otherwise.
     350
     351
     352==== locative-ref
     353
     354 [procedure] (locative-ref LOC)
     355
     356Returns the element to which the locative {{LOC}} refers. If the containing
     357object has been reclaimed by garbage collection, an error is signalled.
     358
     359 (locative-ref (make-locative "abc" 1)) ==> #\b
     360
     361==== locative-set!
     362
     363 [procedure] (locative-set! LOC X)
     364 [procedure] (set! (locative-ref LOC) X)
     365
     366Changes the element to which the locative {{LOC}} refers to {{X}}.
     367If the containing
     368object has been reclaimed by garbage collection, an error is signalled.
     369
     370
     371==== locative->object
     372
     373 [procedure] (locative->object LOC)
     374
     375Returns the object that contains the element referred to by {{LOC}} or
     376{{#f}} if the container has been reclaimed by garbage collection.
     377
     378 (locative->object (make-locative "abc" 1)) ==> "abc"
    274379
    275380
     
    278383
    279384
    280 
    281 
    282385==== extend-procedure
    283386
    284387 [procedure] (extend-procedure PROCEDURE X)
    285388
    286 Returns a copy of the procedure {{PROCEDURE}} which contains an
    287 additional data slot initialized to {{X}}. If {{PROCEDURE}}
    288 is already an extended procedure, then its data slot is changed to
    289 contain {{X}} and the same procedure is returned.
     389Returns a copy of the procedure {{PROCEDURE}} which contains an additional data
     390slot initialized to {{X}}. If {{PROCEDURE}} is already an extended procedure,
     391then its data slot is changed to contain {{X}} and the same procedure is
     392returned. Signals an error when {{PROCEDURE}} is not a procedure.
    290393
    291394
     
    302405 [procedure] (procedure-data PROCEDURE)
    303406
    304 Returns the data object contained in the extended procedure {{PROCEDURE}},
    305 or {{#f}} if it is not an extended procedure.
     407Returns the data object contained in the extended procedure {{PROCEDURE}}, or
     408{{#f}} if it is not an extended procedure.
    306409
    307410
     
    310413 [procedure] (set-procedure-data! PROCEDURE X)
    311414
    312 Changes the data object contained in the extended procedure
    313 {{PROCEDURE}} to {{X}}.
     415Changes the data object contained in the extended procedure {{PROCEDURE}} to
     416{{X}}. Signals an error when {{PROCEDURE}} is not an extended procedure.
    314417
    315418<enscript highlight=scheme>
     
    329432
    330433
    331 
    332 
    333434==== object-evict
    334435
    335436 [procedure] (object-evict X [ALLOCATOR])
    336437
    337 Copies the object {{X}} recursively into the memory pointed
    338 to by the foreign pointer object returned by {{ALLOCATOR}},
    339 which should be a procedure of a single argument (the number of bytes
    340 to allocate). The freshly copied object is returned.  This facility
    341 allows moving arbitrary objects into static memory, but care should be
    342 taken when mutating evicted data: setting slots in evicted vector-like
    343 objects to non-evicted data is not allowed. It '''is''' possible to
     438Copies the object {{X}} recursively into the memory pointed to by the foreign
     439pointer object returned by {{ALLOCATOR}}, which should be a procedure of a
     440single argument (the number of bytes to allocate). The freshly copied object is
     441returned.
     442
     443This facility allows moving arbitrary objects into static memory, but care
     444should be taken when mutating evicted data: setting slots in evicted
     445vector-like objects to non-evicted data is not allowed. It '''is''' possible to
    344446set characters/bytes in evicted strings or byte-vectors, though.  It is
    345 advisable '''not''' to evict ports, because they might be mutated by
    346 certain file-operations.  {{object-evict}} is able to handle circular and
    347 shared structures, but evicted symbols are no longer unique: a fresh
    348 copy of the symbol is created, so
     447advisable '''not''' to evict ports, because they might be mutated by certain
     448file-operations.  {{object-evict}} is able to handle circular and shared
     449structures, but evicted symbols are no longer unique: a fresh copy of the
     450symbol is created, so
    349451
    350452<enscript highlight=scheme>
     
    362464==== object-evict-to-location
    363465
    364  [procedure] (object-evict-to-location X PTR [LIMIT])
     466 [procedure] (object-evict-to-location X PTR* [LIMIT])
    365467
    366468As {{object-evict}} but moves the object at the address pointed to by
    367 the machine pointer {{PTR}}. If the number of copied bytes exceeds
     469the pointer-like object {{PTR*}}. If the number of copied bytes exceeds
    368470the optional {{LIMIT}} then an error is signalled (specifically a composite
    369471condition of types {{exn}} and {{evict}}. The latter provides
     
    372474free address after the evicted object.
    373475
     476Use of anything other than a pointer object as the {{PTR*}} argument is
     477questionable.
    374478
    375479==== object-evicted?
     
    377481 [procedure] (object-evicted? X)
    378482
    379 Returns {{#t}} if {{X}} is a non-immediate evicted data object,
    380 or {{#f}} otherwise.
    381 
    382 
    383 ==== object-size
    384 
    385  [procedure] (object-size X)
    386 
    387 Returns the number of bytes that would be needed to evict the data
    388 object {{X}}.
     483Returns {{#t}} if {{X}} is a non-immediate evicted data object, or {{#f}}
     484otherwise.
    389485
    390486
     
    403499 [procedure] (object-unevict X [FULL])
    404500
    405 Copies the object {{X}} and nested objects back into the normal
    406 Scheme heap.  Symbols are re-interned into the symbol table. Strings
    407 and byte-vectors are '''not''' copied, unless {{FULL}} is given and
    408 not {{#f}}.
    409 
    410 
    411 
    412 
    413 
    414 === Locatives
    415 
    416 
    417 A ''locative'' is an object that points to an element of a containing object,
    418 much like a ''pointer'' in low-level, imperative programming languages like ''C''. The element can
    419 be accessed and changed indirectly, by performing access or change operations
    420 on the locative. The container object can be computed by calling the
    421 {{location->object}} procedure.
    422 
    423 Locatives may be passed to foreign procedures that expect pointer arguments.
    424 The effect of creating locatives for evicted data (see {{object-evict}}) is undefined.
    425 
    426 
    427 
    428 ==== make-locative
    429 
    430  [procedure] (make-locative EXP [INDEX])
    431 
    432 Creates a locative that refers to the element of the non-immediate object {{EXP}}
    433 at position {{INDEX}}. {{EXP}} may be a vector, pair, string, blob,
    434 SRFI-4 number-vector, or record. {{INDEX}} should be a fixnum. {{INDEX}} defaults to 0.
    435 
    436 
    437 ==== make-weak-locative
    438 
    439  [procedure] (make-weak-locative EXP [INDEX])
    440 
    441 Creates a ''weak'' locative. Even though the locative refers to an element of a container object,
    442 the container object will still be reclaimed by garbage collection if no other references
    443 to it exist.
    444 
    445 
    446 ==== locative?
    447 
    448  [procedure] (locative? X)
    449 
    450 Returns {{#t}} if {{X}} is a locative, or {{#f}} otherwise.
    451 
    452 
    453 ==== locative-ref
    454 
    455  [procedure] (locative-ref LOC)
    456 
    457 Returns the element to which the locative {{LOC}} refers. If the containing
    458 object has been reclaimed by garbage collection, an error is signalled.
    459 
    460  (locative-ref (make-locative "abc" 1)) ==> #\b
    461 
    462 ==== locative-set!
    463 
    464  [procedure] (locative-set! LOC X)
    465  [procedure] (set! (locative-ref LOC) X)
    466 
    467 Changes the element to which the locative {{LOC}} refers to {{X}}.
    468 If the containing
    469 object has been reclaimed by garbage collection, an error is signalled.
    470 
    471 
    472 ==== locative->object
    473 
    474  [procedure] (locative->object LOC)
    475 
    476 Returns the object that contains the element referred to by {{LOC}} or
    477 {{#f}} if the container has been reclaimed by garbage collection.
    478 
    479  (locative->object (make-locative "abc" 1)) ==> "abc"
    480 
     501Copies the object {{X}} and nested objects back into the normal Scheme heap.
     502Symbols are re-interned into the symbol table. Strings and byte-vectors are
     503'''not''' copied, unless {{FULL}} is given and not {{#f}}.
     504
     505
     506==== object-size
     507
     508 [procedure] (object-size X)
     509
     510Returns the number of bytes that would be needed to evict the data object
     511{{X}}.
    481512
    482513
    483514
    484515=== Accessing toplevel variables
    485 
    486 
    487516
    488517
     
    516545
    517546
    518 
    519 
    520547=== Low-level data access
    521548
     
    525552 [procedure] (block-ref BLOCK INDEX)
    526553
    527 Returns the contents of the {{INDEX}}th slot of the object
    528 {{BLOCK}}.  {{BLOCK}} may be a vector, record structure,
    529 pair or symbol.
     554Returns the contents of the {{INDEX}}th slot of the object {{BLOCK}}. {{BLOCK}}
     555may be a vector, record structure, pair or symbol.
    530556
    531557
     
    535561 [procedure] (set! (block-ref BLOCK INDEX) X)
    536562
    537 Sets the contents of the {{INDEX}}th slot of the object
    538 {{BLOCK}} to the value of {{X}}.  {{BLOCK}} may be a
    539 vector, record structure, pair or symbol.
     563Sets the contents of the {{INDEX}}th slot of the object {{BLOCK}} to the value
     564of {{X}}.  {{BLOCK}} may be a vector, record structure, pair or symbol.
     565
     566
     567==== number-of-bytes
     568
     569 [procedure] (number-of-bytes BLOCK)
     570
     571Returns the number of bytes that the object {{BLOCK}} contains. {{BLOCK}} may
     572be any non-immediate value.
     573
     574
     575==== number-of-slots
     576
     577 [procedure] (number-of-slots BLOCK)
     578
     579Returns the number of slots that the object {{BLOCK}} contains.
     580{{BLOCK}} may be a vector, record structure, pair or symbol.
    540581
    541582
     
    544585 [procedure] (object-copy X)
    545586
    546 Copies {{X}} recursively and returns the fresh copy. Objects
    547 allocated in static memory are copied back into garbage collected storage.
     587Copies {{X}} recursively and returns the fresh copy. Objects allocated in
     588static memory are copied back into garbage collected storage.
     589
     590
     591==== move-memory!
     592
     593 [procedure] (move-memory! FROM TO [BYTES [FROM-OFFSET [TO-OFFSET]])
     594
     595Copies {{BYTES}} bytes of memory from {{FROM}} to {{TO}}. {{FROM}} and {{TO}}
     596may be strings, blobs, SRFI-4 number-vectors (see: @ref{Unit srfi-4}), memory
     597mapped files, foreign pointers (as obtained from a call to {{foreign-lambda}},
     598for example), tagged-pointers or locatives. if {{BYTES}} is not given and the
     599size of the source or destination operand is known then the maximal number of
     600bytes will be copied. Moving memory to the storage returned by locatives will
     601cause havoc, if the locative refers to containers of non-immediate data, like
     602vectors or pairs.
     603
     604The additional fourth and fifth argument specify starting offsets (in bytes)
     605for the source and destination arguments.
     606
     607Signals an error if any of the above constraints is violated.
     608
     609
     610
     611=== Record instance
    548612
    549613
     
    552616 [procedure] (make-record-instance SYMBOL ARG1 ...)
    553617
    554 Returns a new instance of the record type {{SYMBOL}}, with its
    555 slots initialized to {{ARG1 ...}}.  To illustrate:
     618Returns a new instance of a record structure of type {{SYMBOL}}, with its
     619slots initialized to {{ARG1 ...}}.
     620
     621To illustrate:
    556622
    557623<enscript highlight=scheme>
     
    575641
    576642
    577 ==== move-memory!
    578 
    579  [procedure] (move-memory! FROM TO [BYTES [FROM-OFFSET [TO-OFFSET]])
    580 
    581 Copies {{BYTES}} bytes of memory from {{FROM}} to {{TO}}.
    582 {{FROM}} and {{TO}} may be strings, primitive byte-vectors,
    583 SRFI-4 byte-vectors (see: @ref{Unit srfi-4}), memory mapped files, foreign
    584 pointers (as obtained from a call to {{foreign-lambda}}, for
    585 example) or locatives. if {{BYTES}} is not given and the size of the source
    586 or destination operand is known then the maximal number of bytes will
    587 be copied. Moving memory to the storage returned by locatives will cause havoc,
    588 if the locative refers to containers of non-immediate data, like vectors
    589 or pairs.
    590 
    591 The additional fourth and fifth argument specify starting offsets
    592 (in bytes) for the source and destination arguments.
    593 
    594 
    595 ==== number-of-bytes
    596 
    597  [procedure] (number-of-bytes BLOCK)
    598 
    599 Returns the number of bytes that the object {{BLOCK}} contains.
    600 {{BLOCK}} may be any non-immediate value.
    601 
    602 
    603 ==== number-of-slots
    604 
    605  [procedure] (number-of-slots BLOCK)
    606 
    607 Returns the number of slots that the object {{BLOCK}} contains.
    608 {{BLOCK}} may be a vector, record structure, pair or symbol.
    609 
    610 
    611643==== record-instance?
    612644
    613  [procedure] (record-instance? X)
    614 
    615 Returns {{#t}} if {{X}} is an instance of a record type.
    616 See also: {{make-record-instance}}.
     645 [procedure] (record-instance? X [SYMBOL])
     646
     647Returns {{#t}} if {{X}} is a record structure, or {{#f}} otherwise.
     648
     649Further, returns {{#t}} if {{X}} is of type {{SYMBOL}}, or {{#f}} otherwise.
     650
     651
     652==== record-instance-type
     653
     654 [procedure] (record-instance-type RECORD)
     655
     656Returns type symbol of the record structure {{RECORD}}. Signals an error if
     657{{RECORD}} is not a record structure.
     658
     659
     660==== record-instance-length
     661
     662 [procedure] (record-instance-length RECORD)
     663
     664Returns number of slots for the record structure {{RECORD}}. The
     665record-instance type is not counted. Signals an error if
     666{{RECORD}} is not a record structure.
     667
     668
     669==== record-instance-slot
     670
     671 [procedure] (record-instance-slot RECORD INDEX)
     672
     673Returns the contents of the {{INDEX}}th slot of the record structure
     674{{RECORD}}. The slot index range is the open interval (([0
     675record-instance-length)}}. Signals an error if {{RECORD}} is not a record
     676structure.
     677
     678
     679==== record-instance-slot-set!
     680
     681 [procedure] (record-instance-slot-set! RECORD INDEX X)
     682 [procedure] (set! (record-instance-slot RECORD INDEX) X)
     683
     684Sets the {{INDEX}}th slot of the record structure {{RECORD}} to {{X}}. The slot
     685index range is the open interval (([0 record-instance-length)}}. Signals an
     686error if {{RECORD}} is not a record structure.
    617687
    618688
    619689==== record->vector
    620690
    621  [procedure] (record->vector BLOCK)
    622 
    623 Returns a new vector with the type and the elements of the record {{BLOCK}}.
     691 [procedure] (record->vector RECORD)
     692
     693Returns a new vector with the type and the elements of the record structure
     694{{RECORD}}. Signals an error if {{RECORD}} is not a record structure.
    624695
    625696
     
    632703 [procedure] (set-invalid-procedure-call-handler! PROC)
    633704
    634 Sets an internal hook that is invoked when a call to an object other than a procedure
    635 is executed at runtime. The procedure {{PROC}} will in that case be called
    636 with two arguments: the object being called and a list of the passed arguments.
     705Sets an internal hook that is invoked when a call to an object other than a
     706procedure is executed at runtime. The procedure {{PROC}} will in that case be
     707called with two arguments: the object being called and a list of the passed
     708arguments.
    637709
    638710<enscript highlight=scheme>
     
    655727 [procedure] (unbound-variable-value [X])
    656728
    657 Defines the value that is returned for unbound variables. Normally an error
    658 is signalled, use this procedure to override the check and return {{X}}
    659 instead. To set the default behavior (of signalling an error), call
     729Defines the value that is returned for unbound variables. Normally an error is
     730signalled, use this procedure to override the check and return {{X}} instead.
     731To set the default behavior (of signalling an error), call
    660732{{unbound-variable-value}} with no arguments.
    661733
     
    664736
    665737
    666 
    667 
    668738=== Magic
    669739
     
    673743 [procedure] (object-become! ALIST)
    674744
    675 Changes the identity of the value of the car of each pair in
    676 {{ALIST}} to the value of the cdr. Both values may not be immediate
    677 (i.e. exact integers, characters, booleans or the empty list).
     745Changes the identity of the value of the car of each pair in {{ALIST}} to the
     746value of the cdr. Both values may not be immediate (i.e. exact integers,
     747characters, booleans or the empty list).
    678748
    679749<enscript highlight=scheme>
     
    697767
    698768Replaces the procedure {{OLD}} with the result of calling the one-argument
    699 procedure {{PROC}}. {{PROC}} will receive a copy of {{OLD}} that will
    700 be identical in behaviour to the result of {{PROC}}:
     769procedure {{PROC}}. {{PROC}} will receive a copy of {{OLD}} that will be
     770identical in behaviour to the result of {{PROC}}:
    701771
    702772<enscript highlight=scheme>
  • chicken/branches/chicken-3/posixunix.scm

    r13010 r13134  
    18861886    (##sys#check-string val 'setenv)
    18871887    (##core#inline "C_setenv" (##sys#make-c-string var) (##sys#make-c-string val))
    1888     (##core#undefined) ) )
     1888    (void) ) )
    18891889
    18901890(define (unsetenv var)
    18911891  (##sys#check-string var 'unsetenv)
    18921892  (##core#inline "C_putenv" (##sys#make-c-string var))
    1893   (##core#undefined) )
     1893  (void) )
    18941894
    18951895(define current-environment
  • chicken/branches/chicken-3/posixwin.scm

    r13010 r13134  
    16741674    (##sys#check-string val 'setenv)
    16751675    (##core#inline "C_setenv" (##sys#make-c-string var) (##sys#make-c-string val))
    1676     (##core#undefined) ) )
     1676    (void) ) )
    16771677
    16781678(define (unsetenv var)
    16791679  (##sys#check-string var 'unsetenv)
    16801680  (##core#inline "C_putenv" (##sys#make-c-string var))
    1681   (##core#undefined) )
     1681  (void) )
    16821682
    16831683(define current-environment
  • chicken/branches/chicken-3/scheduler.scm

    r11980 r13134  
    507507               (else
    508508                (##sys#setslot ##sys#current-thread 3 'suspended)
    509                 (##sys#setslot ##sys#current-thread 1 (lambda () (k (##core#undefined))))
     509                (##sys#setslot ##sys#current-thread 1 (lambda () (k (void))))
    510510                (let ([old (##sys#slot ##sys#primordial-thread 1)])
    511511                  (##sys#setslot
     
    526526      (let ((t (cadr t)))
    527527        (if a
    528             (##sys#setslot t 1 (lambda () ((cadr a) (##core#undefined))))
     528            (##sys#setslot t 1 (lambda () ((cadr a) (void))))
    529529            (##sys#signal-hook #:type-error "condition has no continuation" exn) )
    530530        (##sys#add-to-ready-queue t) ) )
    531531    (if pk
    532         ((cadr pk) (##core#undefined))
     532        ((cadr pk) (void))
    533533        (##sys#signal-hook #:type-error "condition has no continuation" exn) ) ) )
  • chicken/branches/chicken-3/srfi-18.scm

    r11554 r13134  
    260260  (when (eq? thread ##sys#primordial-thread)
    261261    ((##sys#exit-handler)) )
    262   (##sys#setslot thread 2 (list (##core#undefined)))
     262  (##sys#setslot thread 2 (list (void)))
    263263  (##sys#setslot thread 7 (##sys#make-structure 'condition '(terminated-thread-exception) '()))
    264264  (##sys#thread-kill! thread 'terminated)
     
    271271    (##sys#call-with-current-continuation
    272272     (lambda (return)
    273        (##sys#setslot thread 1 (lambda () (return (##core#undefined))))
     273       (##sys#setslot thread 1 (lambda () (return (void))))
    274274       (##sys#schedule) ) ) ) )
    275275
     
    285285     (lambda (return)
    286286       (let ((ct ##sys#current-thread))
    287          (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
     287         (##sys#setslot ct 1 (lambda () (return (void))))
    288288         (##sys#thread-block-for-timeout! ct limit)
    289289         (##sys#schedule) ) ) ) )
     
    422422           (gensym 'condition-variable) )
    423423       '()                              ; #2 list of waiting threads
    424        (##core#undefined) ) ) ) )       ; #3 specific
     424       (void) ) ) ) )                   ; #3 specific
    425425
    426426(define (condition-variable? x)
  • chicken/branches/chicken-3/srfi-4.scm

    r10645 r13134  
    698698                         (wrap s n) )
    699699                       (begin
    700                          (##sys#write-char/port c str)
     700                         (##sys#write-char-0 c str)
    701701                         (loop)))))))))))
    702702
  • chicken/branches/chicken-3/support.scm

    r8361 r13134  
    251251(define (immediate? x)
    252252  (or (and (fixnum? x) (not (big-fixnum? x))) ; 64-bit fixnums would result in platform-dependent .c files
    253       (eq? (##core#undefined) x)
     253      (eq? (void) x)
    254254      (null? x)
    255255      (eof-object? x)
  • chicken/branches/chicken-3/tcp.scm

    r12485 r13134  
    235235   (lambda (return)
    236236     (let ((ct ##sys#current-thread))
    237        (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
     237       (##sys#setslot ct 1 (lambda () (return (void))))
    238238       (##sys#schedule) ) ) ) )
    239239
  • chicken/branches/chicken-3/tests/runtests.sh

    r10950 r13134  
    1414echo "======================================== library tests ..."
    1515../csi -w -s library-tests.scm
     16
     17echo "======================================== lolevel tests ..."
     18../csi -w -s lolevel-tests.scm
    1619
    1720echo "======================================== hash-table tests ..."
Note: See TracChangeset for help on using the changeset viewer.