Changeset 13525 in project


Ignore:
Timestamp:
03/06/09 06:23:51 (11 years ago)
Author:
Kon Lovett
Message:

Addded maybe-immediate set! routines. Added better assert comments.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/chicken-primitive-object-inlines.scm

    r13504 r13525  
    318318(define-inline (%block-word-set!/immediate x i y) (##core#inline "C_i_set_i_slot" x i y))
    319319
     320(define-inline (%block-word-set!/maybe-immediate x i y)
     321  (if (%immediate? y)
     322      (%block-word-set!/immediate x i y)
     323      (%block-word-set! x i y) ) )
    320324
    321325
     
    363367(define-inline (%vector-set! v i x) (%block-word-set! v i x))
    364368(define-inline (%vector-set!/immediate v i x) (%block-word-set!/immediate v i x))
     369(define-inline (%vector-set!/maybe-immediate v i x) (%block-word-set!/maybe-immediate v i x))
    365370
    366371(define-inline (%vector-length v) (%block-size v))
     
    388393  (let* ([n (%string-length s)]
    389394               [bv (%make-bytevector sz)] )
    390     (##core#inline "C_copy_memory" bv s n) 
     395    (##core#inline "C_copy_memory" bv s n)
    391396    bv ) )
    392397
     
    394399  (let* ([n (%bytevector-length bv)]
    395400               [s (%make-string n #\space)] )
    396     (##core#inline "C_copy_memory" s bv n) 
     401    (##core#inline "C_copy_memory" s bv n)
    397402    s ) )
    398403
     
    421426(define-inline (%cons x y) (##core#inline_allocate ("C_a_i_cons" 3) x y) )
    422427
    423 (define-inline (%length l) (##core#inline "C_i_length" l))
    424 
    425 (define-inline (%car p) (%block-word-ref p 0))
    426 (define-inline (%cdr p) (%block-word-ref p 1))
    427 
    428 (define-inline (%caar p) (%car (%car p)))
    429 (define-inline (%cadr p) (%car (%cdr p)))
    430 (define-inline (%cdar p) (%cdr (%car p)))
    431 (define-inline (%cddr p) (%cdr (%cdr p)))
    432 
    433 (define-inline (%caaar p) (%car (%caar p)))
    434 (define-inline (%caadr p) (%car (%cadr p)))
    435 (define-inline (%cadar p) (%car (%cdar p)))
    436 (define-inline (%caddr p) (%car (%cddr p)))
    437 (define-inline (%cdaar p) (%cdr (%caar p)))
    438 (define-inline (%cdadr p) (%cdr (%cadr p)))
    439 (define-inline (%cddar p) (%cdr (%cdar p)))
    440 (define-inline (%cdddr p) (%cdr (%cddr p)))
    441 
    442 (define-inline (%set-car! p x) (%block-word-set! p 0 x))
    443 (define-inline (%set-cdr! p x) (%block-word-set! p 1 x))
    444 (define-inline (%set-car/immediate! p x) (%block-word-set!/immediate p 0 x))
    445 (define-inline (%set-cdr/immediate! p x) (%block-word-set!/immediate p 1 x))
     428(define-inline (%length ls) (##core#inline "C_i_length" ls))
     429
     430(define-inline (%car pr) (%block-word-ref pr 0))
     431(define-inline (%cdr pr) (%block-word-ref pr 1))
     432
     433(define-inline (%caar pr) (%car (%car pr)))
     434(define-inline (%cadr pr) (%car (%cdr pr)))
     435(define-inline (%cdar pr) (%cdr (%car pr)))
     436(define-inline (%cddr pr) (%cdr (%cdr pr)))
     437
     438(define-inline (%caaar pr) (%car (%caar pr)))
     439(define-inline (%caadr pr) (%car (%cadr pr)))
     440(define-inline (%cadar pr) (%car (%cdar pr)))
     441(define-inline (%caddr pr) (%car (%cddr pr)))
     442(define-inline (%cdaar pr) (%cdr (%caar pr)))
     443(define-inline (%cdadr pr) (%cdr (%cadr pr)))
     444(define-inline (%cddar pr) (%cdr (%cdar pr)))
     445(define-inline (%cdddr pr) (%cdr (%cddr pr)))
     446
     447(define-inline (%set-car! pr x) (%block-word-set! pr 0 x))
     448(define-inline (%set-cdr! pr x) (%block-word-set! pr 1 x))
     449(define-inline (%set-car/immediate! pr x) (%block-word-set!/immediate pr 0 x))
     450(define-inline (%set-cdr/immediate! pr x) (%block-word-set!/immediate pr 1 x))
     451(define-inline (%set-car!/maybe-immediate pr x) (%block-word-set!/maybe-immediate pr 0 x))
     452(define-inline (%set-cdr!/maybe-immediate pr x) (%block-word-set!/maybe-immediate pr 1 x))
    446453
    447454;; These are safe
    448455
    449 (define-inline (%memq x l) (##core#inline "C_i_memq" x l))
    450 (define-inline (%memv x l) (##core#inline "C_i_memv" x l))
    451 (define-inline (%member x l) (##core#inline "C_i_member" x l))
    452 
    453 (define-inline (%assq x l) (##core#inline "C_i_assq" x l))
    454 (define-inline (%assv x l) (##core#inline "C_i_assv" x l))
    455 (define-inline (%assoc x l) (##core#inline "C_i_assoc" x l))
    456 
    457 ; l0 must be a proper-list
    458 (define-inline (%list-ref l0 i0)
    459   (let loop ([l l0] [i i0])
    460     (cond [(null? l)  '() ]
    461                 [(%fx= 0 i) (%car l) ]
    462                 [else       (loop (%cdr l) (%fx- i 1)) ] ) ) )
    463 
    464 ; l0 cannot be null
    465 (define-inline (%last-pair l0)
    466   (do ([l l0 (%cdr l)])
    467       [(%null? (%cdr l)) l]) )
    468 
    469 (define-inline (%list-copy l0)
    470   (let loop ([ls l0])
    471     (if (%null? ls)
    472         '()
     456(define-inline (%memq x ls) (##core#inline "C_i_memq" x ls))
     457(define-inline (%memv x ls) (##core#inline "C_i_memv" x ls))
     458(define-inline (%member x ls) (##core#inline "C_i_member" x ls))
     459
     460(define-inline (%assq x ls) (##core#inline "C_i_assq" x ls))
     461(define-inline (%assv x ls) (##core#inline "C_i_assv" x ls))
     462(define-inline (%assoc x ls) (##core#inline "C_i_assoc" x ls))
     463
     464(define-inline (%list-ref ls0 i0)
     465  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
     466  (let loop ([ls ls0] [i i0])
     467    (cond [(%null? ls)  '() ]
     468                [(%fx= 0 i)   (%car ls) ]
     469                [else         (loop (%cdr ls) (%fx- i 1)) ] ) ) )
     470
     471(define-inline (%list-pair-ref ls0 i0)
     472  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
     473  (let loop ([ls ls0] [i i0])
     474    (cond [(%null? ls)  '() ]
     475                [(%fx= 0 i)   ls ]
     476                [else         (loop (%cdr ls) (%fx- i 1)) ] ) ) )
     477
     478(define-inline (%last-pair ls0)
     479  ;(assert (and (proper-list? ls0) (not (null? ls0))))
     480  (do ([ls ls0 (%cdr ls)])
     481      [(%null? (%cdr ls)) ls]) )
     482
     483(define-inline (%list-copy ls0)
     484  ;(assert (proper-list? ls0))
     485  (let loop ([ls ls0])
     486    (if (%null? ls) '()
    473487        (%cons (%car ls) (loop (%cdr ls))) ) ) )
    474488
    475 ; each elm of ls must be a proper-list
    476 (define-inline (%append! . ls)
    477   (let ([ls (let loop ([ls ls])
    478               (cond [(%null? ls)        '() ]
    479                     [(%null? (%car ls)) (loop (%cdr ls)) ]
    480                     [else               ls ] ) ) ] )
    481     (if (%null? ls)
    482         '()
    483         (let ([l0 (%car ls)])
    484           ;(assert (not (null? l0)))
    485           (let loop ([ls (%cdr ls)] [pl l0])
    486             (if (%null? ls)
    487                 l0
    488                 (let ([l1 (%car ls)])
    489                   (if (%null? l1)
    490                       (loop (%cdr ls) pl)
    491                       (begin
    492                         (%set-cdr! (%last-pair pl) l1)
    493                         (loop (%cdr ls) l1) ) ) ) ) ) ) ) ) )
    494    
    495 ; l0 must be a proper-list
    496 (define-inline (%delq! x l0)
    497   (let loop ([l l0] [pp #f])
    498     (cond [(null? l)
    499            l0 ]
    500                 [(%eq? x (%car l))
    501                  (cond [pp
    502                         (%set-cdr! pp (%cdr l))
    503                         l0 ]
     489(define-inline (%append! . lss)
     490  ;(assert (and (proper-list? lss) (for-each (lambda (x) (proper-list? x)) lss)))
     491  (let ([lss (let position-at-first-pair ([lss lss])
     492               (cond [(%null? lss)        '() ]
     493                     [(%null? (%car lss))  (position-at-first-pair (%cdr lss)) ]
     494                     [else                 lss ] ) ) ] )
     495    (if (%null? lss) '()
     496        (let ([ls0 (%car lss)])
     497          ;(assert (not (null? ls0)))
     498          (let append!-rest ([lss (%cdr lss)] [pls ls0])
     499            (if (%null? lss) ls0
     500                (let ([ls (%car lss)])
     501                  (cond [(%null? ls)
     502                         (append!-rest (%cdr lss) pls) ]
     503                        [else
     504                         (%set-cdr! (%last-pair pls) ls)
     505                         (append!-rest (%cdr lss) ls) ] ) ) ) ) ) ) ) )
     506
     507(define-inline (%delq! x ls0)
     508  ;(assert (proper-list? ls0))
     509  (let find-elm ([ls ls0] [ppr #f])
     510    (cond [(%null? ls)
     511           ls0 ]
     512                [(%eq? x (%car ls))
     513                 (cond [ppr
     514                        (%set-cdr!/maybe-immediate ppr (%cdr ls))
     515                        ls0 ]
    504516                       [else
    505                         (%cdr l) ] ) ]
     517                        (%cdr ls) ] ) ]
    506518                [else
    507                  (loop (%cdr l) l) ] ) ) )
     519                 (find-elm (%cdr ls) ls) ] ) ) )
     520
     521(define-inline (%list-fold-1 ls0 func init)
     522  ;(assert (and (proper-list? ls0) (procedure? func)))
     523  (let loop ([ls ls0] [acc init])
     524    (if (%null? ls) acc
     525        (loop (%cdr ls) (func (%car ls) acc)) ) ) )
     526
     527(define-inline (%list-map-1 ls0 func)
     528  ;(assert (and (proper-list? ls0) (procedure? func)))
     529  (let loop ([ls ls0])
     530    (if (%null? ls) '()
     531        (%cons (func (%car ls)) (loop (%cdr ls))) ) ) )
     532
     533(define-inline (%list-for-each-1 ls0 proc)
     534  ;(assert (and (proper-list? ls0) (procedure? proc)))
     535  (let loop ([ls ls0])
     536    (unless (%null? ls)
     537      (proc (%car ls))
     538      (loop (%cdr ls)) ) ) )
    508539
    509540
     
    518549(define-inline (%structure-set! r i x) (%block-word-set! r i x))
    519550(define-inline (%structure-set!/immediate r i x) (%block-word-set!/immediate r i x))
     551(define-inline (%structure-set!/maybe-immediate r i x) (%block-word-set!/maybe-immediate r i x))
    520552
    521553(define-inline (%structure-length r) (%block-size r))
     
    566598(define-inline (%port-data-set! port port) (%block-word-set! port 9 x))
    567599
    568 ; Port-class layout     
     600; Port-class layout
    569601;
    570602; 0       (read-char PORT) -> CHAR | EOF
Note: See TracChangeset for help on using the changeset viewer.