From 908874be9287fec78a51d3df9c6651fe7c4afa57 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sun, 30 Apr 2017 17:19:09 +0200 Subject: [PATCH 1/3] Move lo-level hash tables to the "internal" unit & module. Low-level hash tables were in eval.scm, but that unit itself no longer uses any hash tables directly, so it makes no sense to keep it there. By moving it to chicken.internal, we can also get rid of the ##sys# prefixes on each of these procedures, which cleans the code up considerably. This should also make custom builds _without_ the eval unit easier, because it turns out that quite a few units were relying on eval by way of low-level hash tables. This was also obscured by the fact that the "uses" declarations didn't mention eval. --- batch-driver.scm | 7 +++--- c-backend.scm | 12 +++++----- chicken-profile.scm | 7 +++--- core.scm | 30 ++++++++++++------------ csi.scm | 7 +++--- eval.scm | 50 --------------------------------------- expand.scm | 3 ++- internal.scm | 67 +++++++++++++++++++++++++++++++++++++++++++++++++++-- optimizer.scm | 14 ++++++----- read-syntax.scm | 7 +++--- rules.make | 13 ++++++++--- scrutinizer.scm | 5 ++-- support.scm | 49 ++++++++++++++++++++------------------- 13 files changed, 150 insertions(+), 121 deletions(-) diff --git a/batch-driver.scm b/batch-driver.scm index d57d5dd..be86ab1 100644 --- a/batch-driver.scm +++ b/batch-driver.scm @@ -28,7 +28,7 @@ (declare (unit batch-driver) (uses extras data-structures pathname - support compiler-syntax compiler optimizer + support compiler-syntax compiler optimizer internal ;; TODO: Backend should be configurable scrutinizer lfa2 c-platform c-backend user-pass)) @@ -39,6 +39,7 @@ chicken.data-structures chicken.format chicken.gc + chicken.internal chicken.pathname chicken.platform chicken.pretty-print @@ -115,7 +116,7 @@ (append default-standard-bindings default-extended-bindings internal-bindings) ) ) - (##sys#hash-table-for-each + (hash-table-for-each (lambda (sym plist) (let ([val #f] (lval #f) @@ -598,7 +599,7 @@ (map (lambda (il) (->string (car il))) import-libraries) ", "))) - (and-let* ((reqs (##sys#hash-table-ref file-requirements 'dynamic)) + (and-let* ((reqs (hash-table-ref file-requirements 'dynamic)) (missing (remove (cut ##sys#find-extension <> #f) reqs))) (when (null? (lset-intersection/eq? '(eval repl) used-units)) (notice ; XXX only issued when "-verbose" is used diff --git a/c-backend.scm b/c-backend.scm index 5d484c5..146086d 100644 --- a/c-backend.scm +++ b/c-backend.scm @@ -82,7 +82,7 @@ ;; Some helper procedures (define (find-lambda id) - (or (##sys#hash-table-ref lambda-table id) + (or (hash-table-ref lambda-table id) (bomb "can't find lambda" id) ) ) ;; Compile a single expression @@ -612,7 +612,7 @@ (define (prototypes) (gen #t) - (##sys#hash-table-for-each + (hash-table-for-each (lambda (id ll) (let* ((n (lambda-literal-argument-count ll)) (customizable (lambda-literal-customizable ll)) @@ -660,7 +660,7 @@ ((>= i n)) (gen #t "C_word t" i "=av[" j "];"))) - (##sys#hash-table-for-each + (hash-table-for-each (lambda (id ll) (let* ([argc (lambda-literal-argument-count ll)] [rest (lambda-literal-rest-argument ll)] @@ -773,7 +773,7 @@ (else (bomb "invalid unboxed type" t)))) (define (procedures) - (##sys#hash-table-for-each + (hash-table-for-each (lambda (id ll) (let* ((n (lambda-literal-argument-count ll)) (rname (real-name id db)) @@ -961,8 +961,8 @@ (define (emit-procedure-table lambda-table sf) (gen #t #t "#ifdef C_ENABLE_PTABLES" - #t "static C_PTABLE_ENTRY ptable[" (add1 (##sys#hash-table-size lambda-table)) "] = {") - (##sys#hash-table-for-each + #t "static C_PTABLE_ENTRY ptable[" (add1 (hash-table-size lambda-table)) "] = {") + (hash-table-for-each (lambda (id ll) (gen #t "{\"" id #\: (string->c-identifier sf) "\",(void*)") (if (eq? 'toplevel id) diff --git a/chicken-profile.scm b/chicken-profile.scm index c85ac06..78582a8 100644 --- a/chicken-profile.scm +++ b/chicken-profile.scm @@ -27,6 +27,7 @@ (declare (block)) (import chicken.data-structures + chicken.internal chicken.posix) (include "mini-srfi-1.scm") @@ -160,13 +161,13 @@ EOF (type (if (symbol? header) header 'instrumented))) (do ((line (if (symbol? header) (read) header) (read))) ((eof-object? line)) - (##sys#hash-table-set! + (hash-table-set! hash (first line) (map (lambda (x y) (and x y (+ x y))) - (or (##sys#hash-table-ref hash (first line)) '(0 0)) + (or (hash-table-ref hash (first line)) '(0 0)) (cdr line)))) (let ((alist '())) - (##sys#hash-table-for-each + (hash-table-for-each (lambda (sym counts) (set! alist (alist-cons sym counts alist))) hash) diff --git a/core.scm b/core.scm index ff81df9..a9c2510 100644 --- a/core.scm +++ b/core.scm @@ -473,7 +473,7 @@ (nglobs 0) (entries 0) (nsites 0) ) - (##sys#hash-table-for-each + (hash-table-for-each (lambda (sym plist) (for-each (lambda (prop) @@ -547,9 +547,9 @@ (let ((x (lookup x0 se))) (d `(RESOLVE-VARIABLE: ,x0 ,x ,(map (lambda (x) (car x)) se))) (cond ((not (symbol? x)) x0) ; syntax? - ((##sys#hash-table-ref constant-table x) + ((hash-table-ref constant-table x) => (lambda (val) (walk val e se dest ldest h #f #f))) - ((##sys#hash-table-ref inline-table x) + ((hash-table-ref inline-table x) => (lambda (val) (walk val e se dest ldest h #f #f))) ((assq x foreign-variables) => (lambda (fv) @@ -626,7 +626,7 @@ (cond ((not (eq? x xexpanded)) (walk xexpanded e se dest ldest h ln tl?)) - ((##sys#hash-table-ref inline-table name) + ((hash-table-ref inline-table name) => (lambda (val) (walk (cons val (cdr x)) e se dest ldest h ln #f))) @@ -704,7 +704,7 @@ static-extensions register-static-extension))) (unless (not type) - (##sys#hash-table-update! + (hash-table-update! file-requirements type (cut lset-adjoin/eq? <> id) (cut list id))) @@ -1272,7 +1272,7 @@ "~ainline definition of `~s' in non-toplevel context" (if ln (sprintf "(~a) - " ln) "") name)) - (##sys#hash-table-set! inline-table name val) + (hash-table-set! inline-table name val) '(##core#undefined))) ((##core#define-constant) @@ -1297,11 +1297,11 @@ (set! defconstant-bindings (cons (list name `(##core#quote ,val)) defconstant-bindings)) (cond ((collapsable-literal? val) - (##sys#hash-table-set! constant-table name `(##core#quote ,val)) + (hash-table-set! constant-table name `(##core#quote ,val)) '(##core#undefined)) ((basic-literal? val) (let ((var (gensym "constant"))) - (##sys#hash-table-set! constant-table name var) + (hash-table-set! constant-table name var) (hide-variable var) (mark-variable var '##compiler#constant) (mark-variable var '##compiler#always-bound) @@ -1425,9 +1425,9 @@ (cons name ##sys#syntax-context))) (mapwalk x e se h ln tl?))) (head2 (car x2)) - (old (##sys#hash-table-ref line-number-database-2 head2)) ) + (old (hash-table-ref line-number-database-2 head2)) ) (when ln - (##sys#hash-table-set! + (hash-table-set! line-number-database-2 head2 (cons name (alist-cons x2 ln (if old (cdr old) '()))) ) ) @@ -1496,7 +1496,7 @@ (when (pair? us) (set! provided (append provided us)) (set! used-units (append used-units us)) - (##sys#hash-table-update! + (hash-table-update! file-requirements 'static (cut lset-union/eq? us <>) (lambda () us))))) @@ -1853,9 +1853,9 @@ (cond ((not (pair? x))) ((symbol? (car x)) (let* ((name (car x)) - (old (or (##sys#hash-table-ref ##sys#line-number-database name) '())) ) + (old (or (hash-table-ref ##sys#line-number-database name) '())) ) (unless (assq x old) - (##sys#hash-table-set! ##sys#line-number-database name (alist-cons x ln old)) ) + (hash-table-set! ##sys#line-number-database name (alist-cons x ln old)) ) (mapupdate (cdr x)) ) ) (else (mapupdate x)) ) ) (walk exp) ) @@ -2160,7 +2160,7 @@ ;; Complete gathered database information: (debugging 'p "analysis gathering phase...") (set! current-analysis-database-size 0) - (##sys#hash-table-for-each + (hash-table-for-each (lambda (sym plist) (let ([unknown #f] [value #f] @@ -2822,7 +2822,7 @@ (debugging 'o "unused rest argument" rest id)) (when (and direct rest) (bomb "bad direct lambda" id allocated rest) ) - (##sys#hash-table-set! + (hash-table-set! lambda-table id (make-lambda-literal diff --git a/csi.scm b/csi.scm index 321c418..468a14d 100644 --- a/csi.scm +++ b/csi.scm @@ -49,8 +49,9 @@ EOF chicken.foreign chicken.format chicken.gc - chicken.keyword + chicken.internal chicken.io + chicken.keyword chicken.platform chicken.port chicken.pretty-print @@ -705,7 +706,7 @@ EOF (##sys#slot x 1) ) ) ((##sys#generic-structure? x) (let ([st (##sys#slot x 0)]) - (cond ((##sys#hash-table-ref describer-table st) => (cut <> x out)) + (cond ((hash-table-ref describer-table st) => (cut <> x out)) ((assq st bytevector-data) => (lambda (data) (apply descseq (append (map eval (cdr data)) (list 0)))) ) @@ -717,7 +718,7 @@ EOF (define (set-describer! tag proc) (##sys#check-symbol tag 'set-describer!) - (##sys#hash-table-set! describer-table tag proc) ) + (hash-table-set! describer-table tag proc) ) ;;; Display hexdump: diff --git a/eval.scm b/eval.scm index 12521f1..2e1ed1f 100644 --- a/eval.scm +++ b/eval.scm @@ -42,8 +42,6 @@ #ifndef C_BINARY_VERSION # define C_BINARY_VERSION 0 #endif - -#define C_rnd_fix() (C_fix(rand())) <# (module chicken.eval @@ -138,54 +136,6 @@ (##core#inline "C_i_providedp" id)) -;;; Lo-level hashtable support: - -(define ##sys#hash-symbol - (let ([cache-s #f] - [cache-h #f] - ;; NOTE: All low-level hash tables share the same randomization factor - [rand (##core#inline "C_rnd_fix")] ) - (lambda (s n) - (if (eq? s cache-s) - (##core#inline "C_fixnum_modulo" cache-h n) - (begin - (set! cache-s s) - (set! cache-h (##core#inline "C_u_i_string_hash" (##sys#slot s 1) rand)) - (##core#inline "C_fixnum_modulo" cache-h n)))))) - -(define (##sys#hash-table-ref ht key) - (let loop ((bucket (##sys#slot ht (##sys#hash-symbol key (##core#inline "C_block_size" ht))))) - (and (not (eq? '() bucket)) - (if (eq? key (##sys#slot (##sys#slot bucket 0) 0)) - (##sys#slot (##sys#slot bucket 0) 1) - (loop (##sys#slot bucket 1)))))) - -(define (##sys#hash-table-set! ht key val) - (let* ((k (##sys#hash-symbol key (##core#inline "C_block_size" ht))) - (ib (##sys#slot ht k))) - (let loop ((bucket ib)) - (if (eq? '() bucket) - (##sys#setslot ht k (cons (cons key val) ib)) - (if (eq? key (##sys#slot (##sys#slot bucket 0) 0)) - (##sys#setslot (##sys#slot bucket 0) 1 val) - (loop (##sys#slot bucket 1))))))) - -(define (##sys#hash-table-update! ht key updtfunc valufunc) - (##sys#hash-table-set! ht key (updtfunc (or (##sys#hash-table-ref ht key) (valufunc)))) ) - -(define (##sys#hash-table-for-each p ht) - (let ((len (##core#inline "C_block_size" ht))) - (do ((i 0 (fx+ i 1))) - ((fx>= i len)) - (##sys#for-each (lambda (bucket) (p (##sys#slot bucket 0) (##sys#slot bucket 1))) - (##sys#slot ht i) ) ) ) ) - -(define (##sys#hash-table-size ht) - (let loop ((len (##sys#size ht)) (bkt 0) (size 0)) - (if (fx= bkt len) - size - (loop len (fx+ bkt 1) (fx+ size (##sys#length (##sys#slot ht bkt))))))) - ;;; Compile lambda to closure: (define (eval-decorator p ll h cntr) diff --git a/expand.scm b/expand.scm index 9e6b1d5..33469e9 100644 --- a/expand.scm +++ b/expand.scm @@ -52,6 +52,7 @@ expansion-result-hook) (import scheme chicken + chicken.internal chicken.keyword chicken.platform) @@ -737,7 +738,7 @@ (pair? sexp) (let ([head (car sexp)]) (and (symbol? head) - (cond [(##sys#hash-table-ref ##sys#line-number-database head) + (cond [(hash-table-ref ##sys#line-number-database head) => (lambda (pl) (let ([a (assq sexp pl)]) (and a (cdr a)) ) ) ] diff --git a/internal.scm b/internal.scm index 9e4254b..b8a7fbb 100644 --- a/internal.scm +++ b/internal.scm @@ -29,9 +29,24 @@ (disable-interrupts) (fixnum)) +;; This is a bit of a grab-bag of stuff that's used in various places +;; in the runtime and the compiler, but which is not supposed to be +;; used by the user, and doesn't strictly belong anywhere in +;; particular. (module chicken.internal - (library-id valid-library-specifier? - module-requirement string->c-identifier) + ( + ;; Convert string into valid C-identifier + string->c-identifier + + ;; Parse library specifications + library-id valid-library-specifier? + + ;; Requirement identifier for modules + module-requirement + + ;; lo-level hash table support + hash-table-ref hash-table-set! hash-table-update! + hash-table-for-each hash-table-size) (import scheme chicken) @@ -98,4 +113,52 @@ (##sys#string-append (##sys#slot id 1) "#"))) +;;; Lo-level hashtable support: + +(define hash-symbol + (let ((cache-s #f) + (cache-h #f) + ;; NOTE: All low-level hash tables share the same randomization factor + (rand (##core#inline "C_random_fixnum" #x10000)) ) + (lambda (s n) + (if (eq? s cache-s) + (##core#inline "C_fixnum_modulo" cache-h n) + (begin + (set! cache-s s) + (set! cache-h (##core#inline "C_u_i_string_hash" (##sys#slot s 1) rand)) + (##core#inline "C_fixnum_modulo" cache-h n)))))) + +(define (hash-table-ref ht key) + (let loop ((bucket (##sys#slot ht (hash-symbol key (##core#inline "C_block_size" ht))))) + (and (not (eq? '() bucket)) + (if (eq? key (##sys#slot (##sys#slot bucket 0) 0)) + (##sys#slot (##sys#slot bucket 0) 1) + (loop (##sys#slot bucket 1)))))) + +(define (hash-table-set! ht key val) + (let* ((k (hash-symbol key (##core#inline "C_block_size" ht))) + (ib (##sys#slot ht k))) + (let loop ((bucket ib)) + (if (eq? '() bucket) + (##sys#setslot ht k (cons (cons key val) ib)) + (if (eq? key (##sys#slot (##sys#slot bucket 0) 0)) + (##sys#setslot (##sys#slot bucket 0) 1 val) + (loop (##sys#slot bucket 1))))))) + +(define (hash-table-update! ht key updtfunc valufunc) + (hash-table-set! ht key (updtfunc (or (hash-table-ref ht key) (valufunc)))) ) + +(define (hash-table-for-each p ht) + (let ((len (##core#inline "C_block_size" ht))) + (do ((i 0 (fx+ i 1))) + ((fx>= i len)) + (##sys#for-each (lambda (bucket) (p (##sys#slot bucket 0) (##sys#slot bucket 1))) + (##sys#slot ht i) ) ) ) ) + +(define (hash-table-size ht) + (let loop ((len (##sys#size ht)) (bkt 0) (size 0)) + (if (fx= bkt len) + size + (loop len (fx+ bkt 1) (fx+ size (##sys#length (##sys#slot ht bkt))))))) + ) ; chicken.internal diff --git a/optimizer.scm b/optimizer.scm index a6df2fd..6c88196 100644 --- a/optimizer.scm +++ b/optimizer.scm @@ -28,6 +28,7 @@ (declare (unit optimizer) (uses data-structures + internal support) ) (module chicken.compiler.optimizer @@ -38,7 +39,8 @@ (import chicken scheme chicken.data-structures - chicken.compiler.support) + chicken.compiler.support + chicken.internal) (include "tweaks") (include "mini-srfi-1.scm") @@ -166,7 +168,7 @@ (for-each (cut set-cdr! <> #f) gae)) (define (simplify n) - (or (and-let* ((entry (##sys#hash-table-ref + (or (and-let* ((entry (hash-table-ref simplifications (node-class n)))) (any (lambda (s) (and-let* ((vars (second s)) @@ -620,7 +622,7 @@ ;;; Simplifications: (define (register-simplifications class . ss) - (##sys#hash-table-set! simplifications class ss) ) + (hash-table-set! simplifications class ss) ) (register-simplifications @@ -629,7 +631,7 @@ `((##core#call d (##core#variable (a)) b . c) (a b c d) ,(lambda (db may-rewrite a b c d) - (let loop ((entries (or (##sys#hash-table-ref substitution-table a) '()))) + (let loop ((entries (or (hash-table-ref substitution-table a) '()))) (cond ((null? entries) #f) ((simplify-named-call db may-rewrite d a b (caar entries) (cdar entries) c) @@ -933,8 +935,8 @@ (define substitution-table (make-vector 301 '())) (define (rewrite name . class-and-args) - (let ((old (or (##sys#hash-table-ref substitution-table name) '()))) - (##sys#hash-table-set! substitution-table name (append old (list class-and-args))) ) ) + (let ((old (or (hash-table-ref substitution-table name) '()))) + (hash-table-set! substitution-table name (append old (list class-and-args))) ) ) (define (simplify-named-call db may-rewrite params name cont class classargs callargs) diff --git a/read-syntax.scm b/read-syntax.scm index 9c002dd..087c9f3 100644 --- a/read-syntax.scm +++ b/read-syntax.scm @@ -26,13 +26,14 @@ (declare (unit read-syntax) + (uses internal) (disable-interrupts)) (module chicken.read-syntax (copy-read-table define-reader-ctor set-read-syntax! set-sharp-read-syntax! set-parameterized-read-syntax!) -(import scheme chicken chicken.platform) +(import scheme chicken chicken.internal chicken.platform) (include "common-declarations.scm") @@ -100,7 +101,7 @@ (define (define-reader-ctor spec proc) (##sys#check-symbol spec 'define-reader-ctor) - (##sys#hash-table-set! sharp-comma-reader-ctors spec proc)) + (hash-table-set! sharp-comma-reader-ctors spec proc)) (set! ##sys#user-read-hook (let ((old ##sys#user-read-hook) @@ -116,7 +117,7 @@ (let ([spec (##sys#slot exp 0)]) (if (not (symbol? spec)) (err) - (let ((ctor (##sys#hash-table-ref sharp-comma-reader-ctors spec))) + (let ((ctor (hash-table-ref sharp-comma-reader-ctors spec))) (if ctor (apply ctor (##sys#slot exp 1)) (##sys#read-error port "undefined sharp-comma constructor" spec)))))))) diff --git a/rules.make b/rules.make index 81fa31a..7557b07 100644 --- a/rules.make +++ b/rules.make @@ -538,6 +538,7 @@ batch-driver.c: batch-driver.scm mini-srfi-1.scm \ chicken.data-structures.import.scm \ chicken.format.import.scm \ chicken.gc.import.scm \ + chicken.internal.import.scm \ chicken.pathname.import.scm \ chicken.platform.import.scm \ chicken.pretty-print.import.scm \ @@ -570,7 +571,8 @@ core.c: core.scm mini-srfi-1.scm \ chicken.pretty-print.import.scm optimizer.c: optimizer.scm mini-srfi-1.scm \ chicken.compiler.support.import.scm \ - chicken.data-structures.import.scm + chicken.data-structures.import.scm \ + chicken.internal.import.scm scheduler.c: scheduler.scm \ chicken.format.import.scm scrutinizer.c: scrutinizer.scm mini-srfi-1.scm \ @@ -578,6 +580,7 @@ scrutinizer.c: scrutinizer.scm mini-srfi-1.scm \ chicken.data-structures.import.scm \ chicken.expand.import.scm \ chicken.format.import.scm \ + chicken.internal.import.scm \ chicken.io.import.scm \ chicken.pathname.import.scm \ chicken.platform.import.scm \ @@ -601,8 +604,9 @@ support.c: support.scm mini-srfi-1.scm \ chicken.files.import.scm \ chicken.foreign.import.scm \ chicken.format.import.scm \ - chicken.keyword.import.scm \ + chicken.internal.import.scm \ chicken.io.import.scm \ + chicken.keyword.import.scm \ chicken.pathname.import.scm \ chicken.platform.import.scm \ chicken.port.import.scm \ @@ -625,9 +629,10 @@ csi.c: csi.scm \ chicken.foreign.import.scm \ chicken.format.import.scm \ chicken.gc.import.scm \ + chicken.internal.import.scm \ + chicken.io.import.scm \ chicken.keyword.import.scm \ chicken.platform.import.scm \ - chicken.io.import.scm \ chicken.port.import.scm \ chicken.pretty-print.import.scm \ chicken.repl.import.scm @@ -643,6 +648,7 @@ chicken-bug.c: chicken-bug.scm \ chicken.time.import.scm chicken-profile.c: chicken-profile.scm \ chicken.data-structures.import.scm \ + chicken.internal.import.scm \ chicken.posix.import.scm chicken-status.c: chicken-status.scm \ chicken.data-structures.import.scm \ @@ -735,6 +741,7 @@ pathname.c: pathname.scm \ port.c: port.scm \ chicken.io.import.scm read-syntax.c: read-syntax.scm \ + chicken.internal.import.scm \ chicken.platform.import.scm tcp.c: tcp.scm \ chicken.foreign.import.scm \ diff --git a/scrutinizer.scm b/scrutinizer.scm index c3b4652..385a17c 100644 --- a/scrutinizer.scm +++ b/scrutinizer.scm @@ -26,7 +26,7 @@ (declare (unit scrutinizer) - (uses data-structures expand extras pathname port support)) + (uses data-structures expand extras pathname port support internal)) (module chicken.compiler.scrutinizer (scrutinize load-type-database emit-type-file @@ -39,6 +39,7 @@ chicken.data-structures chicken.expand chicken.format + chicken.internal chicken.io chicken.pathname chicken.platform @@ -1777,7 +1778,7 @@ (lambda () (print "; GENERATED BY CHICKEN " (chicken-version) " FROM " source-file "\n") - (##sys#hash-table-for-each + (hash-table-for-each (lambda (sym plist) (when (and (variable-visible? sym block-compilation) (memq (variable-mark sym '##compiler#type-source) '(local inference))) diff --git a/support.scm b/support.scm index f972ca3..4722688 100644 --- a/support.scm +++ b/support.scm @@ -82,8 +82,9 @@ chicken.files chicken.foreign chicken.format - chicken.keyword + chicken.internal chicken.io + chicken.keyword chicken.pathname chicken.platform chicken.port @@ -412,32 +413,32 @@ ;;; Database operations: (define (db-get db key prop) - (let ((plist (##sys#hash-table-ref db key))) + (let ((plist (hash-table-ref db key))) (and plist (let ([a (assq prop plist)]) (and a (##sys#slot a 1)) ) ) ) ) (define (db-get-all db key . props) - (let ((plist (##sys#hash-table-ref db key))) + (let ((plist (hash-table-ref db key))) (if plist (filter-map (lambda (prop) (assq prop plist)) props) '() ) ) ) (define (db-put! db key prop val) - (let ([plist (##sys#hash-table-ref db key)]) + (let ([plist (hash-table-ref db key)]) (if plist (let ([a (assq prop plist)]) (cond [a (##sys#setslot a 1 val)] [val (##sys#setslot plist 1 (alist-cons prop val (##sys#slot plist 1)))] ) ) - (when val (##sys#hash-table-set! db key (list (cons prop val)))) ) ) ) + (when val (hash-table-set! db key (list (cons prop val)))) ) ) ) (define (collect! db key prop val) - (let ((plist (##sys#hash-table-ref db key))) + (let ((plist (hash-table-ref db key))) (if plist (let ([a (assq prop plist)]) (cond [a (##sys#setslot a 1 (cons val (##sys#slot a 1)))] [else (##sys#setslot plist 1 (alist-cons prop (list val) (##sys#slot plist 1)))] ) ) - (##sys#hash-table-set! db key (list (list prop val)))) ) ) + (hash-table-set! db key (list (list prop val)))) ) ) (define (db-get-list db key prop) ; returns '() if not set (let ((x (db-get db key prop))) @@ -451,13 +452,13 @@ (define (get-line-2 exp) (let* ((name (car exp)) - (lst (##sys#hash-table-ref ##sys#line-number-database name)) ) + (lst (hash-table-ref ##sys#line-number-database name)) ) (cond ((and lst (assq exp (cdr lst))) => (lambda (a) (values (car lst) (cdr a))) ) (else (values name #f)) ) ) ) (define (display-line-number-database) - (##sys#hash-table-for-each + (hash-table-for-each (lambda (key val) (when val (printf "~S ~S~%" key (map cdr val))) ) ##sys#line-number-database) ) @@ -753,7 +754,7 @@ block-compilation inline-limit) (let ((lst '()) (out '())) - (##sys#hash-table-for-each + (hash-table-for-each (lambda (sym plist) (when (variable-visible? sym block-compilation) (and-let* ((val (assq 'local-value plist)) @@ -876,7 +877,7 @@ ;;; Some safety checks and database dumping: (define (dump-undefined-globals db) ; Used only in batch-driver.scm - (##sys#hash-table-for-each + (hash-table-for-each (lambda (sym plist) (when (and (not (keyword? sym)) (assq 'global plist) @@ -886,7 +887,7 @@ db) ) (define (dump-defined-globals db) ; Used only in batch-driver.scm - (##sys#hash-table-for-each + (hash-table-for-each (lambda (sym plist) (when (and (not (keyword? sym)) (assq 'global plist) @@ -896,7 +897,7 @@ db) ) (define (dump-global-refs db) ; Used only in batch-driver.scm - (##sys#hash-table-for-each + (hash-table-for-each (lambda (sym plist) (when (and (not (keyword? sym)) (assq 'global plist)) (let ((a (assq 'references plist))) @@ -947,15 +948,15 @@ ;; The latter two must either both be supplied, or neither. ;; TODO: Maybe create a separate record type for foreign types? (define (register-foreign-type! alias type #!optional arg ret) - (##sys#hash-table-set! foreign-type-table alias - (vector type (and ret arg) (and arg ret)))) + (hash-table-set! foreign-type-table alias + (vector type (and ret arg) (and arg ret)))) ;; Returns either #f (if t does not exist) or a vector with the type, ;; the *name* of the argument conversion procedure and the *name* of ;; the return value conversion procedure. If no conversion procedures ;; have been supplied, the corresponding slots will be #f. (define (lookup-foreign-type t) - (##sys#hash-table-ref foreign-type-table t)) + (hash-table-ref foreign-type-table t)) ;;; Create foreign type checking expression: @@ -1389,21 +1390,21 @@ (set! real-name-table (make-vector real-name-table-size '()))) (define (set-real-name! name rname) ; Used only in compiler.scm - (##sys#hash-table-set! real-name-table name rname) ) + (hash-table-set! real-name-table name rname) ) ;; TODO: Find out why there are so many lookup functions for this and ;; reduce them to the minimum. (define (get-real-name name) - (##sys#hash-table-ref real-name-table name)) + (hash-table-ref real-name-table name)) ;; Arbitrary limit to prevent runoff into exponential behavior (define real-name-max-depth 20) (define (real-name var . db) (define (resolve n) - (let ((n2 (##sys#hash-table-ref real-name-table n))) + (let ((n2 (hash-table-ref real-name-table n))) (if n2 - (or (##sys#hash-table-ref real-name-table n2) + (or (hash-table-ref real-name-table n2) n2) n) ) ) (let ((rn (resolve var))) @@ -1427,11 +1428,11 @@ (else (##sys#symbol->qualified-string rn)) ) ) ) (define (real-name2 var db) ; Used only in c-backend.scm - (and-let* ([rn (##sys#hash-table-ref real-name-table var)]) + (and-let* ([rn (hash-table-ref real-name-table var)]) (real-name rn db) ) ) (define (display-real-name-table) - (##sys#hash-table-for-each + (hash-table-for-each (lambda (key val) (printf "~S\t~S~%" key val) ) real-name-table) ) @@ -1537,12 +1538,12 @@ (define (read-info-hook class data val) ; Used here and in compiler.scm (when (and (eq? 'list-info class) (symbol? (car data))) - (##sys#hash-table-set! + (hash-table-set! ##sys#line-number-database (car data) (alist-cons data (conc ##sys#current-source-filename ":" val) - (or (##sys#hash-table-ref ##sys#line-number-database (car data)) + (or (hash-table-ref ##sys#line-number-database (car data)) '() ) ) ) ) data) -- 2.1.4