From f7d1d6b6a3205c6b02c887cb5b66fab7ae036b19 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Sat, 6 Dec 2008 12:40:18 -0500 Subject: [PATCH] unused (garbage) symbols can be reclaimed now --- scheme/Makefile.am | 3 +- scheme/Makefile.in | 3 +- scheme/ikarus.io.ss | 16 +- scheme/ikarus.main.ss | 2 + scheme/ikarus.symbol-table.ss | 130 +++++ scheme/ikarus.symbols.ss | 6 +- scheme/last-revision | 2 +- scheme/makefile.ss | 2 + scheme/todo-r6rs.ss | 957 ---------------------------------- src/ikarus-symbol-table.c | 26 +- 10 files changed, 175 insertions(+), 972 deletions(-) create mode 100644 scheme/ikarus.symbol-table.ss delete mode 100755 scheme/todo-r6rs.ss diff --git a/scheme/Makefile.am b/scheme/Makefile.am index 45ce157..4a49578 100644 --- a/scheme/Makefile.am +++ b/scheme/Makefile.am @@ -28,7 +28,8 @@ EXTRA_DIST=ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \ ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \ ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \ ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \ - ikarus.reader.annotated.ss ikarus.pointers.ss ikarus.equal.ss + ikarus.reader.annotated.ss ikarus.pointers.ss ikarus.equal.ss \ + ikarus.symbol-table.ss all: $(nodist_pkglib_DATA) diff --git a/scheme/Makefile.in b/scheme/Makefile.in index 35f7a0d..f2a6742 100644 --- a/scheme/Makefile.in +++ b/scheme/Makefile.in @@ -183,7 +183,8 @@ EXTRA_DIST = ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \ ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \ ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \ ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \ - ikarus.reader.annotated.ss ikarus.pointers.ss ikarus.equal.ss + ikarus.reader.annotated.ss ikarus.pointers.ss ikarus.equal.ss \ + ikarus.symbol-table.ss revno = "$(shell sed 's/ .*//' ../.bzr/branch/last-revision 2>/dev/null)" sizeofvoidp = $(shell grep SIZEOF_VOID_P ../config.h | sed "s/.*\(.\)/\1/g") diff --git a/scheme/ikarus.io.ss b/scheme/ikarus.io.ss index 3aab548..7268c73 100644 --- a/scheme/ikarus.io.ss +++ b/scheme/ikarus.io.ss @@ -32,7 +32,7 @@ close-port port-closed? close-input-port close-output-port port-eof? get-char lookahead-char read-char peek-char - get-string-n get-string-n! get-string-all get-line + get-string-n get-string-n! get-string-all get-line read-line get-u8 lookahead-u8 get-bytevector-n get-bytevector-n! get-bytevector-some get-bytevector-all @@ -92,7 +92,7 @@ close-port port-closed? close-input-port close-output-port port-eof? get-char lookahead-char read-char peek-char - get-string-n get-string-n! get-string-all get-line + get-string-n get-string-n! get-string-all get-line read-line get-u8 lookahead-u8 get-bytevector-n get-bytevector-n! get-bytevector-some get-bytevector-all @@ -1918,7 +1918,7 @@ [($fx= c 0) 0] [else (die 'get-string-n! "count is negative" c)]))) - (define (get-line p) + (define ($get-line p who) (import UNSAFE) (define (get-it p) (let f ([p p] [n 0] [ac '()]) @@ -1939,8 +1939,14 @@ (if (input-port? p) (if (textual-port? p) (get-it p) - (die 'get-line "not a textual port" p)) - (die 'get-line "not an input port" p))) + (die who "not a textual port" p)) + (die who "not an input port" p))) + (define (get-line p) + ($get-line p 'get-line)) + (define read-line + (case-lambda + [() ($get-line (current-input-port) 'read-line)] + [(p) ($get-line p 'read-line)])) (define (get-string-all p) diff --git a/scheme/ikarus.main.ss b/scheme/ikarus.main.ss index 51ffab5..ac1aebb 100644 --- a/scheme/ikarus.main.ss +++ b/scheme/ikarus.main.ss @@ -77,7 +77,9 @@ (except (ikarus startup) host-info) (only (psyntax library-manager) current-library-expander) (only (ikarus.reader.annotated) read-source-file) + (only (ikarus.symbol-table) initialize-symbol-table!) (only (ikarus load) load-r6rs-top-level)) + (initialize-symbol-table!) (init-library-path) (let-values ([(files script script-type args) (let f ([args (command-line-arguments)]) diff --git a/scheme/ikarus.symbol-table.ss b/scheme/ikarus.symbol-table.ss new file mode 100644 index 0000000..9d9466e --- /dev/null +++ b/scheme/ikarus.symbol-table.ss @@ -0,0 +1,130 @@ + +(library (ikarus.symbol-table) + (export string->symbol initialize-symbol-table!) + (import + (except (ikarus) string->symbol) + (ikarus system $symbols)) + + (define-struct symbol-table (length mask vec guardian)) + + (define (extend-table st) + (let* ([v1 (symbol-table-vec st)] + [n1 (vector-length v1)] + [n2 (+ n1 n1)] + [mask (- n2 1)] + [v2 (make-vector n2 '())]) + (define (insert p) + (unless (null? p) + (let ([a (car p)] [rest (cdr p)]) + (let ([idx (fxand (symbol-hash a) mask)]) + (set-cdr! p (vector-ref v2 idx)) + (vector-set! v2 idx p)) + (insert rest)))) + (vector-for-each insert v1) + (set-symbol-table-vec! st v2) + (set-symbol-table-mask! st mask))) + + (define intern-symbol! + (case-lambda + [(s idx st) + (let ([v (symbol-table-vec st)]) + (vector-set! v idx (weak-cons s (vector-ref v idx))) + ((symbol-table-guardian st) s) + (let ([n (fx+ (symbol-table-length st) 1)]) + (set-symbol-table-length! st n) + (when (fx=? n (symbol-table-mask st)) + (extend-table st))))] + [(s st) + (intern-symbol! s + (fxand (symbol-hash s) (symbol-table-mask st)) + st)])) + + (define (intern str idx st) + (let ([s ($make-symbol str)]) + ($set-symbol-unique-string! s #f) + (intern-symbol! s idx st) + s)) + + (define (unintern x st) + (let ([n (fx- (symbol-table-length st) 1)]) + (set-symbol-table-length! st n)) + (let ([idx (fxand (symbol-hash x) (symbol-table-mask st))] + [v (symbol-table-vec st)]) + (let ([ls (vector-ref v idx)]) + (cond + [(eq? (car ls) x) + (vector-set! v idx (cdr ls))] + [else + (let f ([prev ls] [ls (cdr ls)]) + (cond + [(eq? (car ls) x) + (set-cdr! prev (cdr ls))] + [else (f ls (cdr ls))]))])))) + + (define (guardian-lookup str idx st) + (let ([g (symbol-table-guardian st)]) + (let f () + (let ([a (g)]) + (cond + [(not a) (intern str idx st)] + [(string=? str (symbol->string a)) + (begin (g a) a)] + [else + (cond + [(and ($unbound-object? ($symbol-value a)) + (null? ($symbol-plist a))) + (unintern a st)] + [else (g a)]) + (f)]))))) + + (define (chain-lookup str idx st ls) + (if (null? ls) + (guardian-lookup str idx st) + (let ([a (car ls)]) + (if (string=? str (symbol->string a)) + a + (chain-lookup str idx st (cdr ls)))))) + + (define (lookup str ih st) + (let ([idx (fxand ih (symbol-table-mask st))]) + (let ([v (symbol-table-vec st)]) + (chain-lookup str idx st (vector-ref v idx))))) + + + (module (string->symbol initialize-symbol-table!) + (define st (make-symbol-table 0 3 (make-vector 4 '()) (make-guardian))) + (define (string->symbol x) + (if (string? x) + (lookup x (string-hash x) st) + (die 'string->symbol "not a string" x))) + (define (initialize-symbol-table!) + (define (f x) + (when (pair? x) + (intern-symbol! (car x) st) + (f (cdr x)))) + (vector-for-each f (foreign-call "ikrt_get_symbol_table"))))) + +#!eof + +(define (gen-list i n) + (let f ([i i]) + (if (= i n) + '() + (let ([x (string->symbol (format "s~a" i))]) + (cons x (f (+ i 1))))))) + +(initialize-symbol-table!) + + +(time + (let () + (gen-list 0 1000) + (gen-list 0 1000) + (time (do ((i 0 (+ i 1))) ((= i 1000)) (collect))) + (gen-list 0 1000) + (gen-list 1000 1001) +; (gen-list 1000 2000) + #f)) + + + diff --git a/scheme/ikarus.symbols.ss b/scheme/ikarus.symbols.ss index 9502048..427404f 100644 --- a/scheme/ikarus.symbols.ss +++ b/scheme/ikarus.symbols.ss @@ -16,7 +16,7 @@ (library (ikarus.symbols) (export gensym gensym? gensym->unique-string gensym-prefix - gensym-count print-gensym string->symbol symbol->string + gensym-count print-gensym symbol->string getprop putprop remprop property-list top-level-value top-level-bound? set-top-level-value! symbol-value symbol-bound? set-symbol-value! @@ -28,8 +28,7 @@ (ikarus system $fx) (except (ikarus) gensym gensym? gensym->unique-string gensym-prefix gensym-count print-gensym system-value - string->symbol symbol->string - getprop putprop remprop property-list + symbol->string getprop putprop remprop property-list top-level-value top-level-bound? set-top-level-value! symbol-value symbol-bound? set-symbol-value! reset-symbol-proc!)) @@ -117,6 +116,7 @@ (die 'apply "not a procedure" (top-level-value x)))))))) + #; (define string->symbol (lambda (x) (unless (string? x) diff --git a/scheme/last-revision b/scheme/last-revision index 4e43fed..216c09c 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1698 +1699 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index cc805c2..2c55e3f 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -75,6 +75,7 @@ "ikarus.numerics.ss" "ikarus.conditions.ss" "ikarus.guardians.ss" + "ikarus.symbol-table.ss" "ikarus.codecs.ss" "ikarus.bytevectors.ss" "ikarus.posix.ss" @@ -1110,6 +1111,7 @@ [get-char i r ip] [get-datum i r ip] [get-line i r ip] + [read-line i] [get-string-all i r ip] [get-string-n i r ip] [get-string-n! i r ip] diff --git a/scheme/todo-r6rs.ss b/scheme/todo-r6rs.ss deleted file mode 100755 index f71ee30..0000000 --- a/scheme/todo-r6rs.ss +++ /dev/null @@ -1,957 +0,0 @@ -#!/usr/bin/env scheme-script -;;; Ikarus Scheme -- A compiler for R6RS Scheme. -;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License version 3 as -;;; published by the Free Software Foundation. -;;; -;;; This program is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -this-file-is-out-of-date! -(import (ikarus)) - -;;; library names: - -(define library-names - '( - [se (scheme-report-environment)] - [r5 (rnrs r5rs (6))] - [ct (rnrs control (6))] - [ev (rnrs eval (6))] - [mp (rnrs mutable-pairs (6))] - [ms (rnrs mutable-strings (6))] - [pr (rnrs programs (6))] - [sc (rnrs syntax-case (6))] - [fi (rnrs files (6))] - [ne (null-environment)] - [sr (rnrs sorting (6))] - [ex (rnrs exceptions (6))] - [ls (rnrs lists (6))] - [ri (rnrs records inspection (6))] - [rp (rnrs records procedural (6))] - [rs (rnrs records syntactic (6))] - [co (rnrs conditions (6))] - [en (rnrs enums (6))] - [is (rnrs io simple (6))] - [fl (rnrs arithmetic flonums (6))] - [ba (rnrs base (6))] - [bv (rnrs bytevectors (6))] - [uc (rnrs unicode (6))] - [bw (rnrs arithmetic bitwise (6))] - [fx (rnrs arithmetic fixnums (6))] - [ht (rnrs hashtables (6))] - [ip (rnrs io ports (6))] - )) - -(define status-names - '( - [S scheduled] - [C completed] - )) - -(define identifier-names - '( - ;;; - [lambda C ba se ne] - [and C ba se ne] - [begin C ba se ne] - [case C ba se ne] - [cond C ba se ne] - [define C ba se ne] - [define-syntax C ba se ne] - [identifier-syntax C ba] - [if C ba se ne] - [let C ba se ne] - [let* C ba se ne] - [let*-values C ba] - [let-syntax C ba se ne] - [let-values C ba] - [letrec C ba se ne] - [letrec* C ba] - [letrec-syntax C ba se ne] - [or C ba se ne] - [quasiquote C ba se ne] - [quote C ba se ne] - [set! C ba se ne] - [syntax-rules C ba se ne] - [unquote C ba se ne] - [unquote-splicing C ba se ne] - [< C ba se] - [<= C ba se] - [= C ba se] - [> C ba se] - [>= C ba se] - [+ C ba se] - [- C ba se] - [* C ba se] - [/ C ba se] - [abs C ba se] - [acos C ba se] - [angle S ba se] - [append C ba se] - [apply C ba se] - [asin C ba se] - [assert C ba] - [assertion-violation C ba] - [atan C ba se] - [boolean=? C ba] - [boolean? C ba se] - [car C ba se] - [cdr C ba se] - [caar C ba se] - [cadr C ba se] - [cdar C ba se] - [cddr C ba se] - [caaar C ba se] - [caadr C ba se] - [cadar C ba se] - [caddr C ba se] - [cdaar C ba se] - [cdadr C ba se] - [cddar C ba se] - [cdddr C ba se] - [caaaar C ba se] - [caaadr C ba se] - [caadar C ba se] - [caaddr C ba se] - [cadaar C ba se] - [cadadr C ba se] - [caddar C ba se] - [cadddr C ba se] - [cdaaar C ba se] - [cdaadr C ba se] - [cdadar C ba se] - [cdaddr C ba se] - [cddaar C ba se] - [cddadr C ba se] - [cdddar C ba se] - [cddddr C ba se] - [call-with-current-continuation C ba se] - [call/cc C ba] - [call-with-values C ba se] - [ceiling C ba se] - [char->integer C ba se] - [char<=? C ba se] - [char=? C ba se] - [char>? C ba se] - [char? C ba se] - [complex? C ba se] - [cons C ba se] - [cos C ba se] - [denominator C ba se] - [div C ba] - [mod C ba] - [div-and-mod C ba] - [div0 C ba] - [mod0 C ba] - [div0-and-mod0 C ba] - [dynamic-wind C ba se] - [eq? C ba se] - [equal? C ba se] - [eqv? C ba se] - [error C ba] - [even? C ba se] - [exact C ba] - [exact-integer-sqrt C ba] - [exact? C ba se] - [exp C ba se] - [expt C ba se] - [finite? C ba] - [floor C ba se] - [for-each C ba se] - [gcd C ba se] - [imag-part C ba se] - [inexact C ba] - [inexact? C ba se] - [infinite? C ba] - [integer->char C ba se] - [integer-valued? C ba] - [integer? C ba se] - [lcm C ba se] - [length C ba se] - [list C ba se] - [list->string C ba se] - [list->vector C ba se] - [list-ref C ba se] - [list-tail C ba se] - [list? C ba se] - [log C ba se] - [magnitude C ba se] - [make-polar S ba se] - [make-rectangular S ba se] - [make-string C ba se] - [make-vector C ba se] - [map C ba se] - [max C ba se] - [min C ba se] - [nan? C ba] - [negative? C ba se] - [not C ba se] - [null? C ba] - [number->string C ba se] - [number? C ba se] - [numerator C ba se] - [odd? C ba se] - [pair? C ba se] - [positive? C ba se] - [procedure? C ba se] - [rational-valued? C ba] - [rational? C ba se] - [rationalize C ba se] - [real-part C ba se] - [real-valued? C ba] - [real? C ba se] - [reverse C ba se] - [round C ba se] - [sin C ba se] - [sqrt C ba se] - [string C ba se] - [string->list C ba se] - [string->number C ba se] - [string->symbol C ba se] - [string-append C ba se] - [string-copy C ba se] - [string-for-each C ba] - [string-length C ba se] - [string-ref C ba se] - [string<=? C ba se] - [string=? C ba se] - [string>? C ba se] - [string? C ba se] - [substring C ba se] - [symbol->string C ba se] - [symbol=? C ba] - [symbol? C ba se] - [tan C ba se] - [truncate C ba se] - [values C ba se] - [vector C ba se] - [vector->list C ba se] - [vector-fill! C ba se] - [vector-for-each C ba] - [vector-length C ba se] - [vector-map C ba] - [vector-ref C ba se] - [vector-set! C ba se] - [vector? C ba se] - [zero? C ba se] - [... C ba sc] - [=> C ba ex] - [_ C ba sc] - [else C ba ex] - ;;; - [bitwise-arithmetic-shift C bw] - [bitwise-arithmetic-shift-left C bw] - [bitwise-arithmetic-shift-right C bw] - [bitwise-not C bw] - [bitwise-and C bw] - [bitwise-ior S bw] - [bitwise-xor S bw] - [bitwise-bit-count C bw] - [bitwise-bit-field C bw] - [bitwise-bit-set? C bw] - [bitwise-copy-bit C bw] - [bitwise-copy-bit-field S bw] - [bitwise-first-bit-set C bw] - [bitwise-if S bw] - [bitwise-length C bw] - [bitwise-reverse-bit-field S bw] - [bitwise-rotate-bit-field S bw] - ;;; - [fixnum? C fx] - [fixnum-width C fx] - [least-fixnum C fx] - [greatest-fixnum C fx] - [fx* C fx] - [fx*/carry C fx] - [fx+ C fx] - [fx+/carry C fx] - [fx- C fx] - [fx-/carry C fx] - [fx<=? C fx] - [fx=? C fx] - [fx>? C fx] - [fxand C fx] - [fxarithmetic-shift C fx] - [fxarithmetic-shift-left C fx] - [fxarithmetic-shift-right C fx] - [fxbit-count C fx] - [fxbit-field C fx] - [fxbit-set? C fx] - [fxcopy-bit C fx] - [fxcopy-bit-field C fx] - [fxdiv C fx] - [fxdiv-and-mod C fx] - [fxdiv0 C fx] - [fxdiv0-and-mod0 C fx] - [fxeven? C fx] - [fxfirst-bit-set C fx] - [fxif C fx] - [fxior C fx] - [fxlength C fx] - [fxmax C fx] - [fxmin C fx] - [fxmod C fx] - [fxmod0 C fx] - [fxnegative? C fx] - [fxnot C fx] - [fxodd? C fx] - [fxpositive? C fx] - [fxreverse-bit-field S fx] - [fxrotate-bit-field S fx] - [fxxor C fx] - [fxzero? C fx] - ;;; - [fixnum->flonum C fl] - [fl* C fl] - [fl+ C fl] - [fl- C fl] - [fl/ C fl] - [fl<=? C fl] - [fl=? C fl] - [fl>? C fl] - [flabs C fl] - [flacos C fl] - [flasin C fl] - [flatan C fl] - [flceiling C fl] - [flcos C fl] - [fldenominator C fl] - [fldiv C fl] - [fldiv-and-mod C fl] - [fldiv0 C fl] - [fldiv0-and-mod0 C fl] - [fleven? C fl] - [flexp C fl] - [flexpt C fl] - [flfinite? C fl] - [flfloor C fl] - [flinfinite? C fl] - [flinteger? C fl] - [fllog C fl] - [flmax C fl] - [flmin C fl] - [flmod C fl] - [flmod0 C fl] - [flnan? C fl] - [flnegative? C fl] - [flnumerator C fl] - [flodd? C fl] - [flonum? C fl] - [flpositive? C fl] - [flround C fl] - [flsin C fl] - [flsqrt C fl] - [fltan C fl] - [fltruncate C fl] - [flzero? C fl] - [real->flonum C fl] - [make-no-infinities-violation C fl] - [make-no-nans-violation C fl] - [&no-infinities C fl] - [no-infinities-violation? C fl] - [&no-nans C fl] - [no-nans-violation? C fl] - ;;; - [bytevector->sint-list C bv] - [bytevector->u8-list C bv] - [bytevector->uint-list C bv] - [bytevector-copy C bv] - [bytevector-copy! C bv] - [bytevector-fill! C bv] - [bytevector-ieee-double-native-ref C bv] - [bytevector-ieee-double-native-set! C bv] - [bytevector-ieee-double-ref C bv] - [bytevector-ieee-double-set! C bv] - [bytevector-ieee-single-native-ref C bv] - [bytevector-ieee-single-native-set! C bv] - [bytevector-ieee-single-ref C bv] - [bytevector-ieee-single-set! C bv] - [bytevector-length C bv] - [bytevector-s16-native-ref C bv] - [bytevector-s16-native-set! C bv] - [bytevector-s16-ref C bv] - [bytevector-s16-set! C bv] - [bytevector-s32-native-ref C bv] - [bytevector-s32-native-set! C bv] - [bytevector-s32-ref C bv] - [bytevector-s32-set! C bv] - [bytevector-s64-native-ref C bv] - [bytevector-s64-native-set! C bv] - [bytevector-s64-ref C bv] - [bytevector-s64-set! C bv] - [bytevector-s8-ref C bv] - [bytevector-s8-set! C bv] - [bytevector-sint-ref C bv] - [bytevector-sint-set! C bv] - [bytevector-u16-native-ref C bv] - [bytevector-u16-native-set! C bv] - [bytevector-u16-ref C bv] - [bytevector-u16-set! C bv] - [bytevector-u32-native-ref C bv] - [bytevector-u32-native-set! C bv] - [bytevector-u32-ref C bv] - [bytevector-u32-set! C bv] - [bytevector-u64-native-ref C bv] - [bytevector-u64-native-set! C bv] - [bytevector-u64-ref C bv] - [bytevector-u64-set! C bv] - [bytevector-u8-ref C bv] - [bytevector-u8-set! C bv] - [bytevector-uint-ref C bv] - [bytevector-uint-set! C bv] - [bytevector=? C bv] - [bytevector? C bv] - [endianness C bv] - [native-endianness C bv] - [sint-list->bytevector C bv] - [string->utf16 S bv] - [string->utf32 S bv] - [string->utf8 C bv] - [u8-list->bytevector C bv] - [uint-list->bytevector C bv] - [utf8->string C bv] - [utf16->string S bv] - [utf32->string S bv] - ;;; - [condition? C co] - [&assertion C co] - [assertion-violation? C co] - [&condition C co] - [condition C co] - [condition-accessor C co] - [condition-irritants C co] - [condition-message C co] - [condition-predicate C co] - [condition-who C co] - [define-condition-type C co] - [&error C co] - [error? C co] - [&implementation-restriction C co] - [implementation-restriction-violation? C co] - [&irritants C co] - [irritants-condition? C co] - [&lexical C co] - [lexical-violation? C co] - [make-assertion-violation C co] - [make-error C co] - [make-implementation-restriction-violation C co] - [make-irritants-condition C co] - [make-lexical-violation C co] - [make-message-condition C co] - [make-non-continuable-violation C co] - [make-serious-condition C co] - [make-syntax-violation C co] - [make-undefined-violation C co] - [make-violation C co] - [make-warning C co] - [make-who-condition C co] - [&message C co] - [message-condition? C co] - [&non-continuable C co] - [non-continuable-violation? C co] - [&serious C co] - [serious-condition? C co] - [simple-conditions C co] - [&syntax C co] - [syntax-violation C co sc] - [syntax-violation-form C co] - [syntax-violation-subform C co] - [syntax-violation? C co] - [&undefined C co] - [undefined-violation? C co] - [&violation C co] - [violation? C co] - [&warning C co] - [warning? C co] - [&who C co] - [who-condition? C co] - ;;; - [case-lambda C ct] - [do C ct se ne] - [unless C ct] - [when C ct] - ;;; - [define-enumeration C en] - [enum-set->list C en] - [enum-set-complement C en] - [enum-set-constructor C en] - [enum-set-difference C en] - [enum-set-indexer C en] - [enum-set-intersection C en] - [enum-set-member? C en] - [enum-set-projection C en] - [enum-set-subset? C en] - [enum-set-union C en] - [enum-set-universe C en] - [enum-set=? C en] - [make-enumeration C en] - ;;; - [environment C ev] - [eval C ev se] - ;;; - [raise C ex] - [raise-continuable C ex] - [with-exception-handler C ex] - [guard C ex] - ;;; - [binary-port? C ip] - [buffer-mode C ip] - [buffer-mode? C ip] - [bytevector->string S ip] - [string->bytevector S ip] - [call-with-bytevector-output-port C ip] - [call-with-port C ip] - [call-with-string-output-port C ip] - ;;; - [assoc C ls se] - [assp C ls] - [assq C ls se] - [assv C ls se] - [cons* C ls] - [filter C ls] - [find C ls] - [fold-left C ls] - [fold-right C ls] - [for-all C ls] - [exists C ls] - [member C ls se] - [memp C ls] - [memq C ls se] - [memv C ls se] - [partition C ls] - [remq C ls] - [remp C ls] - [remv C ls] - [remove C ls] - ;;; - [set-car! C mp se] - [set-cdr! C mp se] - ;;; - [string-set! C ms se] - [string-fill! C ms se] - ;;; - [command-line C pr] - [exit C pr] - ;;; - [delay C r5 se ne] - [exact->inexact C r5 se] - [force C r5 se] - [inexact->exact C r5 se] - [modulo C r5 se] - [remainder C r5 se] - [null-environment C r5 se] - [quotient C r5 se] - [scheme-report-environment C r5 se] - ;;; - [close-port C ip] - [eol-style C ip] - [error-handling-mode C ip] - [file-options C ip] - [flush-output-port C ip] - [get-bytevector-all C ip] - [get-bytevector-n C ip] - [get-bytevector-n! C ip] - [get-bytevector-some C ip] - [get-char C ip] - [get-datum C ip] - [get-line C ip] - [get-string-all C ip] - [get-string-n C ip] - [get-string-n! C ip] - [get-u8 C ip] - [&i/o C ip is fi] - [&i/o-decoding C ip] - [i/o-decoding-error? C ip] - [&i/o-encoding C ip] - [i/o-encoding-error-char C ip] - [i/o-encoding-error? C ip] - [i/o-error-filename C ip is fi] - [i/o-error-port C ip is fi] - [i/o-error? C ip is fi] - [&i/o-file-already-exists C ip is fi] - [i/o-file-already-exists-error? C ip is fi] - [&i/o-file-does-not-exist C ip is fi] - [i/o-file-does-not-exist-error? C ip is fi] - [&i/o-file-is-read-only C ip is fi] - [i/o-file-is-read-only-error? C ip is fi] - [&i/o-file-protection C ip is fi] - [i/o-file-protection-error? C ip is fi] - [&i/o-filename C ip is fi] - [i/o-filename-error? C ip is fi] - [&i/o-invalid-position C ip is fi] - [i/o-invalid-position-error? C ip is fi] - [&i/o-port C ip is fi] - [i/o-port-error? C ip is fi] - [&i/o-read C ip is fi] - [i/o-read-error? C ip is fi] - [&i/o-write C ip is fi] - [i/o-write-error? C ip is fi] - [lookahead-char C ip] - [lookahead-u8 C ip] - [make-bytevector C bv] - [make-custom-binary-input-port C ip] - [make-custom-binary-output-port C ip] - [make-custom-textual-input-port C ip] - [make-custom-textual-output-port C ip] - [make-custom-binary-input/output-port S ip] - [make-custom-textual-input/output-port S ip] - [make-i/o-decoding-error C ip] - [make-i/o-encoding-error C ip] - [make-i/o-error C ip is fi] - [make-i/o-file-already-exists-error C ip is fi] - [make-i/o-file-does-not-exist-error C ip is fi] - [make-i/o-file-is-read-only-error C ip is fi] - [make-i/o-file-protection-error C ip is fi] - [make-i/o-filename-error C ip is fi] - [make-i/o-invalid-position-error C ip is fi] - [make-i/o-port-error C ip is fi] - [make-i/o-read-error C ip is fi] - [make-i/o-write-error C ip is fi] - [latin-1-codec C ip] - [make-transcoder C ip] - [native-eol-style C ip] - [native-transcoder C ip] - [open-bytevector-input-port C ip] - [open-bytevector-output-port C ip] - [open-file-input-port C ip] - [open-file-input/output-port S ip] - [open-file-output-port C ip] - [open-string-input-port C ip] - [open-string-output-port C ip] - [output-port-buffer-mode S ip] - [port-eof? C ip] - [port-has-port-position? S ip] - [port-has-set-port-position!? S ip] - [port-position S ip] - [port-transcoder C ip] - [port? C ip] - [put-bytevector C ip] - [put-char C ip] - [put-datum C ip] - [put-string C ip] - [put-u8 C ip] - [set-port-position! S ip] - [standard-error-port C ip] - [standard-input-port C ip] - [standard-output-port C ip] - [textual-port? C ip] - [transcoded-port C ip] - [transcoder-codec C ip] - [transcoder-eol-style C ip] - [transcoder-error-handling-mode C ip] - [utf-16-codec C ip] - [utf-8-codec C ip] - ;;; - [input-port? C is ip se] - [output-port? C is ip se] - [current-input-port C ip is se] - [current-output-port C ip is se] - [current-error-port C ip is] - [eof-object C ip is se] - [eof-object? C ip is] - [close-input-port C is se] - [close-output-port C is se] - [display C is se] - [newline C is se] - [open-input-file C is se] - [open-output-file C is se] - [peek-char C is se] - [read C is se] - [read-char C is se] - [with-input-from-file C is se] - [with-output-to-file C is se] - [write C is se] - [write-char C is se] - [call-with-input-file C is se] - [call-with-output-file C is se] - ;;; - [hashtable-clear! C ht] - [hashtable-contains? C ht] - [hashtable-copy C ht] - [hashtable-delete! C ht] - [hashtable-entries C ht] - [hashtable-keys C ht] - [hashtable-mutable? C ht] - [hashtable-ref C ht] - [hashtable-set! C ht] - [hashtable-size C ht] - [hashtable-update! C ht] - [hashtable? C ht] - [make-eq-hashtable C ht] - [make-eqv-hashtable S ht] - [hashtable-hash-function S ht] - [make-hashtable S ht] - [hashtable-equivalence-function S ht] - [equal-hash S ht] - [string-hash C ht] - [string-ci-hash C ht] - [symbol-hash C ht] - ;;; - [list-sort C sr] - [vector-sort C sr] - [vector-sort! C sr] - ;;; - [file-exists? C fi] - [delete-file C fi] - ;;; - [define-record-type C rs] - [fields C rs] - [immutable C rs] - [mutable C rs] - [opaque C rs] - [parent C rs] - [parent-rtd C rs] - [protocol C rs] - [record-constructor-descriptor C rs] - [record-type-descriptor C rs] - [sealed C rs] - [nongenerative C rs] - ;;; - [record-field-mutable? C ri] - [record-rtd C ri] - [record-type-field-names C ri] - [record-type-generative? C ri] - [record-type-name C ri] - [record-type-opaque? C ri] - [record-type-parent C ri] - [record-type-sealed? C ri] - [record-type-uid C ri] - [record? C ri] - ;;; - [make-record-constructor-descriptor C rp] - [make-record-type-descriptor C rp] - [record-accessor C rp] - [record-constructor C rp] - [record-mutator C rp] - [record-predicate C rp] - [record-type-descriptor? C rp] - ;;; - [bound-identifier=? C sc] - [datum->syntax C sc] - [syntax C sc] - [syntax->datum C sc] - [syntax-case C sc] - [unsyntax C sc] - [unsyntax-splicing C sc] - [quasisyntax C sc] - [with-syntax C sc] - [free-identifier=? C sc] - [generate-temporaries C sc] - [identifier? C sc] - [make-variable-transformer C sc] - ;;; - [char-alphabetic? C uc se] - [char-ci<=? C uc se] - [char-ci=? C uc se] - [char-ci>? C uc se] - [char-downcase C uc se] - [char-foldcase C uc] - [char-titlecase C uc] - [char-upcase C uc se] - [char-general-category C uc] - [char-lower-case? C uc se] - [char-numeric? C uc se] - [char-title-case? C uc] - [char-upper-case? C uc se] - [char-whitespace? C uc se] - [string-ci<=? C uc se] - [string-ci=? C uc se] - [string-ci>? C uc se] - [string-downcase S uc] - [string-foldcase C uc] - [string-normalize-nfc S uc] - [string-normalize-nfd S uc] - [string-normalize-nfkc S uc] - [string-normalize-nfkd S uc] - [string-titlecase S uc] - [string-upcase S uc] - ;;; - [char-ready? S ] - [interaction-environment S ] - [load S ] - ;;; - )) - - -(define (no-dups ls) - (unless (null? ls) - (when (memq (car ls) (cdr ls)) - (error #f "duplicate identifier" (car ls))) - (no-dups (cdr ls)))) - -(define (assert-id x) - (unless (and (>= (length x) 2) - (let ([name (car x)] - [status (cadr x)] - [libs (cddr x)]) - (no-dups libs) - (and (assq status status-names) - (andmap (lambda (x) - (assq x library-names)) - libs)))) - (error #f "invalid identifier" x))) - - -(define (filter* ls) - (filter - (lambda (x) - (not (null? (filter - (lambda (x) - (memq x ls)) - (cdr x))))) - identifier-names)) - -(define (count-status x) - (length (filter* (list x)))) - -(define (join s ls) - (cond - [(null? ls) ""] - [(null? (cdr ls)) (format "~a" (car ls))] - [else - (format "~a~a~a" (car ls) s (join s (cdr ls)))])) - -(define (status-str x) - (cond - [(assq x identifier-names) - => - (lambda (x) - (let ([st (cadr x)] [libs (cddr x)]) - (format "(~a ~a)" st (join "," libs))))] - [else (error #f "invalid identifier" x)])) - -(define (print-ids ls) - (define (split ls n) - (cond - [(null? ls) (values '() '())] - [(> (string-length (car ls)) n) - (values '() ls)] - [else - (let-values ([(fst rest) - (split (cdr ls) - (- n - (string-length (car ls))))]) - (values (cons (car ls) fst) rest))])) - (define (print-ids ls) - (unless (null? ls) - (let-values ([(ls rest) - (split ls 72)]) - (for-each display ls) - (newline) - (print-ids rest)))) - (print-ids - (map (lambda (x) (format "~s ~a " x (status-str x))) ls))) - - -(define (split p ls) - (cond - [(null? ls) (values '() '())] - [else - (let-values ([(ls1 ls2) - (split p (cdr ls))]) - (if (p (car ls)) - (values (cons (car ls) ls1) ls2) - (values ls1 (cons (car ls) ls2))))])) - -(define (null-intersection? ls1 ls2) - (cond - [(null? ls1) #t] - [(memq (car ls1) ls2) #f] - [else (null-intersection? (cdr ls1) ls2)])) - - -(define (library-info lib) - (let ([inf (map (lambda (x) (cons (car x) 0)) status-names)]) - (for-each - (lambda (x) - (let ([s (cadr x)] - [l* (cddr x)]) - (cond - [(and (memq lib l*) (assq s inf)) => - (lambda (x) - (set-cdr! x (add1 (cdr x))))]))) - identifier-names) - (join " " - (map (lambda (x) - (format "~a=~a" (car x) (cdr x))) - (filter - (lambda (x) - (not (zero? (cdr x)))) - inf))))) - -(no-dups (map car identifier-names)) -(no-dups (map car library-names)) -(no-dups (map car status-names)) -(for-each assert-id identifier-names) - - -(let ([args (cdr (command-line-arguments))] - [exe (car (command-line-arguments))]) - (cond - [(null? args) - (printf "usage: ~a (|)*\n\n" exe) - (printf "Library Names:\n") - (for-each - (lambda (x) - (printf " ~a ~a ~a\n" (car x) (cadr x) - (library-info (car x)))) - library-names) - (printf "Status Codes:\n") - (let* ([s* (map - (lambda (x) - (count-status (car x))) - status-names)] - [all (apply + s*)]) - (for-each - (lambda (x s) - (printf " ~a ~a (~s ids == ~s%)\n" - (car x) (cadr x) - s - (/ (round (* (/ s all) 10000)) 100.0))) - status-names s*))] - [else - (let-values ([(s* l*) - (split - (lambda (x) - (cond - [(assq x status-names) #t] - [(assq x library-names) #f] - [else (error #f "invalid argument" x)])) - (map string->symbol args))]) - (let ([ls (filter - (lambda (x) - (let ([s (cadr x)] - [libs (cddr x)]) - (cond - [(null? l*) (memq s s*)] - [(null? s*) - (not (null-intersection? l* libs))] - [else - (and (memq s s*) - (not (null-intersection? l* libs)))]))) - identifier-names)]) - (printf "~s identifiers\n" (length ls)) - (print-ids (map car ls))))] - )) - diff --git a/src/ikarus-symbol-table.c b/src/ikarus-symbol-table.c index e683122..32e32dd 100644 --- a/src/ikarus-symbol-table.c +++ b/src/ikarus-symbol-table.c @@ -32,14 +32,18 @@ make_symbol_table(ikpcb* pcb){ return st; } + +/* one-at-a-time from http://burtleburtle.net/bob/hash/doobs.html */ static long int compute_hash(ikptr str){ long int len = unfix(ref(str, off_string_length)); - char* data = (char*)(long) str + off_string_data; - long int h = len; - char* last = data + len * string_char_size; + int* data = (int*)(str + off_string_data); + int h = len; + int* last = data + len; + + /* one-at-a-time */ while(data < last){ - char c = *data; + int c = (*data >> 8); h = h + c; h = h + (h << 10); h = h ^ (h >> 6); @@ -184,11 +188,25 @@ ikrt_unintern_gensym(ikptr sym, ikpcb* pcb){ return false_object; } +ikptr +ikrt_get_symbol_table(ikpcb* pcb){ + ikptr st = pcb->symbol_table; + pcb->symbol_table = false_object; + if(st == false_object) { + fprintf(stderr, "bug in ikarus, attempt to access dead symbol table\n"); + exit(-1); + } + return st; +} ikptr ikrt_string_to_symbol(ikptr str, ikpcb* pcb){ ikptr st = pcb->symbol_table; + if(st == false_object) { + fprintf(stderr, "bug in ikarus, attempt to access dead symbol table\n"); + exit(-1); + } if(st == 0){ st = make_symbol_table(pcb); pcb->symbol_table = st;