conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

- Added an optimization to the base record constructors for args up 

to 4.
This commit is contained in:
Abdulaziz Ghuloum 2008-01-19 18:15:18 -05:00
parent df1cef98be
commit 0142ba2315
3 changed files with 61 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
scheme/ikarus.io.ss
View File

@ -927,7 +927,10 @@
($set-port-attrs! p ($set-port-attrs! p
(fxior textual-input-port-bits fast-u7-text-tag)) (fxior textual-input-port-bits fast-u7-text-tag))
(eof-object? (advance-bom p who '(#xEF #xBB #xBF)))] (eof-object? (advance-bom p who '(#xEF #xBB #xBF)))]
[else (die 'slow-get-char "codec not handled")]))) [else
(die 'slow-get-char
"BUG: codec not handled"
(transcoder-codec tr))])))
;;; ;;;
(define (lookahead-char-char-mode p who) (define (lookahead-char-char-mode p who)
(let ([str ($port-buffer p)] (let ([str ($port-buffer p)]

80
scheme/ikarus.records.procedural.ss
View File

@ -255,31 +255,63 @@
all-fields))))) all-fields)))))
(define (constructor main-rtd size prcd proto) (define (constructor main-rtd size prcd proto)
(define (fill i r flds f*)
(cond
[(null? flds)
(if (null? f*)
r
(fill i r (car f*) (cdr f*)))]
[else
($struct-set! r i (car flds))
(fill (add1 i) r (cdr flds) f*)]))
(if (not prcd) ;;; base (if (not prcd) ;;; base
(lambda (f*) (let ([n (rtd-size main-rtd)])
(let ([a-record-constructor (define-syntax expand-setters
(lambda flds (syntax-rules ()
(let ([n (rtd-size main-rtd)]) [(_ r idx) #f]
(unless (= (length flds) size) [(_ r idx a0 a* ...)
(apply die (begin
'a-record-constructor ($struct-set! r idx a0)
(format (expand-setters r (+ idx 1) a* ...))]))
"expected ~a args, got ~a instead" (define-syntax expand-constructor
n (length flds)) (syntax-rules (default)
flds)) [(_ f* default)
(let ([r ($make-struct main-rtd n)]) (lambda flds
(let f ([i 0] [r r] [flds flds] [f* f*]) (unless (= (length flds) size)
(cond (apply die
[(null? flds) 'a-record-constructor
(if (null? f*) (format
r "expected ~a args, got ~a instead"
(f i r (car f*) (cdr f*)))] n (length flds))
[else flds))
($struct-set! r i (car flds)) (let ([r ($make-struct main-rtd n)])
(f (add1 i) r (cdr flds) f*)])))))]) (fill 0 r flds f*)))]
(if proto [(_ f* (args ...))
(proto a-record-constructor) (lambda (args ...)
a-record-constructor))) (let ([r ($make-struct main-rtd n)])
(expand-setters r 0 args ...)
(if (null? f*)
r
(fill (length '(args ...)) r (car f*) (cdr f*)))))]))
(define-syntax expand-one-case
(syntax-rules ()
[(_ arg-case)
(if proto
(lambda (f*)
(let ([a-record-constructor
(expand-constructor f* arg-case)])
(proto a-record-constructor)))
(lambda (f*)
(let ([a-record-constructor
(expand-constructor f* arg-case)])
a-record-constructor)))]))
(case size
[(0) (expand-one-case ())]
[(1) (expand-one-case (f0))]
[(2) (expand-one-case (f0 f1))]
[(3) (expand-one-case (f0 f1 f2))]
[(4) (expand-one-case (f0 f1 f2 f3))]
[else (expand-one-case default)]))
(let ([pprcd (rcd-prcd prcd)] (let ([pprcd (rcd-prcd prcd)]
[sz (rtd-size (rcd-rtd prcd))]) [sz (rtd-size (rcd-rtd prcd))])
(let ([p (constructor main-rtd sz pprcd (rcd-proc prcd))] (let ([p (constructor main-rtd sz pprcd (rcd-proc prcd))]

2
scheme/last-revision
View File

@ -1 +1 @@
1349 1350