~ chicken-core (chicken-5) a5e2d81914e3e1bc6e6e410a95c4ecf1a6fe66e2
commit a5e2d81914e3e1bc6e6e410a95c4ecf1a6fe66e2
Author: felix <felix@y.(none)>
AuthorDate: Sat Mar 20 22:29:25 2010 +0100
Commit: felix <felix@y.(none)>
CommitDate: Sat Mar 20 22:29:25 2010 +0100
removed more unsafe runtime stuff
diff --git a/data-structures.scm b/data-structures.scm
index 825bc329..809217cd 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -218,9 +218,7 @@ EOF
(let ([reverse reverse])
(lambda (lst n)
(##sys#check-exact n 'chop)
- (cond-expand
- [(not unsafe) (when (fx<= n 0) (##sys#error 'chop "invalid numeric argument" n))]
- [else] )
+ (when (fx<= n 0) (##sys#error 'chop "invalid numeric argument" n))
(let ([len (length lst)])
(let loop ([lst lst] [i len])
(cond [(null? lst) '()]
@@ -237,7 +235,7 @@ EOF
(##sys#check-list lst 'join)
(let loop ([lsts lsts])
(cond [(null? lsts) '()]
- [(cond-expand [unsafe #f] [else (not (pair? lsts))])
+ [(not (pair? lsts))
(##sys#error-not-a-proper-list lsts) ]
[else
(let ([l (##sys#slot lsts 0)]
@@ -252,11 +250,12 @@ EOF
(##sys#check-list lst 'compress)
(let loop ([blst blst] [lst lst])
(cond [(null? blst) '()]
- [(cond-expand [unsafe #f] [else (not (pair? blst))])
+ [(not (pair? blst))
(##sys#signal-hook #:type-error 'compress msg blst) ]
- [(cond-expand [unsafe #f] [else (not (pair? lst))])
+ [(not (pair? lst))
(##sys#signal-hook #:type-error 'compress msg lst) ]
- [(##sys#slot blst 0) (cons (##sys#slot lst 0) (loop (##sys#slot blst 1) (##sys#slot lst 1)))]
+ [(##sys#slot blst 0)
+ (cons (##sys#slot lst 0) (loop (##sys#slot blst 1) (##sys#slot lst 1)))]
[else (loop (##sys#slot blst 1) (##sys#slot lst 1))] ) ) ) ) )
(define shuffle
@@ -307,12 +306,12 @@ EOF
default) ) )
(define (rassoc x lst . tst)
- (cond-expand [(not unsafe) (##sys#check-list lst 'rassoc)][else])
+ (##sys#check-list lst 'rassoc)
(let ([tst (if (pair? tst) (car tst) eqv?)])
(let loop ([l lst])
(and (pair? l)
(let ([a (##sys#slot l 0)])
- (cond-expand [(not unsafe) (##sys#check-pair a 'rassoc)][else])
+ (##sys#check-pair a 'rassoc)
(if (tst x (##sys#slot a 1))
a
(loop (##sys#slot l 1)) ) ) ) ) ) )
@@ -561,7 +560,7 @@ EOF
[(char? to)
(##core#inline "C_setsubchar" str2 j to)
(loop (fx+ i 1) (fx+ j 1)) ]
- [(cond-expand [unsafe #f] [else (fx>= found tlen)])
+ [(fx>= found tlen)
(##sys#error 'string-translate "invalid translation destination" i to) ]
[else
(##core#inline "C_setsubchar" str2 j (##core#inline "C_subchar" to found))
@@ -870,22 +869,16 @@ EOF
(lambda (q)
(##sys#check-structure q 'queue 'queue-first)
(let ((first-pair (##sys#slot q 1)))
- (cond-expand
- [(not unsafe)
- (when (eq? '() first-pair)
- (##sys#error 'queue-first "queue is empty" q)) ]
- [else] )
+ (when (eq? '() first-pair)
+ (##sys#error 'queue-first "queue is empty" q))
(##sys#slot first-pair 0) ) ) )
(define queue-last
(lambda (q)
(##sys#check-structure q 'queue 'queue-last)
(let ((last-pair (##sys#slot q 2)))
- (cond-expand
- [(not unsafe)
- (when (eq? '() last-pair)
- (##sys#error 'queue-last "queue is empty" q)) ]
- [else] )
+ (when (eq? '() last-pair)
+ (##sys#error 'queue-last "queue is empty" q))
(##sys#slot last-pair 0) ) ) )
(define (queue-add! q datum)
@@ -900,11 +893,8 @@ EOF
(lambda (q)
(##sys#check-structure q 'queue 'queue-remove!)
(let ((first-pair (##sys#slot q 1)))
- (cond-expand
- [(not unsafe)
- (when (eq? '() first-pair)
- (##sys#error 'queue-remove! "queue is empty" q) ) ]
- [else] )
+ (when (eq? '() first-pair)
+ (##sys#error 'queue-remove! "queue is empty" q) )
(let ((first-cdr (##sys#slot first-pair 1)))
(##sys#setslot q 1 first-cdr)
(if (eq? '() first-cdr)
diff --git a/distribution/manifest b/distribution/manifest
index ae8b04f6..f58300de 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -42,25 +42,7 @@ srfi-4.c
stub.c
support.c
tcp.c
-ueval.c
-uextras.c
-udata-structures.c
-uports.c
-ufiles.c
-ulibrary.c
-ulolevel.c
-uregex.c
-uposixunix.c
-uposixwin.c
-usrfi-1.c
-usrfi-13.c
-usrfi-14.c
-usrfi-18.c
-usrfi-4.c
-usrfi-69.c
-utcp.c
utils.c
-uutils.c
build.scm
version.scm
buildversion
@@ -107,7 +89,6 @@ srfi-13.scm
srfi-14.scm
srfi-18.scm
srfi-4.scm
-toposort.scm
stub.scm
support.scm
tcp.scm
diff --git a/eval.scm b/eval.scm
index c51f12c4..8224c040 100644
--- a/eval.scm
+++ b/eval.scm
@@ -227,6 +227,7 @@
(define ##sys#unbound-in-eval #f)
(define ##sys#eval-debug-level 1)
+(define ##sys#unsafe-eval #f)
(define ##sys#compile-to-closure
(let ([write write]
@@ -300,20 +301,21 @@
(if ##sys#eval-environment
(let ([loc (##sys#hash-table-location ##sys#eval-environment var #t)])
(unless loc (##sys#syntax-error-hook "reference to undefined identifier" var))
- (cond-expand
- [unsafe (lambda v (##sys#slot loc 1))]
- [else
- (lambda v
- (let ([val (##sys#slot loc 1)])
- (if (eq? unbound val)
- (##sys#error "unbound variable" var)
- val) ) ) ] ) )
- (cond-expand
- [unsafe (lambda v (##core#inline "C_slot" var 0))]
- [else
- (when (and ##sys#unbound-in-eval (not (##sys#symbol-has-toplevel-binding? var)))
- (set! ##sys#unbound-in-eval (cons (cons var cntr) ##sys#unbound-in-eval)) )
- (lambda v (##core#inline "C_retrieve" var))] ) ) ) ]
+ (if ##sys#unsafe-eval
+ (lambda v (##sys#slot loc 1))
+ (lambda v
+ (let ([val (##sys#slot loc 1)])
+ (if (eq? unbound val)
+ (##sys#error "unbound variable" var)
+ val) ) ) ))
+ (cond (##sys#unsafe-eval
+ (lambda v (##core#inline "C_slot" var 0)))
+ (else
+ (when (and ##sys#unbound-in-eval
+ (not (##sys#symbol-has-toplevel-binding? var)))
+ (set! ##sys#unbound-in-eval
+ (cons (cons var cntr) ##sys#unbound-in-eval)) )
+ (lambda v (##core#inline "C_retrieve" var))))))]
[(zero? i) (lambda (v) (##sys#slot (##sys#slot v 0) j))]
[else (lambda (v) (##sys#slot (##core#inline "C_u_i_list_ref" v i) j))] ) ) )
[(##sys#number? x)
diff --git a/extras.scm b/extras.scm
index c35d6fb4..fd305a0d 100644
--- a/extras.scm
+++ b/extras.scm
@@ -611,7 +611,7 @@
(set! index (fx+ index 1))
c) )
(define (next)
- (if (cond-expand [unsafe #f] [else (##core#inline "C_eqp" args '())])
+ (if (##core#inline "C_eqp" args '())
(##sys#error loc "too few arguments to formatted output procedure")
(let ((x (##sys#slot args 0)))
(set! args (##sys#slot args 1))
diff --git a/library.scm b/library.scm
index dd944517..5756ec26 100644
--- a/library.scm
+++ b/library.scm
@@ -258,14 +258,11 @@ EOF
(define ##sys#apply-argument-limit (##sys#fudge 34))
(define (##sys#block-set! x i y)
- (cond-expand
- [(not unsafe)
- (when (or (not (##core#inline "C_blockp" x))
- (and (##core#inline "C_specialp" x) (fx= i 0))
- (##core#inline "C_byteblockp" x) )
- (##sys#signal-hook '#:type-error '##sys#block-set! "slot not accessible" x) )
- (##sys#check-range i 0 (##sys#size x) '##sys#block-set!) ]
- [else] )
+ (when (or (not (##core#inline "C_blockp" x))
+ (and (##core#inline "C_specialp" x) (fx= i 0))
+ (##core#inline "C_byteblockp" x) )
+ (##sys#signal-hook '#:type-error '##sys#block-set! "slot not accessible" x) )
+ (##sys#check-range i 0 (##sys#size x) '##sys#block-set!) ]
(##sys#setslot x i y) )
(define (current-seconds)
@@ -454,29 +451,19 @@ EOF
(if (eq? (##sys#slot lsts 1) '())
(##sys#slot lsts 0)
(let copy ((node (##sys#slot lsts 0)))
- (cond-expand
- [unsafe
- (if (eq? node '())
- (loop (##sys#slot lsts 1))
- (cons (##sys#slot node 0) (copy (##sys#slot node 1))) ) ]
- [else
- (cond ((eq? node '()) (loop (##sys#slot lsts 1)))
- ((pair? node)
- (cons (##sys#slot node 0) (copy (##sys#slot node 1))) )
- (else (##sys#error-not-a-proper-list (##sys#slot lsts 0) 'append)) ) ] ) ) ) ) ) )
+ (cond ((eq? node '()) (loop (##sys#slot lsts 1)))
+ ((pair? node)
+ (cons (##sys#slot node 0) (copy (##sys#slot node 1))) )
+ (else
+ (##sys#error-not-a-proper-list
+ (##sys#slot lsts 0) 'append)) ) )))))
(define (reverse lst0)
(let loop ((lst lst0) (rest '()))
- (cond-expand
- [unsafe
- (if (eq? lst '())
- rest
- (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest)) ) ]
- [else
- (cond ((eq? lst '()) rest)
- ((pair? lst)
- (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest)) )
- (else (##sys#error-not-a-proper-list lst0 'reverse)) ) ] ) ) )
+ (cond ((eq? lst '()) rest)
+ ((pair? lst)
+ (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest)) )
+ (else (##sys#error-not-a-proper-list lst0 'reverse)) ) ))
(define (memq x lst) (##core#inline "C_i_memq" x lst))
(define (memv x lst) (##core#inline "C_i_memv" x lst))
@@ -503,15 +490,15 @@ EOF
(define (make-string size . fill)
(##sys#check-exact size 'make-string)
- #+(not unsafe)
(when (fx< size 0)
(##sys#signal-hook #:bounds-error 'make-string "size is negative" size))
- (%make-string size
- (if (null? fill)
- #\space
- (let ((c (car fill)))
- (##sys#check-char c 'make-string)
- c ) ) ) )
+ (%make-string
+ size
+ (if (null? fill)
+ #\space
+ (let ((c (car fill)))
+ (##sys#check-char c 'make-string)
+ c ) ) ) )
(define ##sys#string->list
(lambda (s)
@@ -526,43 +513,23 @@ EOF
(define string->list ##sys#string->list)
(define (##sys#list->string lst0)
- (cond-expand
- [unsafe
- (let* ([len (length lst0)]
- [s (##sys#make-string len)] )
- (do ([i 0 (fx+ i 1)]
- [lst lst0 (##sys#slot lst 1)] )
- ((fx>= i len) s)
- (##core#inline "C_setsubchar" s i (##sys#slot lst 0)) ) )]
- [else
- (if (not (list? lst0))
+ (if (not (list? lst0))
(##sys#error-not-a-proper-list lst0 'list->string)
(let* ([len (length lst0)]
[s (##sys#make-string len)] )
(do ([i 0 (fx+ i 1)]
[lst lst0 (##sys#slot lst 1)] )
- ((fx>= i len) s)
+ ((fx>= i len) s)
(let ([c (##sys#slot lst 0)])
(##sys#check-char c 'list->string)
- (##core#inline "C_setsubchar" s i c) ) ) ) )]
- ))
+ (##core#inline "C_setsubchar" s i c) ) ) ) ))
(define list->string ##sys#list->string)
;;; By Sven Hartrumpf:
(define (##sys#reverse-list->string l)
- (cond-expand
- [unsafe
- (let* ((n (length l))
- (s (##sys#make-string n)))
- (let iter ((l2 l) (n2 (fx- n 1)))
- (cond ((fx>= n2 0)
- (##core#inline "C_setsubchar" s n2 (##sys#slot l2 0))
- (iter (##sys#slot l2 1) (fx- n2 1)) ) ) )
- s ) ]
- [else
- (if (list? l)
+ (if (list? l)
(let* ((n (length l))
(s (##sys#make-string n)))
(let iter ((l2 l) (n2 (fx- n 1)))
@@ -572,8 +539,7 @@ EOF
(##core#inline "C_setsubchar" s n2 c) )
(iter (##sys#slot l2 1) (fx- n2 1)) ) ) )
s )
- (##sys#error-not-a-proper-list l 'reverse-list->string) ) ]
- ) )
+ (##sys#error-not-a-proper-list l 'reverse-list->string) ) )
(define reverse-list->string ##sys#reverse-list->string)
@@ -599,15 +565,14 @@ EOF
(##sys#check-exact end 'substring)
end)
(##sys#size s) ) ] )
- (cond-expand
- [unsafe (##sys#substring s start end)]
- [else
- (let ([len (##sys#size s)])
- (if (and (fx<= start end)
- (fx>= start 0)
- (fx<= end len) )
+ (let ([len (##sys#size s)])
+ (if (and (fx<= start end)
+ (fx>= start 0)
+ (fx<= end len) )
(##sys#substring s start end)
- (##sys#error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int) 'substring start end) ) ) ] ) ) )
+ (##sys#error-hook
+ (foreign-value "C_OUT_OF_RANGE_ERROR" int)
+ 'substring start end) ) ) ))
(define (##sys#substring s start end)
(let ([s2 (##sys#make-string (fx- end start))])
@@ -615,8 +580,7 @@ EOF
s2 ) )
(define (string=? x y)
- (cond-expand [unsafe (##core#inline "C_u_i_string_equal_p" x y)]
- [else (##core#inline "C_i_string_equal_p" x y)] ) )
+ (##core#inline "C_i_string_equal_p" x y))
(define (string-ci=? x y) (##core#inline "C_i_string_ci_equal_p" x y))
@@ -770,18 +734,12 @@ EOF
(##sys#error-hook (foreign-value "C_DIVISION_BY_ZERO_ERROR" int) loc x y) ) )
(define (fx/ x y)
- (cond-expand
- [unsafe (##core#inline "C_fixnum_divide" x y)]
- [else
- (fx-check-divison-by-zero x y 'fx/)
- (##core#inline "C_fixnum_divide" x y) ] ) )
+ (fx-check-divison-by-zero x y 'fx/)
+ (##core#inline "C_fixnum_divide" x y) )
(define (fxmod x y)
- (cond-expand
- [unsafe (##core#inline "C_fixnum_modulo" x y)]
- [else
- (fx-check-divison-by-zero x y 'fxmod)
- (##core#inline "C_fixnum_modulo" x y) ] ) )
+ (fx-check-divison-by-zero x y 'fxmod)
+ (##core#inline "C_fixnum_modulo" x y) )
(define maximum-flonum (foreign-value "DBL_MAX" double))
(define minimum-flonum (foreign-value "DBL_MIN" double))
@@ -809,106 +767,66 @@ EOF
(##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int) loc x y) ) )
(define (fp+ x y)
- (cond-expand
- [unsafe (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y)]
- [else
- (fp-check-flonums x y 'fp+)
- (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y) ] ) )
+ (fp-check-flonums x y 'fp+)
+ (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y) )
(define (fp- x y)
- (cond-expand
- [unsafe (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y)]
- [else
- (fp-check-flonums x y 'fp-)
- (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y) ] ) )
+ (fp-check-flonums x y 'fp-)
+ (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y) )
(define (fp* x y)
- (cond-expand
- [unsafe (##core#inline_allocate ("C_a_i_flonum_times" 4) x y)]
- [else
- (fp-check-flonums x y 'fp*)
- (##core#inline_allocate ("C_a_i_flonum_times" 4) x y) ] ) )
+ (fp-check-flonums x y 'fp*)
+ (##core#inline_allocate ("C_a_i_flonum_times" 4) x y) )
(define (fp/ x y)
- (cond-expand
- [unsafe (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y)]
- [else
- (fp-check-flonums x y 'fp/)
- (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y) ] ) )
+ (fp-check-flonums x y 'fp/)
+ (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y) )
(define (fp= x y)
- (cond-expand
- [unsafe (##core#inline "C_flonum_equalp" x y)]
- [else
- (fp-check-flonums x y 'fp=)
- (##core#inline "C_flonum_equalp" x y) ] ) )
+ (fp-check-flonums x y 'fp=)
+ (##core#inline "C_flonum_equalp" x y) )
(define (fp> x y)
- (cond-expand
- [unsafe (##core#inline "C_flonum_greaterp" x y)]
- [else
- (fp-check-flonums x y 'fp>)
- (##core#inline "C_flonum_greaterp" x y) ] ) )
+ (fp-check-flonums x y 'fp>)
+ (##core#inline "C_flonum_greaterp" x y) )
(define (fp< x y)
- (cond-expand
- [unsafe (##core#inline "C_flonum_lessp" x y)]
- [else
- (fp-check-flonums x y 'fp<)
- (##core#inline "C_flonum_lessp" x y) ] ) )
+ (fp-check-flonums x y 'fp<)
+ (##core#inline "C_flonum_lessp" x y) )
(define (fp>= x y)
- (cond-expand
- [unsafe (##core#inline "C_flonum_greater_or_equal_p" x y)]
- [else
- (fp-check-flonums x y 'fp>=)
- (##core#inline "C_flonum_greater_or_equal_p" x y) ] ) )
+ (fp-check-flonums x y 'fp>=)
+ (##core#inline "C_flonum_greater_or_equal_p" x y) )
(define (fp<= x y)
- (cond-expand
- [unsafe (##core#inline "C_flonum_less_or_equal_p" x y)]
- [else
- (fp-check-flonums x y 'fp<=)
- (##core#inline "C_flonum_less_or_equal_p" x y) ] ) )
+ (fp-check-flonums x y 'fp<=)
+ (##core#inline "C_flonum_less_or_equal_p" x y) )
(define (fpneg x)
- (cond-expand
- [unsafe (##core#inline_allocate ("C_a_i_flonum_negate" 4) x)]
- [else
- (fp-check-flonum x 'fpneg)
- (##core#inline_allocate ("C_a_i_flonum_negate" 4) x) ] ) )
+ (fp-check-flonum x 'fpneg)
+ (##core#inline_allocate ("C_a_i_flonum_negate" 4) x) )
(define (fpmax x y)
- (cond-expand
- [unsafe (##core#inline "C_i_flonum_max" x y)]
- [else
- (fp-check-flonums x y 'fpmax)
- (##core#inline "C_i_flonum_max" x y) ] ) )
+ (fp-check-flonums x y 'fpmax)
+ (##core#inline "C_i_flonum_max" x y) )
(define (fpmin x y)
- (cond-expand
- [unsafe (##core#inline "C_i_flonum_min" x y)]
- [else
- (fp-check-flonums x y 'fpmin)
- (##core#inline "C_i_flonum_min" x y) ] ) )
+ (fp-check-flonums x y 'fpmin)
+ (##core#inline "C_i_flonum_min" x y) )
(define (fpfloor x)
- #+(not unsafe)
(fp-check-flonum x 'fpfloor)
(##core#inline_allocate ("C_a_i_flonum_floor" 4) x))
(define (fptruncate x)
- #+(not unsafe)
(fp-check-flonum x 'fptruncate)
(##core#inline_allocate ("C_a_i_flonum_truncate" 4) x))
(define (fpround x)
- #+(not unsafe)
(fp-check-flonum x 'fpround)
(##core#inline_allocate ("C_a_i_flonum_round" 4) x))
(define (fpceiling x)
- #+(not unsafe)
(fp-check-flonum x 'fpceiling)
(##core#inline_allocate ("C_a_i_flonum_ceiling" 4) x))
@@ -917,67 +835,54 @@ EOF
(define ##sys#ceiling fpceiling)
(define (fpsin x)
- #+(not unsafe)
(fp-check-flonum x 'fpsin)
(##core#inline_allocate ("C_a_i_flonum_sin" 4) x))
(define (fpcos x)
- #+(not unsafe)
(fp-check-flonum x 'fpcos)
(##core#inline_allocate ("C_a_i_flonum_cos" 4) x))
(define (fptan x)
- #+(not unsafe)
(fp-check-flonum x 'fptan)
(##core#inline_allocate ("C_a_i_flonum_tan" 4) x))
(define (fpasin x)
- #+(not unsafe)
(fp-check-flonum x 'fpasin)
(##core#inline_allocate ("C_a_i_flonum_asin" 4) x))
(define (fpacos x)
- #+(not unsafe)
(fp-check-flonum x 'fpacos)
(##core#inline_allocate ("C_a_i_flonum_acos" 4) x))
(define (fpatan x)
- #+(not unsafe)
(fp-check-flonum x 'fpatan)
(##core#inline_allocate ("C_a_i_flonum_atan" 4) x))
(define (fpatan2 x y)
- #+(not unsafe)
(fp-check-flonums x y 'fpatan2)
(##core#inline_allocate ("C_a_i_flonum_atan2" 4) x y))
(define (fpexp x)
- #+(not unsafe)
(fp-check-flonum x 'fpexp)
(##core#inline_allocate ("C_a_i_flonum_exp" 4) x))
(define (fpexpt x y)
- #+(not unsafe)
(fp-check-flonums x y 'fpexpt)
(##core#inline_allocate ("C_a_i_flonum_expt" 4) x y))
(define (fplog x)
- #+(not unsafe)
(fp-check-flonum x 'fplog)
(##core#inline_allocate ("C_a_i_flonum_log" 4) x))
(define (fpsqrt x)
- #+(not unsafe)
(fp-check-flonum x 'fpsqrt)
(##core#inline_allocate ("C_a_i_flonum_sqrt" 4) x))
(define (fpabs x)
- #+(not unsafe)
(fp-check-flonum x 'fpabs)
(##core#inline_allocate ("C_a_i_flonum_abs" 4) x))
(define (fpinteger? x)
- #+(not unsafe)
(fp-check-flonum x 'fpinteger?)
(##core#inline "C_u_i_fpintegerp" x))
@@ -1165,11 +1070,11 @@ EOF
(let loop ([ns ns] [f #t])
(let ([head (##sys#slot ns 0)]
[next (##sys#slot ns 1)] )
- (cond-expand [unsafe] [else (when f (##sys#check-integer head 'gcd))])
+ (when f (##sys#check-integer head 'gcd))
(if (null? next)
(abs head)
(let ([n2 (##sys#slot next 0)])
- (cond-expand [unsafe] [else (##sys#check-integer n2 'gcd)])
+ (##sys#check-integer n2 'gcd)
(loop (cons (##sys#gcd head n2) (##sys#slot next 1)) #f) ) ) ) ) ) )
(define (##sys#lcm x y)
@@ -1181,12 +1086,15 @@ EOF
(let loop ([ns ns] [f #t])
(let ([head (##sys#slot ns 0)]
[next (##sys#slot ns 1)] )
- (cond-expand [unsafe] [else (when f (##sys#check-integer head 'lcm))])
+ (when f (##sys#check-integer head 'lcm))
(if (null? next)
(abs head)
(let ([n2 (##sys#slot next 0)])
- (cond-expand [unsafe] [else (##sys#check-integer n2 'lcm)])
- (loop (cons (##sys#lcm head (##sys#slot next 0)) (##sys#slot next 1)) #f) ) ) ) ) ) )
+ (##sys#check-integer n2 'lcm)
+ (loop
+ (cons
+ (##sys#lcm head (##sys#slot next 0))
+ (##sys#slot next 1)) #f) ) ) ) ) ) )
(define ##sys#string->number (##core#primitive "C_string_to_number"))
(define string->number ##sys#string->number)
@@ -1376,7 +1284,7 @@ EOF
(define (##sys#make-vector size . fill)
(##sys#check-exact size 'make-vector)
- (cond-expand [unsafe] [else (when (fx< size 0) (##sys#error 'make-vector "size is negative" size))])
+ (when (fx< size 0) (##sys#error 'make-vector "size is negative" size))
(##sys#allocate-vector
size #f
(if (null? fill)
@@ -1387,19 +1295,7 @@ EOF
(define make-vector ##sys#make-vector)
(define (list->vector lst0)
- (cond-expand
- [unsafe
- (let* ([len (length lst0)]
- [v (##sys#make-vector len)] )
- (let loop ([lst lst0]
- [i 0])
- (if (null? lst)
- v
- (begin
- (##sys#setslot v i (##sys#slot lst 0))
- (loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) )]
- [else
- (if (not (list? lst0))
+ (if (not (list? lst0))
(##sys#error-not-a-proper-list lst0 'list->vector)
(let* ([len (length lst0)]
[v (##sys#make-vector len)] )
@@ -1409,8 +1305,7 @@ EOF
v
(begin
(##sys#setslot v i (##sys#slot lst 0))
- (loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) ) )]
- ))
+ (loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) ) ))
(define (vector->list v)
(##sys#check-vector v 'vector->list)
@@ -1438,13 +1333,10 @@ EOF
[len-to (##sys#size to)]
[n (if (pair? n) (car n) (fxmin len-to len-from))] )
(##sys#check-exact n 'vector-copy!)
- (cond-expand
- [(not unsafe)
- (when (or (fx> n len-to) (fx> n len-from))
- (##sys#signal-hook
- #:bounds-error 'vector-copy!
- "cannot copy vector - count exceeds length" from to n) ) ]
- [else] )
+ (when (or (fx> n len-to) (fx> n len-from))
+ (##sys#signal-hook
+ #:bounds-error 'vector-copy!
+ "cannot copy vector - count exceeds length" from to n) )
(do ([i 0 (fx+ i 1)])
((fx>= i n))
(##sys#setslot to i (##sys#slot from i)) ) ) )
@@ -1607,32 +1499,18 @@ EOF
(define (##sys#for-each p lst0)
(let loop ((lst lst0))
- (cond-expand
- [unsafe
- (if (eq? lst '())
- (##core#undefined)
- (begin
- (p (##sys#slot lst 0))
- (loop (##sys#slot lst 1)) ) ) ]
- [else
- (cond ((eq? lst '()) (##core#undefined))
- ((pair? lst)
- (p (##sys#slot lst 0))
- (loop (##sys#slot lst 1)) )
- (else (##sys#error-not-a-proper-list lst0 'for-each)) ) ] ) ) )
+ (cond ((eq? lst '()) (##core#undefined))
+ ((pair? lst)
+ (p (##sys#slot lst 0))
+ (loop (##sys#slot lst 1)) )
+ (else (##sys#error-not-a-proper-list lst0 'for-each)) ) ))
(define (##sys#map p lst0)
(let loop ((lst lst0))
- (cond-expand
- [unsafe
- (if (eq? lst '())
- lst
- (cons (p (##sys#slot lst 0)) (loop (##sys#slot lst 1))) ) ]
- [else
- (cond ((eq? lst '()) lst)
- ((pair? lst)
- (cons (p (##sys#slot lst 0)) (loop (##sys#slot lst 1))) )
- (else (##sys#error-not-a-proper-list lst0 'map)) ) ] ) ) )
+ (cond ((eq? lst '()) lst)
+ ((pair? lst)
+ (cons (p (##sys#slot lst 0)) (loop (##sys#slot lst 1))) )
+ (else (##sys#error-not-a-proper-list lst0 'map)) ) ))
(define for-each)
(define map)
@@ -1645,8 +1523,7 @@ EOF
lsts
(let ((item (##sys#slot lsts 0)))
(cond ((eq? item '())
- (cond-expand [unsafe (##core#undefined)]
- [else (check lsts start loc)] ) )
+ (check lsts start loc))
((pair? item)
(cons (p item) (mapsafe p (##sys#slot lsts 1) #f loc)) )
(else (##sys#error-not-a-proper-list item loc)) ) ) ) ) )
diff --git a/lolevel.scm b/lolevel.scm
index 9705bbac..020affde 100644
--- a/lolevel.scm
+++ b/lolevel.scm
@@ -141,25 +141,6 @@ EOF
(and (pair? loc) (car loc))
"bad argument type - not a pointer" x) ) )
-(cond-expand
- [unsafe
- (define-syntax ##sys#check-pointer
- (syntax-rules ()
- ((_ . _) (##core#undefined))))
- (define-syntax ##sys#check-block
- (syntax-rules ()
- ((_ . _) (##core#undefined))))
- (define-syntax ##sys#check-become-alist
- (syntax-rules ()
- ((_ . _) (##core#undefined))))
- (define-syntax ##sys#check-generic-structure
- (syntax-rules ()
- ((_ . _) (##core#undefined))))
- (define-syntax ##sys#check-generic-vector
- (syntax-rules ()
- ((_ . _) (##core#undefined)))) ]
- [else] )
-
;;; Move arbitrary blocks of memory around:
@@ -184,21 +165,19 @@ EOF
(apply ##sys#error 'move-memory! "number of bytes to move too large" from to args))
;
(define (checkn1 n nmax off)
- (if (cond-expand [unsafe #t] [else (fx<= n (fx- nmax off))])
+ (if (fx<= n (fx- nmax off))
n
(sizerr n nmax) ) )
;
(define (checkn2 n nmax nmax2 off1 off2)
- (if (cond-expand [unsafe #t] [else (and (fx<= n (fx- nmax off1)) (fx<= n (fx- nmax2 off2)))])
+ (if (and (fx<= n (fx- nmax off1)) (fx<= n (fx- nmax2 off2)))
n
(sizerr n nmax nmax2) ) )
;
(##sys#check-block from 'move-memory!)
(##sys#check-block to 'move-memory!)
- #+(not unsafe)
(when (fx< foffset 0)
(##sys#error 'move-memory! "negative source offset" foffset))
- #+(not unsafe)
(when (fx< toffset 0)
(##sys#error 'move-memory! "negative destination offset" toffset))
(let move ([from from] [to to])
@@ -535,7 +514,7 @@ EOF
y ) ] ) ) ) )
(define (object-evict-to-location x ptr . limit)
- (cond-expand [(not unsafe) (##sys#check-special ptr 'object-evict-to-location)] [else])
+ (##sys#check-special ptr 'object-evict-to-location)
(let* ([limit (and (pair? limit)
(let ([limit (car limit)])
(##sys#check-exact limit 'object-evict-to-location)
@@ -636,7 +615,7 @@ EOF
;;; `become':
(define (object-become! alst)
- (cond-expand [(not unsafe) (##sys#check-become-alist alst 'object-become!)] [else])
+ (##sys#check-become-alist alst 'object-become!)
(##sys#become! alst) )
(define (mutate-procedure old proc)
diff --git a/runtime.c b/runtime.c
index 81b454e7..13e1f500 100644
--- a/runtime.c
+++ b/runtime.c
@@ -3977,12 +3977,12 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
long tgc;
switch(fudge_factor) {
- case C_fix(1): return C_SCHEME_END_OF_FILE;
- case C_fix(2):
+ case C_fix(1): return C_SCHEME_END_OF_FILE; /* eof object */
+ case C_fix(2): /* get time */
/* can be considered broken (overflows into negatives), but is useful for randomize */
return C_fix(C_MOST_POSITIVE_FIXNUM & time(NULL));
- case C_fix(3):
+ case C_fix(3): /* 64-bit system? */
#ifdef C_SIXTY_FOUR
return C_SCHEME_TRUE;
#else
@@ -4003,50 +4003,50 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
return C_fix(0);
- case C_fix(6):
+ case C_fix(6): /* milliseconds CPU */
return C_fix(C_MOST_POSITIVE_FIXNUM & cpu_milliseconds());
- case C_fix(7):
+ case C_fix(7): /* wordsize */
return C_fix(sizeof(C_word));
- case C_fix(8):
+ case C_fix(8): /* words needed for double */
return C_fix(C_wordsperdouble(1));
- case C_fix(9):
+ case C_fix(9): /* latency */
return C_fix(last_interrupt_latency);
- case C_fix(10):
+ case C_fix(10): /* clocks per sec */
return C_fix(CLOCKS_PER_SEC);
- case C_fix(11):
+ case C_fix(11): /* not a unix system? */
#if defined(C_NONUNIX) || defined(__CYGWIN__)
return C_SCHEME_FALSE;
#else
return C_SCHEME_TRUE;
#endif
- case C_fix(12):
+ case C_fix(12): /* tty forced? */
return C_mk_bool(fake_tty_flag);
- case C_fix(13):
+ case C_fix(13): /* debug mode */
return C_mk_bool(debug_mode);
- case C_fix(14):
+ case C_fix(14): /* interrupts enabled? */
return C_mk_bool(C_interrupts_enabled);
- case C_fix(15):
+ case C_fix(15): /* symbol-gc enabled? */
return C_mk_bool(C_enable_gcweak);
- case C_fix(16):
+ case C_fix(16): /* milliseconds (wall clock) */
return C_fix(C_MOST_POSITIVE_FIXNUM & milliseconds());
- case C_fix(17):
+ case C_fix(17): /* fixed heap? */
return(C_mk_bool(C_heap_size_is_fixed));
- case C_fix(18):
+ case C_fix(18): /* stack direction */
return(C_fix(C_STACK_GROWS_DOWNWARD));
- case C_fix(19):
+ case C_fix(19): /* number of locatives */
for(i = j = 0; i < locative_table_count; ++i)
if(locative_table[ i ] != C_SCHEME_UNDEFINED) ++j;
return C_fix(j);
diff --git a/srfi-69.scm b/srfi-69.scm
index 0a8a5224..85f7269c 100644
--- a/srfi-69.scm
+++ b/srfi-69.scm
@@ -51,14 +51,11 @@
*hash-table-for-each *hash-table-fold
hash-table-canonical-length hash-table-rehash! hash-table-check-resize! ) )
-(cond-expand
- [unsafe]
- [else
- (declare
- (bound-to-procedure
- ##sys#check-string ##sys#check-symbol
- ##sys#check-exact ##sy#check-inexact
- ##sys#check-closure ##sys#check-structure ) ) ] )
+(declare
+ (bound-to-procedure
+ ##sys#check-string ##sys#check-symbol
+ ##sys#check-exact ##sy#check-inexact
+ ##sys#check-closure ##sys#check-structure ) )
(include "unsafe-declarations.scm")
diff --git a/tcp.scm b/tcp.scm
index c3ee0826..c2ac6ce4 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -255,11 +255,8 @@ EOF
(define (##net#bind-socket port style host)
(##sys#check-exact port)
- (cond-expand
- (unsafe)
- (else
- (when (or (fx< port 0) (fx>= port 65535))
- (##sys#signal-hook #:domain-error 'tcp-listen "invalid port number" port) ) ) )
+ (when (or (fx< port 0) (fx>= port 65535))
+ (##sys#signal-hook #:domain-error 'tcp-listen "invalid port number" port) )
(let ((s (##net#socket _af_inet style 0)))
(when (eq? _invalid_socket s)
(##sys#update-errno)
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 6edcfd61..ba915f24 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -215,7 +215,7 @@ $compile locative-stress-test.scm
./a.out
echo "======================================== syntax-rules stress test ..."
-time $interpret syntax-rule-stress-test.scm
+time $interpret -bnq syntax-rule-stress-test.scm
echo "======================================== embedding (1) ..."
$compile embedded1.c
Trap