Hi all, I am struggling with the chicken.eval module. I've considered renaming it to chicken.load, but then we still need to do something with "eval" and the whole support machinery that it requires.
In any case, while pondering what to do with it, I noticed that the lo-level hash table support that is used throughout the codebase is defined in eval.scm, of all places, and eval.scm itself never uses this! So, I thought we could make eval a bit more self-contained by moving the hash table stuff into chicken.internal. While I was at it, getting rid of the ##sys# prefix seemed like a good idea as well. I also noticed that the (time) macro uses stuff from library.scm which is used nowhere else, and this also goes for the helper ##sys#take-right and ##sys#drop-right as well as ##sys#del and ##sys#nodups, so I removed those from library.scm as well. The only slightly iffy thing is that mini-srfi-1.scm has all the SRFI-1 procedures (even unused ones?), but take-right and drop-right are not in there, and in chicken.internal instead. I don't know how to clean that up yet: these two procedures need to be exported in some module, because syntax-rules expands into calls to them. This also means they can't be inlined, which was the whole point of mini-srfi-1 anyway. So I guess the post-patch situation qualifies as "okay, but surprising". Cheers, Peter
From 908874be9287fec78a51d3df9c6651fe7c4afa57 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
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
From abec1ed1afc118a7ef77ef5661b40dc2ab9ec7a0 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sun, 30 Apr 2017 17:43:12 +0200
Subject: [PATCH 2/3] Move "time" macro helper procedures to chicken.internal
These helpers are not supposed to be used directly by the user, so
let's just move it to the internal module to signal that more clearly.
This reduces the immense sprawl of library.scm a little as well.
---
batch-driver.scm | 4 ++--
c-platform.scm | 3 ++-
chicken-syntax.scm | 5 +++--
internal.scm | 64 ++++++++++++++++++++++++++++++++++++++++++++++++++++--
library.scm | 60 --------------------------------------------------
5 files changed, 69 insertions(+), 67 deletions(-)
diff --git a/batch-driver.scm b/batch-driver.scm
index be86ab1..7cb8b51 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -323,7 +323,7 @@
(set! enable-module-registration (not (memq 'no-module-registration options)))
(when enable-specialization
(set! do-scrutinize #t))
- (when (memq 't debugging-chicken) (##sys#start-timer))
+ (when (memq 't debugging-chicken) (start-timer))
(when (memq 'b debugging-chicken) (set! time-breakdown #t))
(when (memq 'raw options)
(set! explicit-use-flag #t)
@@ -831,7 +831,7 @@
(close-output-port out)))
(end-time "code generation")
(when (memq 't debugging-chicken)
- (##sys#display-times (##sys#stop-timer)))
+ (display-timer-statistics (stop-timer)))
(compiler-cleanup-hook)
(dribble "compilation finished.") ) ) ) ) ) ) ) ) ) ) ) )
)
diff --git a/c-platform.scm b/c-platform.scm
index 49bbfc0..da68409 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -59,9 +59,10 @@
##sys#standard-input ##sys#standard-output ##sys#standard-error
##sys#undefined-value)
(bound-to-procedure
+ chicken.internal#start-timer chicken.internal#stop-timer
##sys#for-each ##sys#map ##sys#print ##sys#setter
##sys#setslot ##sys#dynamic-wind ##sys#call-with-values
- ##sys#start-timer ##sys#stop-timer ##sys#gcd ##sys#lcm ##sys#make-promise ##sys#structure? ##sys#slot
+ ##sys#gcd ##sys#lcm ##sys#make-promise ##sys#structure? ##sys#slot
##sys#allocate-vector ##sys#list->vector ##sys#block-ref ##sys#block-set!
##sys#list ##sys#cons ##sys#append ##sys#vector ##sys#foreign-char-argument ##sys#foreign-fixnum-argument
##sys#foreign-flonum-argument ##sys#error ##sys#peek-c-string ##sys#peek-nonnull-c-string
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 65367b8..a1f01ab 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -150,12 +150,13 @@
(lambda (form r c)
(let ((rvar (r 't)))
`(##core#begin
- (##sys#start-timer)
+ (chicken.internal#start-timer)
(##sys#call-with-values
(##core#lambda () ,@(cdr form))
(##core#lambda
,rvar
- (##sys#display-times (##sys#stop-timer))
+ (chicken.internal#display-timer-statistics
+ (chicken.internal#stop-timer))
(##sys#apply ##sys#values ,rvar) ) ) ) ) ) ) )
(##sys#extend-macro-environment
diff --git a/internal.scm b/internal.scm
index b8a7fbb..6ef7628 100644
--- a/internal.scm
+++ b/internal.scm
@@ -26,8 +26,7 @@
(declare
(unit internal)
- (disable-interrupts)
- (fixnum))
+ (disable-interrupts) )
;; 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
@@ -35,6 +34,9 @@
;; particular.
(module chicken.internal
(
+ ;; Timing information (support for "time" macro)
+ start-timer stop-timer display-timer-statistics
+
;; Convert string into valid C-identifier
string->c-identifier
@@ -53,6 +55,64 @@
(include "common-declarations.scm")
(include "mini-srfi-1.scm")
+;;; Timing information (support for "time" macro):
+
+(define (start-timer)
+ (##sys#gc #t)
+ (##core#inline "C_start_timer"))
+
+(define (stop-timer)
+ (let ((info ((##core#primitive "C_stop_timer"))))
+ ;; Run a major GC one more time to get memory usage information in
+ ;; case there was no major GC while the timer was running
+ (##sys#gc #t)
+ (##sys#setslot info 6 (##sys#slot ((##core#primitive "C_stop_timer")) 6))
+ info))
+
+(define (display-timer-statistics info)
+ (define (pstr str) (##sys#print str #f ##sys#standard-error))
+ (define (pchr chr) (##sys#write-char-0 chr ##sys#standard-error))
+ (define (pnum num)
+ (##sys#print (if (zero? num) "0" (##sys#number->string num)) #f ##sys#standard-error))
+ (define (round-to x y) ; Convert to fp with y digits after the point
+ (/ (round (* x (expt 10 y))) (expt 10.0 y)))
+ (define (pmem bytes)
+ (cond ((> bytes (expt 1024 3))
+ (pnum (round-to (/ bytes (expt 1024 3)) 2)) (pstr " GiB"))
+ ((> bytes (expt 1024 2))
+ (pnum (round-to (/ bytes (expt 1024 2)) 2)) (pstr " MiB"))
+ ((> bytes 1024)
+ (pnum (round-to (/ bytes 1024) 2)) (pstr " KiB"))
+ (else (pnum bytes) (pstr " bytes"))))
+ (##sys#flush-output ##sys#standard-output)
+ (pnum (##sys#slot info 0))
+ (pstr "s CPU time")
+ (let ((gctime (##sys#slot info 1)))
+ (when (> gctime 0)
+ (pstr ", ")
+ (pnum gctime)
+ (pstr "s GC time (major)")))
+ (let ((mut (##sys#slot info 2))
+ (umut (##sys#slot info 3)))
+ (when (fx> mut 0)
+ (pstr ", ")
+ (pnum mut)
+ (pchr #\/)
+ (pnum umut)
+ (pstr " mutations (total/tracked)")))
+ (let ((minor (##sys#slot info 4))
+ (major (##sys#slot info 5)))
+ (when (or (fx> minor 0) (fx> major 0))
+ (pstr ", ")
+ (pnum major)
+ (pchr #\/)
+ (pnum minor)
+ (pstr " GCs (major/minor)")))
+ (let ((maximum-heap-usage (##sys#slot info 6)))
+ (pstr ", maximum live heap: ")
+ (pmem maximum-heap-usage))
+ (##sys#write-char-0 #\newline ##sys#standard-error)
+ (##sys#flush-output ##sys#standard-error))
;;; Convert string into valid C-identifier:
diff --git a/library.scm b/library.scm
index 071d85d..0b324db 100644
--- a/library.scm
+++ b/library.scm
@@ -288,18 +288,6 @@ EOF
(define get-environment-variable (foreign-lambda c-string "C_getenv" c-string))
(define executable-pathname (foreign-lambda c-string* "C_executable_pathname"))
-(define (##sys#start-timer)
- (##sys#gc #t)
- (##core#inline "C_start_timer"))
-
-(define (##sys#stop-timer)
- (let ((info ((##core#primitive "C_stop_timer"))))
- ;; Run a major GC one more time to get memory usage information in
- ;; case there was no major GC while the timer was running
- (##sys#gc #t)
- (##sys#setslot info 6 (##sys#slot ((##core#primitive "C_stop_timer")) 6))
- info))
-
(define (##sys#immediate? x) (not (##core#inline "C_blockp" x)))
(define (##sys#message str) (##core#inline "C_message" str))
(define (##sys#byte x i) (##core#inline "C_subbyte" x i))
@@ -5639,54 +5627,6 @@ EOF
(loop nxt) ) ) ) ) )
-;;; Print timing information (support for "time" macro):
-
-(define (##sys#display-times info)
- (define (pstr str) (##sys#print str #f ##sys#standard-error))
- (define (pchr chr) (##sys#write-char-0 chr ##sys#standard-error))
- (define (pnum num)
- (##sys#print (if (zero? num) "0" (##sys#number->string num)) #f ##sys#standard-error))
- (define (round-to x y) ; Convert to fp with y digits after the point
- (/ (round (* x (expt 10 y))) (expt 10.0 y)))
- (define (pmem bytes)
- (cond ((> bytes (expt 1024 3))
- (pnum (round-to (/ bytes (expt 1024 3)) 2)) (pstr " GiB"))
- ((> bytes (expt 1024 2))
- (pnum (round-to (/ bytes (expt 1024 2)) 2)) (pstr " MiB"))
- ((> bytes 1024)
- (pnum (round-to (/ bytes 1024) 2)) (pstr " KiB"))
- (else (pnum bytes) (pstr " bytes"))))
- (##sys#flush-output ##sys#standard-output)
- (pnum (##sys#slot info 0))
- (pstr "s CPU time")
- (let ((gctime (##sys#slot info 1)))
- (when (> gctime 0)
- (pstr ", ")
- (pnum gctime)
- (pstr "s GC time (major)")))
- (let ((mut (##sys#slot info 2))
- (umut (##sys#slot info 3)))
- (when (fx> mut 0)
- (pstr ", ")
- (pnum mut)
- (pchr #\/)
- (pnum umut)
- (pstr " mutations (total/tracked)")))
- (let ((minor (##sys#slot info 4))
- (major (##sys#slot info 5)))
- (when (or (fx> minor 0) (fx> major 0))
- (pstr ", ")
- (pnum major)
- (pchr #\/)
- (pnum minor)
- (pstr " GCs (major/minor)")))
- (let ((maximum-heap-usage (##sys#slot info 6)))
- (pstr ", maximum live heap: ")
- (pmem maximum-heap-usage))
- (##sys#write-char-0 #\newline ##sys#standard-error)
- (##sys#flush-output ##sys#standard-error))
-
-
;;; Dump heap state to stderr:
(define ##sys#dump-heap-state (##core#primitive "C_dump_heap_state"))
--
2.1.4
From b8b7ff303c7ca893d9d5c09ec8e7cf86848d7434 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sun, 30 Apr 2017 18:02:09 +0200
Subject: [PATCH 3/3] Remove ##sys#nodups, move {take,drop}-right into
chicken.internal
The ##sys#nodups and corresponding ##sys#del procedures are just
differently named (and specialisable) versions of delete-duplicates
and delete from SRFI-1. So, we load mini-srfi-1.scm into csi.scm, and
get rid of those definition in library.scm.
We also get rid of the optional arguments in the SRFI-1 "delete" and
"delete-duplicates" definitions because that's completely unnecessary
for a fast internal API.
Finally, ##sys#take-right and ##sys#drop-right (which are used
exclusively by syntax-rules) are moved into chicken.internal just
like we did for the helpers for the "time" macro.
---
batch-driver.scm | 2 +-
chicken-status.scm | 2 +-
chicken-uninstall.scm | 2 +-
core.scm | 4 ++--
csi.scm | 4 +++-
internal.scm | 30 ++++++++++++++++++++++++++++++
library.scm | 41 -----------------------------------------
mini-srfi-1.scm | 8 ++++----
optimizer.scm | 2 +-
rules.make | 2 +-
synrules.scm | 4 ++--
11 files changed, 46 insertions(+), 55 deletions(-)
diff --git a/batch-driver.scm b/batch-driver.scm
index 7cb8b51..0f920f5 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -447,7 +447,7 @@
(when (not f) (quit-compiling "cannot load extension: ~a" e))
(load f)))
extends) )
- (set! ##sys#features (delete #:compiler-extension ##sys#features))
+ (set! ##sys#features (delete #:compiler-extension ##sys#features eq?))
(set! ##sys#features (cons '#:compiling ##sys#features))
(set! upap (user-post-analysis-pass))
diff --git a/chicken-status.scm b/chicken-status.scm
index 2fb54c5..8b49a14 100644
--- a/chicken-status.scm
+++ b/chicken-status.scm
@@ -77,7 +77,7 @@
(lambda (egg)
(any (cut string=? <> egg) patterns))
eggs)))))
- (delete-duplicates names)))
+ (delete-duplicates names string=?)))
(define (gather-eggs)
(delete-duplicates
diff --git a/chicken-uninstall.scm b/chicken-uninstall.scm
index d9c7925..4ade54a 100644
--- a/chicken-uninstall.scm
+++ b/chicken-uninstall.scm
@@ -69,7 +69,7 @@
(lambda (egg)
(any (cut string=? <> egg) patterns))
eggs))))
- (delete-duplicates pats)))
+ (delete-duplicates pats string=?)))
(define (fini code)
(print "aborted.")
diff --git a/core.scm b/core.scm
index a9c2510..41a7814 100644
--- a/core.scm
+++ b/core.scm
@@ -997,7 +997,7 @@
;; Remove from list to avoid error
(when (pair? il)
(set! import-libraries
- (delete il import-libraries)))
+ (delete il import-libraries equal?)))
(values (reverse xs) '())))
((not enable-module-registration)
(values (reverse xs) '()))
@@ -2423,7 +2423,7 @@
(when (pair? (cdr params)) (bomb "let-node has invalid format" params))
(let ((c (gather (first subs) here locals))
(var (first params)))
- (append c (delete var (gather (second subs) here (cons var locals))))))
+ (append c (delete var (gather (second subs) here (cons var locals)) eq?))))
((set!)
(let ((var (first params))
diff --git a/csi.scm b/csi.scm
index 468a14d..e6890d4 100644
--- a/csi.scm
+++ b/csi.scm
@@ -58,6 +58,7 @@ EOF
chicken.repl)
(include "banner.scm")
+(include "mini-srfi-1.scm")
;;; Parameters:
@@ -959,6 +960,7 @@ EOF
(define-constant complex-options
'("-D" "-feature" "-I" "-include-path" "-K" "-keyword-style" "-no-feature") )
+
(define (run)
(let* ([extraopts (parse-option-string (or (get-environment-variable "CSI_OPTIONS") ""))]
[args (canonicalize-args (command-line-arguments))]
@@ -1031,7 +1033,7 @@ EOF
(for-each register-feature! (collect-options "-D"))
(for-each unregister-feature! (collect-options "-no-feature"))
(set! ##sys#include-pathnames
- (##sys#nodups
+ (delete-duplicates
(append (map chop-separator (collect-options "-include-path"))
(map chop-separator (collect-options "-I"))
##sys#include-pathnames
diff --git a/internal.scm b/internal.scm
index 6ef7628..ea6490c 100644
--- a/internal.scm
+++ b/internal.scm
@@ -34,6 +34,9 @@
;; particular.
(module chicken.internal
(
+ ;; SRFI-1 workalikes, as support for "syntax-rules" macro
+ take-right drop-right
+
;; Timing information (support for "time" macro)
start-timer stop-timer display-timer-statistics
@@ -55,6 +58,33 @@
(include "common-declarations.scm")
(include "mini-srfi-1.scm")
+;; SRFI-1 workalikes, as support for "syntax-rules" macro:
+;;
+;; NOTE: these are not part of mini-srfi-1.scm because they're not
+;; inlineable since they're used in the expansion, rather than in the
+;; syntax-rules macro processor itself. We don't put it in
+;; mini-srfi-1, because everything that uses internal *and*
+;; mini-srfi-1 would start to complain about redefinitions of already
+;; imported procedures.
+(define (drop-right input temp)
+ ;;XXX use unsafe accessors
+ (let loop ((len (length input))
+ (input input))
+ (cond
+ ((> len temp)
+ (cons (car input)
+ (loop (- len 1) (cdr input))))
+ (else '()))))
+
+(define (take-right input temp)
+ ;;XXX use unsafe accessors
+ (let loop ((len (length input))
+ (input input))
+ (cond
+ ((> len temp)
+ (loop (- len 1) (cdr input)))
+ (else input))))
+
;;; Timing information (support for "time" macro):
(define (start-timer)
diff --git a/library.scm b/library.scm
index 0b324db..199157f 100644
--- a/library.scm
+++ b/library.scm
@@ -5650,47 +5650,6 @@ EOF
(f (##sys#slot lst 0) (loop (##sys#slot lst 1))))))
-;; Some list-operations, used by the syntax-rules implementation, inside module
-;; implementation and in csi
-
-(define (##sys#del x lst tst)
- (let loop ((lst lst))
- (if (null? lst)
- '()
- (let ((y (car lst)))
- (if (tst x y)
- (cdr lst)
- (cons y (loop (cdr lst))) ) ) ) ) )
-
-(define (##sys#nodups lis elt=)
- (let recur ((lis lis))
- (if (null? lis) lis
- (let* ((x (car lis))
- (tail (cdr lis))
- (new-tail (recur (##sys#del x tail elt=))))
- (if (eq? tail new-tail) lis (cons x new-tail))))))
-
-;; contributed by Peter Bex
-(define (##sys#drop-right input temp)
- ;;XXX use unsafe accessors
- (let loop ((len (length input))
- (input input))
- (cond
- ((> len temp)
- (cons (car input)
- (loop (- len 1) (cdr input))))
- (else '()))))
-
-(define (##sys#take-right input temp)
- ;;XXX use unsafe accessors
- (let loop ((len (length input))
- (input input))
- (cond
- ((> len temp)
- (loop (- len 1) (cdr input)))
- (else input))))
-
-
;;; Platform configuration inquiry:
(module chicken.platform
diff --git a/mini-srfi-1.scm b/mini-srfi-1.scm
index cd74dbe..627aa0f 100644
--- a/mini-srfi-1.scm
+++ b/mini-srfi-1.scm
@@ -26,8 +26,8 @@
(declare
- (unused take span drop partition split-at append-map every any cons* concatenate delete
- first second third fourth alist-cons delete-duplicates fifth remove
+ (unused take span drop partition split-at append-map every any cons* concatenate
+ first second third fourth alist-cons fifth remove
filter filter-map unzip1 last list-index lset-adjoin/eq? lset-difference/eq?
lset-union/eq? lset-intersection/eq? list-tabulate lset<=/eq? lset=/eq? length+
find find-tail iota make-list posq posv)
@@ -100,7 +100,7 @@
'()
(append (car lst) (loop (cdr lst))))))
-(define (delete x lst #!optional (test equal?))
+(define (delete x lst test)
(let loop ((lst lst))
(cond ((null? lst) lst)
((test x (car lst))
@@ -114,7 +114,7 @@
(define (fourth x) (cadddr x))
(define (fifth x) (car (cddddr x)))
-(define (delete-duplicates lst #!optional (test equal?))
+(define (delete-duplicates lst test)
(let loop ((lst lst))
(if (null? lst)
lst
diff --git a/optimizer.scm b/optimizer.scm
index 6c88196..9fb5c48 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -126,7 +126,7 @@
(debugging 'p "scanning toplevel assignments...")
(scan node '())
(when (pair? safe)
- (debugging 'o "safe globals" (delete-duplicates safe)))
+ (debugging 'o "safe globals" (delete-duplicates safe eq?)))
(for-each (cut mark-variable <> '##compiler#always-bound) safe)))
diff --git a/rules.make b/rules.make
index 7557b07..336a5b5 100644
--- a/rules.make
+++ b/rules.make
@@ -856,7 +856,7 @@ endef
$(foreach obj, $(COMPILER_OBJECTS_1),\
$(eval $(call declare-bootstrap-compiler-object,$(obj))))
-csi.c: $(SRCDIR)csi.scm $(SRCDIR)banner.scm
+csi.c: $(SRCDIR)csi.scm $(SRCDIR)banner.scm $(SRCDIR)mini-srfi-1.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
chicken-profile.c: $(SRCDIR)chicken-profile.scm $(SRCDIR)mini-srfi-1.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
diff --git a/synrules.scm b/synrules.scm
index cf8912e..df89404 100644
--- a/synrules.scm
+++ b/synrules.scm
@@ -176,7 +176,7 @@
(let* ((tail-length (length (cddr pattern)))
(%match (if (zero? tail-length) ; Simple segment?
path ; No list traversing overhead at runtime!
- `(##sys#drop-right ,path ,tail-length))))
+ `(chicken.internal#drop-right ,path ,tail-length))))
(append
(process-pattern (car pattern)
%temp
@@ -187,7 +187,7 @@
`(,%map1 (,%lambda (,%temp) ,x) ,%match))))
#f)
(process-pattern (cddr pattern)
- `(##sys#take-right ,path ,tail-length) mapit #t))))
+ `(chicken.internal#take-right ,path ,tail-length) mapit #t))))
((pair? pattern)
(append (process-pattern (car pattern) `(,%car ,path) mapit #f)
(process-pattern (cdr pattern) `(,%cdr ,path) mapit #f)))
--
2.1.4
signature.asc
Description: Digital signature
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
