ikarus/scheme/unicode/extract-common.ss

143 lines
5.5 KiB
Scheme
Raw Normal View History

;;; Copyright (C) 2008 Abdulaziz Ghuloum, R. Kent Dybvig
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a
;;; copy of this software and associated documentation files (the "Software"),
;;; to deal in the Software without restriction, including without limitation
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;; and/or sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(module (define-table) ;;;((define-table maker accessor mutator))
(define-syntax maker
(syntax-rules ()
[(_ make-inner x t) (make-inner t x)]
[(_ make-inner x t1 t2 ...)
(let ([v (make-vector t1)])
(do ([i 0 (fx+ i 1)])
((fx= i t1))
(vector-set! v i (maker make-inner x t2 ...)))
v)]))
(define-syntax accessor
(syntax-rules ()
[(_ inner-ref tbl i t) (inner-ref tbl i)]
[(_ inner-ref tbl i t1 t2 ...)
(let ([d (* t2 ...)])
(accessor inner-ref (vector-ref tbl (fxdiv i d))
(fxmod i d) t2 ...))]))
(define-syntax mutator
(syntax-rules ()
[(_ inner-set! tbl i x t) (inner-set! tbl i x)]
[(_ inner-set! tbl i x t1 t2 ...)
(let ([d (* t2 ...)])
(mutator inner-set! (vector-ref tbl (fxdiv i d))
(fxmod i d) x t2 ...))]))
(define-syntax define-table
(lambda (x)
(define accessor-code
(lambda (x)
(syntax-case x ()
[(inner-ref tbl i t) #'(inner-ref tbl i)]
[(inner-ref tbl i t1 t2 ...)
(with-syntax ([(d) (generate-temporaries '(d))])
(with-syntax ([body (accessor-code
#'(inner-ref
(vector-ref tbl (fxdiv i d))
(fxmod i d) t2 ...))])
#'(let ([d (* t2 ...)]) body)))])))
(syntax-case x ()
[(_ (make-table table-ref table-set! table-ref-code)
(make-inner inner-ref inner-set!) size dim ...)
(with-syntax ([(t1 t2 ...) (generate-temporaries #'(size dim ...))]
[code (accessor-code
#'(inner-ref tbl i
(/ size (* dim ...))
dim ...))])
#'(module (make-table table-ref table-set! table-ref-code)
(define t2 dim) ...
(define t1 (/ size (* t2 ...)))
(define make-table (lambda (x) (maker make-inner x t1 t2 ...)))
(define table-ref-code '(lambda (tbl i) code))
(define table-ref (lambda (tbl i) (accessor inner-ref tbl i t1 t2 ...)))
(define table-set! (lambda (tbl i x) (mutator inner-set! tbl i x t1 t2 ...)))))]))))
(define (with-output-to-file* file thunk)
(when (file-exists? file) (delete-file file))
(with-output-to-file file thunk))
(define common-equal?
(lambda (x y)
(cond
[(eq? x y) #t]
[(vector? x)
(and (vector? y)
(let ([n (vector-length x)])
(and (fx= (vector-length y) n)
(let f ([i 0])
(or (fx= i n)
(and (eq? (vector-ref x i) (vector-ref y i))
(f (fx+ i 1))))))))]
[(pair? x) (and (pair? y) (eq? (car x) (car y)) (eq? (cdr x) (cdr y)))]
[else (equal? x y)])))
(define cache '())
#;(define commonize ; 5.8s
(lambda (x)
(or (find (lambda (y) (common-equal? y x)) cache)
(begin (set! cache (cons x cache)) x))))
#;(define commonize ; 2.6s
(let ([cache-table (make-hashtable equal-hash common-equal?)])
(lambda (x)
(or (hashtable-ref cache-table x #f)
(begin
(set! cache (cons x cache)) ; for sizeof
(hashtable-set! cache-table x x)
x)))))
(define commonize ; 1.9s
(lambda (x)
(let ([v (find (lambda (y) (common-equal? y x)) cache)])
(if v
(begin (set! cache (cons v (remq v cache))) v)
(begin (set! cache (cons x cache)) x)))))
(define commonize*
(lambda (x)
(cond
[(vector? x)
(let ([n (vector-length x)])
(do ([i 0 (fx+ i 1)])
((fx= i n))
(vector-set! x i (commonize* (vector-ref x i)))))
(commonize x)]
[(bytevector? x) (commonize x)]
[(pair? x)
(set-car! x (commonize* (car x)))
(set-cdr! x (commonize* (cdr x)))
(commonize x)]
[else x])))
(define (sizeof ls)
(apply +
(map (lambda (x)
(cond
[(vector? x) (* (vector-length x) ptr-bytes)]
[(bytevector? x) (bytevector-length x)]
[(pair? x) (* ptr-bytes 2)]
[(fixnum? x) 0]
[(char? x) 0]
[else (error 'sizeof "unexpected ~s" x)]))
ls)))
(define (hex->num x) (string->number x 16))