~ chicken-core (chicken-5) 476e40d193092156aa4fa4145728149f97240d26
commit 476e40d193092156aa4fa4145728149f97240d26
Author: felix <felix@y.(none)>
AuthorDate: Thu Apr 22 20:12:01 2010 +0200
Commit: felix <felix@y.(none)>
CommitDate: Thu Apr 22 20:12:01 2010 +0200
fixed handling of arguments for void in optimizer; more efficient treatment of ##sys#undefined-value; if ##core#always-bound, then 'removable
diff --git a/c-platform.scm b/c-platform.scm
index 8be0d25f..00020d3a 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -38,7 +38,8 @@
(define default-declarations
'((always-bound
- ##sys#standard-input ##sys#standard-output ##sys#standard-error)
+ ##sys#standard-input ##sys#standard-output ##sys#standard-error
+ ##sys#undefined-value)
(bound-to-procedure
##sys#for-each ##sys#map ##sys#print ##sys#setter
##sys#setslot ##sys#dynamic-wind ##sys#call-with-values
diff --git a/compiler.scm b/compiler.scm
index 8d165c00..99d01582 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -2008,14 +2008,16 @@
(set! explicitly-consed (cons rest explicitly-consed))
(put! db (first lparams) 'explicit-rest #t) ] ) ) ) ) ) ) ) )
- ;; Make 'removable, if it has no references and is not assigned to, and if it has either a value that
- ;; does not cause any side-effects or if it is 'undefined:
+ ;; Make 'removable, if it has no references and is not assigned to, and if it
+ ;; has either a value that does not cause any side-effects or if it is 'undefined:
(when (and (not assigned)
(null? references)
(or (and value
- (or (not (eq? '##core#variable (node-class value)))
- (not (get db (first (node-parameters value)) 'global)) )
- (not (expression-has-side-effects? value db)) )
+ (if (eq? '##core#variable (node-class value))
+ (let ((varname (first (node-parameters value))))
+ (or (not (get db varname 'global))
+ (not (variable-mark varname '##core#always-bound))))
+ (not (expression-has-side-effects? value db)) ))
undefined) )
(quick-put! plist 'removable #t) )
diff --git a/data-structures.import.scm b/data-structures.import.scm
index 4732eccd..15e05e09 100644
--- a/data-structures.import.scm
+++ b/data-structures.import.scm
@@ -56,7 +56,7 @@
merge!
never?
none?
- noop
+ noop ;DEPRECATED
o
project
queue->list
diff --git a/data-structures.scm b/data-structures.scm
index 809217cd..934272da 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -136,7 +136,7 @@ EOF
[(pred (##sys#slot lst 0)) (loop (##sys#slot lst 1))]
[else #f] ) ) ) )
-(define (noop . _) (void))
+(define (noop . _) (void)) ;DEPRECATED
(define (each . procs)
(cond ((null? procs) (lambda _ (void)))
diff --git a/manual/Unit data-structures b/manual/Unit data-structures
index ebd83f23..b6f4e531 100644
--- a/manual/Unit data-structures
+++ b/manual/Unit data-structures
@@ -558,7 +558,7 @@ is equivalent to
</enscript>
{{(each PROC)}} is equivalent to {{PROC}} and {{(each)}} is equivalent to
-{{noop}}.
+{{void}}.
==== flip
@@ -600,13 +600,6 @@ applied to a list of elements that all satisfy the predicate procedure
</enscript>
-==== noop
-
-<procedure>(noop X ...)</procedure>
-
-Ignores its arguments, does nothing and returns an unspecified value.
-
-
==== o
<procedure>(o PROC ...)</procedure>
diff --git a/manual/Unit library b/manual/Unit library
index 697de3fa..71f281f8 100644
--- a/manual/Unit library
+++ b/manual/Unit library
@@ -1062,9 +1062,9 @@ contents are initialized to some unspecified value.
==== void
-<procedure>(void)</procedure>
+<procedure>(void ARGUMENT ...)</procedure>
-Returns an unspecified value.
+Ignores {{ARGUMENT ...}} and returns an unspecified value.
diff --git a/optimizer.scm b/optimizer.scm
index 596bc44f..b50f8bae 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -846,12 +846,15 @@
cont
(make-node '##core#inline (list (second classargs)) callargs) ) ) ) ) )
- ;; (<op>) -> <var>
+ ;; (<op> ...) -> <var>
((3) ; classargs = (<var>)
(and inline-substitutions-enabled
- (null? callargs)
(intrinsic? name)
- (make-node '##core#call '(#t) (list cont (varnode (first classargs)))) ) )
+ (fold-right
+ (lambda (val body)
+ (make-node 'let (list (gensym "t")) (list val body)) )
+ (make-node '##core#call '(#t) (list cont (varnode (first classargs))))
+ callargs)))
;; (<op> a b) -> (<primitiveop> a (quote <i>) b)
((4) ; classargs = (<primitiveop> <i>)
diff --git a/ports.scm b/ports.scm
index 2d0f6fe3..81545344 100644
--- a/ports.scm
+++ b/ports.scm
@@ -101,7 +101,7 @@
(define (make-broadcast-port . ports)
(make-output-port
(lambda (s) (for-each (cut write-string s #f <>) ports))
- noop
+ void
(lambda () (for-each flush-output ports)) ) )
(define (make-concatenated-port p1 . ports)
@@ -119,7 +119,7 @@
(lambda ()
(and (not (null? ports))
(char-ready? (car ports))))
- noop
+ void
(lambda ()
(let loop ()
(if (null? ports)
diff --git a/posixunix.scm b/posixunix.scm
index bc985e8a..28460997 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -1620,7 +1620,7 @@ EOF
(define ##sys#custom-input-port
(let ([make-input-port make-input-port]
[set-port-name! set-port-name!] )
- (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 1) (on-close noop) (more? #f))
+ (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 1) (on-close void) (more? #f))
(when nonblocking? (##sys#file-nonblocking! fd) )
(let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))]
[buf (if (fixnum? bufi) (##sys#make-string bufi) bufi)]
@@ -1746,7 +1746,7 @@ EOF
(define ##sys#custom-output-port
(let ([make-output-port make-output-port]
[set-port-name! set-port-name!] )
- (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 0) (on-close noop))
+ (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 0) (on-close void))
(when nonblocking? (##sys#file-nonblocking! fd) )
(letrec (
[poke
diff --git a/types.db b/types.db
index 5021ee45..eaef9e60 100644
--- a/types.db
+++ b/types.db
@@ -417,7 +417,7 @@
(system (procedure system (string) fixnum))
(unregister-feature! (procedure unregister-feature! (#!rest symbol) undefined))
(vector-resize (procedure vector-resize (vector fixnum) vector))
-(void (procedure void () undefined))
+(void (procedure void (#!rest) undefined))
(warning (procedure warning (#!rest) . *))
(with-exception-handler (procedure with-exception-handler (procedure procedure) . *))
@@ -453,7 +453,7 @@
(merge! (procedure merge! (list list (procedure (* *) *)) list))
(never? (procedure never? (#!rest) boolean))
(none? (procedure none? (*) boolean))
-(noop (procedure noop (#!rest) *))
+(noop deprecated)
(o (procedure o (#!rest (procedure (*) *)) (procedure (*) *)))
(project (procedure project (fixnum) procedure))
(queue->list (procedure queue->list ((struct queue)) list))
Trap