From 2908767340badd5962ab0bb2578e315d29cb3176 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 1 Mar 2017 23:33:34 -0800 Subject: [PATCH] Giant edit to remove most of the now-obsolete guarantee-FOO bindings. --- doc/ref-manual/io.texi | 9 - doc/ref-manual/procedures.texi | 26 -- src/6001/arith.scm | 16 +- src/6001/edextra.scm | 6 +- src/6001/floppy.scm | 12 +- src/6001/pic-imag.scm | 6 +- src/6001/picture.scm | 20 +- src/compiler/back/lapgn1.scm | 6 +- src/compiler/back/regmap.scm | 2 +- src/compiler/base/crsend.scm | 2 +- src/compiler/base/utils.scm | 10 +- src/compiler/fggen/canon.scm | 2 +- src/compiler/fggen/fggen.scm | 6 +- src/compiler/fgopt/blktyp.scm | 18 +- src/compiler/fgopt/closan.scm | 22 +- src/compiler/fgopt/contan.scm | 43 ++- src/compiler/fgopt/folcon.scm | 6 +- src/compiler/fgopt/operan.scm | 23 +- src/compiler/fgopt/outer.scm | 4 +- src/compiler/fgopt/param.scm | 8 +- src/compiler/fgopt/reord.scm | 8 +- src/compiler/fgopt/reuse.scm | 12 +- src/compiler/fgopt/sideff.scm | 33 ++- src/compiler/fgopt/simple.scm | 2 +- src/compiler/improvements/gasn.scm | 4 +- src/compiler/machines/C/decls.scm | 43 +-- src/compiler/machines/i386/decls.scm | 43 +-- src/compiler/machines/i386/rulrew.scm | 12 +- .../machines/svm/assembler-compiler.scm | 42 +-- .../machines/svm/assembler-runtime.scm | 6 +- src/compiler/machines/svm/decls.scm | 43 +-- src/compiler/machines/svm/lapgen.scm | 6 +- src/compiler/machines/svm/machine.scm | 2 +- src/compiler/machines/svm/rules.scm | 8 +- src/compiler/machines/x86-64/decls.scm | 43 +-- src/compiler/machines/x86-64/rulrew.scm | 10 +- src/compiler/rtlbase/rtlexp.scm | 24 +- src/compiler/rtlgen/rtlgen.scm | 26 +- src/compiler/rtlopt/rdflow.scm | 26 +- src/compiler/rtlopt/rtlcsm.scm | 2 +- src/cref/conpkg.scm | 12 +- src/cref/redpkg.scm | 19 +- src/edwin/abbrev.scm | 4 +- src/edwin/basic.scm | 16 +- src/edwin/bufcom.scm | 8 +- src/edwin/buffer.scm | 2 +- src/edwin/comint.scm | 8 +- src/edwin/comtab.scm | 2 +- src/edwin/curren.scm | 6 +- src/edwin/dabbrev.scm | 12 +- src/edwin/dosfile.scm | 20 +- src/edwin/edwin.pkg | 1 - src/edwin/evlcom.scm | 4 +- src/edwin/fileio.scm | 18 +- src/edwin/info.scm | 6 +- src/edwin/input.scm | 2 +- src/edwin/intmod.scm | 8 +- src/edwin/keymap.scm | 6 +- src/edwin/linden.scm | 2 +- src/edwin/nntp.scm | 12 +- src/edwin/print.scm | 6 +- src/edwin/process.scm | 8 +- src/edwin/prompt.scm | 2 +- src/edwin/rfc822.scm | 4 +- src/edwin/rmail.scm | 30 +-- src/edwin/sendmail.scm | 14 +- src/edwin/simple.scm | 2 +- src/edwin/snr.scm | 16 +- src/edwin/string.scm | 40 +-- src/edwin/unix.scm | 14 +- src/edwin/utils.scm | 4 +- src/edwin/vc.scm | 10 +- src/edwin/vhdl.scm | 6 +- src/etc/ucd-converter.scm | 4 +- src/imail/imail-imap.scm | 4 +- src/imail/imail-mime.scm | 4 +- src/imail/imail-summary.scm | 6 +- src/imail/imail-top.scm | 12 +- src/microcode/makegen/makegen.scm | 6 +- src/runtime/boole.scm | 26 +- src/runtime/condvar.scm | 2 +- src/runtime/contin.scm | 2 +- src/runtime/datime.scm | 10 +- src/runtime/defstr.scm | 12 +- src/runtime/dosprm.scm | 2 +- src/runtime/dospth.scm | 14 +- src/runtime/dynamic.scm | 8 +- src/runtime/error.scm | 18 +- src/runtime/fixart.scm | 14 +- src/runtime/floenv.scm | 6 +- src/runtime/gcnote.scm | 2 +- src/runtime/generic.scm | 24 +- src/runtime/genio.scm | 2 +- src/runtime/gentag.scm | 6 +- src/runtime/global.scm | 17 +- src/runtime/hashtb.scm | 50 ++-- src/runtime/http-client.scm | 2 +- src/runtime/http-syntax.scm | 13 +- src/runtime/httpio.scm | 22 +- src/runtime/integer-bits.scm | 2 +- src/runtime/lambda-list.scm | 18 +- src/runtime/list.scm | 135 +++++----- src/runtime/mit-macros.scm | 2 +- src/runtime/ntprm.scm | 2 +- src/runtime/parse.scm | 10 +- src/runtime/pathnm.scm | 2 +- src/runtime/pgsql.scm | 2 +- src/runtime/process.scm | 4 +- src/runtime/record.scm | 26 +- src/runtime/rep.scm | 8 +- src/runtime/rexp.scm | 8 +- src/runtime/rfc2822-headers.scm | 12 +- src/runtime/runtime.pkg | 244 +----------------- src/runtime/scode.scm | 8 +- src/runtime/sfile.scm | 29 +-- src/runtime/srfi-1.scm | 26 +- src/runtime/stream.scm | 10 +- src/runtime/structure-parser.scm | 20 +- src/runtime/syntax-environment.scm | 18 +- src/runtime/syntax.scm | 6 +- src/runtime/thread-barrier.scm | 6 +- src/runtime/thread-queue.scm | 4 +- src/runtime/thread.scm | 22 +- src/runtime/tvector.scm | 6 +- src/runtime/udata.scm | 2 +- src/runtime/uenvir.scm | 35 +-- src/runtime/unpars.scm | 5 +- src/runtime/unsyn.scm | 8 +- src/runtime/unxprm.scm | 5 +- src/runtime/uproc.scm | 12 +- src/runtime/url.scm | 22 +- src/runtime/usrint.scm | 8 +- src/runtime/vector.scm | 32 +-- src/sf/analyze.scm | 141 ++++++---- src/sf/emodel.scm | 6 +- src/sf/object.scm | 10 +- src/sf/pardec.scm | 35 +-- src/sf/subst.scm | 2 +- src/sf/tables.scm | 2 +- src/sf/toplev.scm | 10 +- src/sos/class.scm | 6 +- src/sos/instance.scm | 2 +- src/sos/macros.scm | 2 +- src/sos/method.scm | 35 ++- src/ssp/mod-lisp.scm | 2 +- src/star-parser/shared.scm | 4 +- src/win32/graphics.scm | 2 +- src/xdoc/validate-xdoc.scm | 8 +- src/xdoc/xdoc.scm | 39 ++- src/xml/xhtml.scm | 2 +- src/xml/xml-names.scm | 2 +- src/xml/xml-parser.scm | 20 +- src/xml/xml-struct.scm | 8 +- tests/runtime/test-dynamic-env.scm | 3 +- tests/runtime/test-srfi-1.scm | 4 +- 155 files changed, 1012 insertions(+), 1346 deletions(-) diff --git a/doc/ref-manual/io.texi b/doc/ref-manual/io.texi index eac40d75a..4fd383162 100644 --- a/doc/ref-manual/io.texi +++ b/doc/ref-manual/io.texi @@ -123,15 +123,6 @@ output port, input/output port, textual port, binary port, or any kind of port, respectively. Otherwise they return @code{#f}. @end deffn -@deffn {obsolete procedure} guarantee-port object -@deffnx {obsolete procedure} guarantee-input-port object -@deffnx {obsolete procedure} guarantee-output-port object -@deffnx {obsolete procedure} guarantee-i/o-port object -@findex guarantee -These procedures are @strong{deprecated}. Instead use -@code{guarantee} with the appropriate predicate. -@end deffn - @deffn {standard procedure} input-port-open? port @deffnx {standard procedure} output-port-open? port Returns @code{#t} if @var{port} is still open and capable of diff --git a/doc/ref-manual/procedures.texi b/doc/ref-manual/procedures.texi index f5f609261..c7474d9e3 100644 --- a/doc/ref-manual/procedures.texi +++ b/doc/ref-manual/procedures.texi @@ -154,12 +154,6 @@ Returns @samp{#t} if @var{object} is an arity object, and @samp{#f} otherwise. @end deffn -@deffn procedure guarantee-procedure-arity object caller -Signals an error if @var{object} is not an arity object. @var{Caller} -is a symbol that is printed as part of the error message and is -intended to be the name of the procedure where the error occurs. -@end deffn - @deffn procedure procedure-arity-min arity @deffnx procedure procedure-arity-max arity Return the lower and upper bounds of @var{arity}, respectively. @@ -232,13 +226,6 @@ zero arguments, and @samp{#f} otherwise. Equivalent to: @end example @end deffn -@deffn procedure guarantee-thunk object caller -Signals an error if @var{object} is not a procedure accepting zero -arguments. @var{Caller} is a symbol that is printed as part of the -error message and is intended to be the name of the procedure where -the error occurs. -@end deffn - @node Primitive Procedures, Continuations, Arity, Procedures @section Primitive Procedures @@ -609,13 +596,6 @@ Returns @samp{#t} if @var{object} is a generic procedure, and @samp{#f} otherwise. @end deffn -@deffn procedure guarantee-generic-procedure object caller -Signals an error if @var{object} is not a generic procedure. -@var{Caller} is a symbol that is printed as part of the error message -and is intended to be the name of the procedure where the error -occurs. -@end deffn - @deffn procedure generic-procedure-arity generic Returns the arity of @var{generic}, as given to @code{make-generic-procedure}. @@ -749,9 +729,3 @@ Returns the dispatch tag associate with @var{record-type}. See Returns @samp{#t} if @var{object} is a dispatch tag, and @samp{#f} otherwise. @end deffn - -@deffn procedure guarantee-dispatch-tag object caller -Signals an error if @var{object} is not a dispatch tag. @var{Caller} -is a symbol that is printed as part of the error message and is -intended to be the name of the procedure where the error occurs. -@end deffn diff --git a/src/6001/arith.scm b/src/6001/arith.scm index 981ca973b..8f81d8090 100644 --- a/src/6001/arith.scm +++ b/src/6001/arith.scm @@ -44,10 +44,6 @@ USA. (error:wrong-type-argument x "integer" 'FLONUM->INTEGER)) (flo:truncate->exact x)) -(define-integrable (guarantee-integer object procedure) - (if (not (int:integer? object)) - (error:wrong-type-argument object "number" procedure))) - (define-syntax define-standard-unary (sc-macro-transformer (lambda (form environment) @@ -60,7 +56,7 @@ USA. (define-standard-unary integer? flo:integer? int:integer?) (define-standard-unary exact? (lambda (x) x false) (lambda (x) - (guarantee-integer x 'EXACT?) + (guarantee int:integer? x 'EXACT?) true)) (define-standard-unary zero? flo:zero? int:zero?) (define-standard-unary negative? flo:negative? int:negative?) @@ -77,7 +73,7 @@ USA. (error:bad-range-argument x 'INEXACT->EXACT)) (flo:truncate->exact x)) (lambda (x) - (guarantee-integer x 'INEXACT->EXACT) + (guarantee int:integer? x 'INEXACT->EXACT) x)) (define-syntax define-standard-binary @@ -138,12 +134,12 @@ USA. (if (flonum? y) (flo:= x y) (begin - (guarantee-integer y '=) + (guarantee int:integer? y '=) (and (flo:= x (flo:truncate x)) (int:= (flo:truncate->exact x) y)))) (if (flonum? y) (begin - (guarantee-integer x '=) + (guarantee int:integer? x '=) (and (flo:= y (flo:truncate y)) (int:= x (flo:truncate->exact y)))) (int:= x y)))) @@ -219,14 +215,14 @@ USA. (if (flonum? q) (int:->flonum (rat:numerator (flo:->rational q))) (begin - (guarantee-integer q 'NUMERATOR) + (guarantee int:integer? q 'NUMERATOR) q))) (define (denominator q) (if (flonum? q) (int:->flonum (rat:denominator (flo:->rational q))) (begin - (guarantee-integer q 'DENOMINATOR) + (guarantee int:integer? q 'DENOMINATOR) 1))) (define-syntax define-transcendental-unary diff --git a/src/6001/edextra.scm b/src/6001/edextra.scm index f647468ab..0d364246c 100644 --- a/src/6001/edextra.scm +++ b/src/6001/edextra.scm @@ -246,9 +246,9 @@ Now, there is formatting stuff to be considered here, in print-pgm.sh. ;;; Returns #t iff FILES all exist in DIRECTORY. (define (files-all-exist? files directory) - (for-all? files - (lambda (file) - (file-exists? (merge-pathnames directory file))))) + (every (lambda (file) + (file-exists? (merge-pathnames directory file))) + files)) (define-command load-problem-set "Load a 6.001 problem set." diff --git a/src/6001/floppy.scm b/src/6001/floppy.scm index fda3c713c..327a7cd35 100644 --- a/src/6001/floppy.scm +++ b/src/6001/floppy.scm @@ -900,12 +900,12 @@ M-x rename-file, or use the `r' command in Dired.") (not (substring-find-next-char-in-set filename 0 end invalid-chars)) (not - (there-exists? '("clock$" "con" "aux" "com1" "com2" - "com3" "com4" "lpt1" "lpt2" - "lpt3" "nul" "prn") - (lambda (name) - (substring=? filename 0 end - name 0 (string-length name))))))))) + (any (lambda (name) + (substring=? filename 0 end + name 0 (string-length name))) + '("clock$" "con" "aux" "com1" "com2" + "com3" "com4" "lpt1" "lpt2" + "lpt3" "nul" "prn"))))))) (let ((dot (string-find-next-char filename #\.))) (if (not dot) (valid-name? end) diff --git a/src/6001/pic-imag.scm b/src/6001/pic-imag.scm index 9940df8f1..1ed0ad1ab 100644 --- a/src/6001/pic-imag.scm +++ b/src/6001/pic-imag.scm @@ -38,9 +38,9 @@ USA. (image-width (fix:* h-sf pic-width)) ;x (image-height (fix:* v-sf pic-height)) ;iy (use-string? - (for-all? (vector->list gray-map) - (lambda (n) - (<= 0 n 255)))) + (every (lambda (n) + (<= 0 n 255)) + (vector->list gray-map))) (image (image/create window image-width image-height)) (pixels (if use-string? diff --git a/src/6001/picture.scm b/src/6001/picture.scm index e5e70d975..6ba94bc8c 100644 --- a/src/6001/picture.scm +++ b/src/6001/picture.scm @@ -144,18 +144,18 @@ USA. (visual-info (vector->list (x-graphics/visual-info window)))) (let ((find-class (lambda (class) - (there-exists? visual-info - (lambda (info) - (eqv? class (x-visual-info/class info)))))) + (any (lambda (info) + (eqv? class (x-visual-info/class info))) + visual-info))) (find-range (lambda (class depth-min depth-max) - (there-exists? visual-info - (lambda (info) - (and (eqv? class (x-visual-info/class info)) - ;; kludge, but X made us do it. - (<= depth-min - (x-visual-info/colormap-size info) - depth-max)))))) + (any (lambda (info) + (and (eqv? class (x-visual-info/class info)) + ;; kludge, but X made us do it. + (<= depth-min + (x-visual-info/colormap-size info) + depth-max))) + visual-info))) (make-gray-map (lambda (n-levels) (let ((gm (make-vector n-levels)) diff --git a/src/compiler/back/lapgn1.scm b/src/compiler/back/lapgn1.scm index c7f262cf5..7d2e23868 100644 --- a/src/compiler/back/lapgn1.scm +++ b/src/compiler/back/lapgn1.scm @@ -118,9 +118,9 @@ USA. (let ((next (edge-next-node edge))) (if (and next (not (node-marked? next))) (let ((previous (node-previous-edges next))) - (cond ((for-all? previous - (lambda (edge) - (memq edge (rgraph-entry-edges rgraph)))) + (cond ((every (lambda (edge) + (memq edge (rgraph-entry-edges rgraph))) + previous) ;; Assumption: no action needed to clear existing ;; register map at this point. (loop next (empty-register-map))) diff --git a/src/compiler/back/regmap.scm b/src/compiler/back/regmap.scm index 8430faa52..b714e745b 100644 --- a/src/compiler/back/regmap.scm +++ b/src/compiler/back/regmap.scm @@ -729,7 +729,7 @@ for REGISTER. If no such register exists, returns #F." (loop (cdr entries))))))) (define (register-map-clear? map) - (for-all? (map-entries map) map-entry-saved-into-home?)) + (every map-entry-saved-into-home? (map-entries map))) ;;;; Map Coercion diff --git a/src/compiler/base/crsend.scm b/src/compiler/base/crsend.scm index 9f71b3655..5dba929c9 100644 --- a/src/compiler/base/crsend.scm +++ b/src/compiler/base/crsend.scm @@ -131,7 +131,7 @@ USA. (if (compiled-code-block? code-vector) code-vector (begin - (guarantee-vector code-vector #f) + (guarantee vector? code-vector #f) (let ((new-code-vector (cross-link/finish-assembly (cc-code-block/bit-string code-vector) diff --git a/src/compiler/base/utils.scm b/src/compiler/base/utils.scm index 03a6a63f6..1f0813b61 100644 --- a/src/compiler/base/utils.scm +++ b/src/compiler/base/utils.scm @@ -99,17 +99,17 @@ USA. (if (null? items) (error "ALL-EQ?: undefined for empty set")) (or (null? (cdr items)) - (for-all? (cdr items) - (let ((item (car items))) - (lambda (item*) - (eq? item item*)))))) + (every (let ((item (car items))) + (lambda (item*) + (eq? item item*))) + (cdr items)))) (define (all-eq-map? items map) (if (null? items) (error "ALL-EQ-MAP?: undefined for empty set")) (let ((item (map (car items)))) (if (or (null? (cdr items)) - (for-all? (cdr items) (lambda (item*) (eq? item (map item*))))) + (every (lambda (item*) (eq? item (map item*))) (cdr items))) (values true item) (values false false)))) diff --git a/src/compiler/fggen/canon.scm b/src/compiler/fggen/canon.scm index a1f156402..c768de898 100644 --- a/src/compiler/fggen/canon.scm +++ b/src/compiler/fggen/canon.scm @@ -430,7 +430,7 @@ ARBITRARY: The expression may be executed more than once. It (collect knames kvals directive-wrapper)) (join (collect knames kvals directive-wrapper) (collect vnames vvals identity-procedure)))))) - (for-all? values canout-safe?) + (every canout-safe? values) true false)) ((pseudo-constant? (car values)) diff --git a/src/compiler/fggen/fggen.scm b/src/compiler/fggen/fggen.scm index e008fda4f..29d5eb97d 100644 --- a/src/compiler/fggen/fggen.scm +++ b/src/compiler/fggen/fggen.scm @@ -842,9 +842,9 @@ USA. (let ((operands (generate/operands expression (scode/combination-operands expression) block continuation context 1))) - (if (for-all? operands - (lambda (subpr) - (rvalue/constant? (subproblem-rvalue subpr)))) + (if (every (lambda (subpr) + (rvalue/constant? (subproblem-rvalue subpr))) + operands) (generate/constant block continuation context (list->vector diff --git a/src/compiler/fgopt/blktyp.scm b/src/compiler/fgopt/blktyp.scm index be1fb4ee3..95b2b8b3a 100644 --- a/src/compiler/fgopt/blktyp.scm +++ b/src/compiler/fgopt/blktyp.scm @@ -144,9 +144,7 @@ USA. (and block* (let ((closure-block (block-parent block)) (ancestor-block (block-shared-block (block-parent block*)))) - (and (for-all? - (refilter-variables (block-bound-variables closure-block) - update? procedure) + (and (every (let ((bvars (block-bound-variables ancestor-block))) (lambda (var) (or (memq var bvars) @@ -158,7 +156,9 @@ USA. (procedure/full-closure? val) (eq? (block-shared-block (procedure-closing-block val)) - ancestor-block))))))))) + ancestor-block)))))))) + (refilter-variables (block-bound-variables closure-block) + update? procedure)) (graft-child! procedure ancestor-block closure-block)))))) (define (graft-child! procedure ancestor-block closure-block) @@ -289,17 +289,17 @@ USA. (closure-block (block-parent block*))) (if (and (or (not (block-parent closure-block)) ic-parent) - (for-all? - (refilter-variables - (block-bound-variables closure-block) - update? (block-procedure block*)) + (every (lambda (var) (or (lvalue-implicit? var unconditional) (let ((ind (variable-indirection var))) (memq (if ind (car ind) var) - closed-over-variables)))))) + closed-over-variables)))) + (refilter-variables + (block-bound-variables closure-block) + update? (block-procedure block*)))) (cons (car conditional) block-closed) block-closed)))) ((null? (cdr block-closed)) diff --git a/src/compiler/fgopt/closan.scm b/src/compiler/fgopt/closan.scm index d4d9a8a1d..38e74ea88 100644 --- a/src/compiler/fgopt/closan.scm +++ b/src/compiler/fgopt/closan.scm @@ -254,7 +254,7 @@ USA. (close-combination-arguments! combination))))) (define (compatibility-class procs) - (if (for-all? procs rvalue/procedure?) + (if (every rvalue/procedure? procs) (let* ((model (car procs)) (model-env (procedure-closing-block model))) (call-with-values (lambda () (procedure-arity-encoding model)) @@ -491,9 +491,9 @@ USA. (remove-condition procedure) (for-each (let ((block (procedure-block procedure))) (lambda (entry) - (if (there-exists? (cdr entry) - (lambda (entry*) - (block-ancestor-or-self? (car entry*) block))) + (if (any (lambda (entry*) + (block-ancestor-or-self? (car entry*) block)) + (cdr entry)) (close-non-descendant-callees! (car entry) block condition)))) *undrifting-constraints*)) @@ -565,7 +565,7 @@ USA. (define (pending-undrifting? procedure) (let ((entry (assq (procedure-block procedure) *undrifting-constraints*))) (and entry - (there-exists? (cdr entry) valid-constraint-conditions?)))) + (any valid-constraint-conditions? (cdr entry))))) (define (undrift-procedures! constraints) (for-each @@ -589,12 +589,12 @@ USA. constraints)) (define (valid-constraint-conditions? entry) - (there-exists? (cdr entry) - (lambda (condition) - (not - (and condition - (eq? 'CONTAGION (condition-keyword condition)) - (procedure/trivial-closure? (condition-argument condition))))))) + (any (lambda (condition) + (not + (and condition + (eq? 'CONTAGION (condition-keyword condition)) + (procedure/trivial-closure? (condition-argument condition))))) + (cdr entry))) (define-structure condition (procedure #f read-only #t) diff --git a/src/compiler/fgopt/contan.scm b/src/compiler/fgopt/contan.scm index 6f08cacc2..98dffe3e4 100644 --- a/src/compiler/fgopt/contan.scm +++ b/src/compiler/fgopt/contan.scm @@ -105,8 +105,7 @@ may change if call-with-current-continuation is handled specially. (and (not (lvalue/external-source? lvalue)) (null? (lvalue-initial-values lvalue)) (memq end (lvalue-backward-links lvalue)) - (for-all? (lvalue-initial-backward-links lvalue) - next))) + (every next (lvalue-initial-backward-links lvalue)))) (define (next lvalue) (if (lvalue-marked? lvalue) @@ -149,28 +148,28 @@ may change if call-with-current-continuation is handled specially. (else true))))) (define (block/no-free-references? block) - (and (for-all? (block-free-variables block) - (lambda (variable) - (or (lvalue-integrated? variable) - (let ((block (variable-block variable))) - (and (ic-block? block) - (not (ic-block/use-lookup? block))))))) + (and (every (lambda (variable) + (or (lvalue-integrated? variable) + (let ((block (variable-block variable))) + (and (ic-block? block) + (not (ic-block/use-lookup? block)))))) + (block-free-variables block)) (let loop ((block* block)) (and (not - (there-exists? (block-applications block*) - (lambda (application) - (let ((block* - (if (application/combination? application) - (let ((adjustment - (combination/frame-adjustment - application))) - (and adjustment - (cdr adjustment))) - (block-popping-limit - (reference-context/block - (application-context application)))))) - (and block* (block-ancestor? block block*)))))) - (for-all? (block-children block*) loop))))) + (any (lambda (application) + (let ((block* + (if (application/combination? application) + (let ((adjustment + (combination/frame-adjustment + application))) + (and adjustment + (cdr adjustment))) + (block-popping-limit + (reference-context/block + (application-context application)))))) + (and block* (block-ancestor? block block*)))) + (block-applications block*))) + (every loop (block-children block*)))))) (define (compute-block-popping-limits block) (let ((external (stack-block/external-ancestor block))) diff --git a/src/compiler/fgopt/folcon.scm b/src/compiler/fgopt/folcon.scm index 41b23e469..2441ee689 100644 --- a/src/compiler/fgopt/folcon.scm +++ b/src/compiler/fgopt/folcon.scm @@ -96,7 +96,7 @@ USA. (define (delete-if-known! lvalue) (if (and (not (lvalue-known-value lvalue)) - (for-all? (lvalue-source-links lvalue) lvalue-known-value)) + (every lvalue-known-value (lvalue-source-links lvalue))) (let ((value (car (lvalue-values lvalue)))) (for-each (lambda (lvalue*) (if (lvalue-marked? lvalue*) @@ -167,7 +167,7 @@ USA. (and (constant-foldable-operator? operator) ;; (rvalue-known? continuation) ;; (uni-continuation? (rvalue-known-value continuation)) - (for-all? operands rvalue-known-constant?) + (every rvalue-known-constant? operands) (let ((op (constant-foldable-operator-value operator))) (and (or (arity-correct? op (length operands)) (begin @@ -210,7 +210,7 @@ USA. (define (recompute-lvalue-passed-in! lvalue) (set-lvalue-passed-in?! lvalue false) - (if (there-exists? (lvalue-backward-links lvalue) lvalue-passed-in?) + (if (any lvalue-passed-in? (lvalue-backward-links lvalue)) (begin (set-lvalue-passed-in?! lvalue 'INHERITED) ;; The assignment would return the right value, but this is clearer. diff --git a/src/compiler/fgopt/operan.scm b/src/compiler/fgopt/operan.scm index 045bb4895..c7bc61d4b 100644 --- a/src/compiler/fgopt/operan.scm +++ b/src/compiler/fgopt/operan.scm @@ -56,13 +56,13 @@ USA. (rvalue-values (combination/continuation combination)))) (define (continuation-passed-out? continuation) - (there-exists? (continuation/combinations continuation) - (lambda (combination) - (and (not (combination/simple-inline? combination)) - (let ((operator (combination/operator combination))) - (or (rvalue-passed-in? operator) - (there-exists? (rvalue-values operator) - (lambda (rvalue) (not (rvalue/procedure? rvalue)))))))))) + (any (lambda (combination) + (and (not (combination/simple-inline? combination)) + (let ((operator (combination/operator combination))) + (or (rvalue-passed-in? operator) + (any (lambda (rvalue) (not (rvalue/procedure? rvalue))) + (rvalue-values operator)))))) + (continuation/combinations continuation))) (define (analyze/continuation continuation) (let ((returns (continuation/returns continuation)) @@ -96,7 +96,8 @@ USA. (and (not (procedure-passed-out? procedure)) (let ((combinations (procedure-applications procedure))) (and (not (null? combinations)) - (for-all? combinations - (lambda (combination) - (eq? (rvalue-known-value (combination/operator combination)) - procedure))))))) \ No newline at end of file + (every (lambda (combination) + (eq? (rvalue-known-value + (combination/operator combination)) + procedure)) + combinations))))) \ No newline at end of file diff --git a/src/compiler/fgopt/outer.scm b/src/compiler/fgopt/outer.scm index 10d189bc3..ccba4d102 100644 --- a/src/compiler/fgopt/outer.scm +++ b/src/compiler/fgopt/outer.scm @@ -54,8 +54,8 @@ USA. ;; `lexical-unassigned?' with a known block for its first argument ;; and a known symbol for its second. Unfortunately, doing this ;; optimally introduces feedback in this analysis. - (if (there-exists? (rvalue-values (application-operator application)) - (lambda (value) (not (rvalue/procedure? value)))) + (if (any (lambda (value) (not (rvalue/procedure? value))) + (rvalue-values (application-operator application))) (application-arguments-passed-out! application))) (define (check-application application) diff --git a/src/compiler/fgopt/param.scm b/src/compiler/fgopt/param.scm index 3a407901f..a6f98b9d9 100644 --- a/src/compiler/fgopt/param.scm +++ b/src/compiler/fgopt/param.scm @@ -114,7 +114,7 @@ parameters in registers. (order-parallel! node (let ((subproblems (parallel-subproblems node))) - (if (for-all? subproblems subproblem-simple?) + (if (every subproblem-simple? subproblems) false (complex-parallel-constraints subproblems @@ -229,9 +229,9 @@ parameters in registers. (lambda (subproblems) (discriminate-items subproblems (lambda (subproblem) - (there-exists? (subproblem-free-variables subproblem) - (lambda (var) - (memq var vars-referenced-later))))))) + (any (lambda (var) + (memq var vars-referenced-later)) + (subproblem-free-variables subproblem)))))) (constraint-graph (make-constraint-graph))) (with-values (lambda () (discriminate-by-bad-vars simple)) (lambda (good-simples bad-simples) diff --git a/src/compiler/fgopt/reord.scm b/src/compiler/fgopt/reord.scm index 1900cdfcd..e6540b3ff 100644 --- a/src/compiler/fgopt/reord.scm +++ b/src/compiler/fgopt/reord.scm @@ -159,10 +159,10 @@ number of assignments of any ordering. (if (first-node-needs-temporary? nodes) (1+ cost) cost)))))) (define (first-node-needs-temporary? nodes) - (there-exists? (cdr nodes) - (let ((target (node-target (car nodes)))) - (lambda (node) - (memq target (node-original-dependencies node)))))) + (any (let ((target (node-target (car nodes)))) + (lambda (node) + (memq target (node-original-dependencies node)))) + (cdr nodes))) (define (reorder! nodes find-index) ;; This is expensive. It could be done for all at once, diff --git a/src/compiler/fgopt/reuse.scm b/src/compiler/fgopt/reuse.scm index 1d0020449..6136f1ec3 100644 --- a/src/compiler/fgopt/reuse.scm +++ b/src/compiler/fgopt/reuse.scm @@ -58,9 +58,9 @@ USA. (else (stack-block/external-ancestor block)))))))) (and adjustment - (if (for-all? (block-popping-limits block) - (lambda (limit) - (block-ancestor-or-self? adjustment limit))) + (if (every (lambda (limit) + (block-ancestor-or-self? adjustment limit)) + (block-popping-limits block)) (cons 'KNOWN adjustment) (let ((limit (block-popping-limit block))) (if limit @@ -266,9 +266,9 @@ USA. rest) ((first-node-needs-temporary? nodes) (linearize-subproblem! - (if (for-all? (cdr nodes) - (lambda (node) - (subproblem-simple? (node-value node)))) + (if (every (lambda (node) + (subproblem-simple? (node-value node))) + (cdr nodes)) continuation-type/register continuation-type/push) (node-value (car nodes)) diff --git a/src/compiler/fgopt/sideff.scm b/src/compiler/fgopt/sideff.scm index 5c524b1be..ef00db659 100644 --- a/src/compiler/fgopt/sideff.scm +++ b/src/compiler/fgopt/sideff.scm @@ -149,12 +149,11 @@ USA. (list-transform-positive (block-free-variables block) (lambda (variable) - (there-exists? - (variable-assignments variable) - (lambda (assignment) - (eq? (reference-context/block - (assignment-context assignment)) - block))))))) + (any (lambda (assignment) + (eq? (reference-context/block + (assignment-context assignment)) + block)) + (variable-assignments variable)))))) (arbitrary-callees (list-transform-negative (car (procedure-initial-callees procedure)) @@ -318,13 +317,13 @@ USA. (define (check value op-vals) (if (and value - (for-all? op-vals - (lambda (proc) - (and (rvalue/procedure? proc) - (eq? value - (procedure/simplified-value - proc - (application-block app))))))) + (every (lambda (proc) + (and (rvalue/procedure? proc) + (eq? value + (procedure/simplified-value + proc + (application-block app))))) + op-vals)) (simplify-combination! value))) (define (check-operators operator) @@ -340,10 +339,10 @@ USA. (let ((operator (application-operator app)) (cont (combination/continuation app))) (and (not (rvalue-passed-in? operator)) - (for-all? (rvalue-values operator) - (lambda (proc) - (and (rvalue/procedure? proc) - (null? (procedure-side-effects proc))))) + (every (lambda (proc) + (and (rvalue/procedure? proc) + (null? (procedure-side-effects proc)))) + (rvalue-values operator)) (cond ((rvalue/procedure? cont) (if (eq? (continuation/type cont) continuation-type/effect) diff --git a/src/compiler/fgopt/simple.scm b/src/compiler/fgopt/simple.scm index fa5687c50..d2d0b0b26 100644 --- a/src/compiler/fgopt/simple.scm +++ b/src/compiler/fgopt/simple.scm @@ -66,7 +66,7 @@ USA. (define (walk/node node continuation) (cfg-node-case (tagged-vector/tag node) ((PARALLEL) - (and (for-all? (parallel-subproblems node) walk/subproblem) + (and (every walk/subproblem (parallel-subproblems node)) (walk/next (snode-next node) continuation))) ((APPLICATION) (case (application-type node) diff --git a/src/compiler/improvements/gasn.scm b/src/compiler/improvements/gasn.scm index 0d70beadf..3f5dc1abf 100644 --- a/src/compiler/improvements/gasn.scm +++ b/src/compiler/improvements/gasn.scm @@ -84,8 +84,8 @@ dependent))))))) (define (nodes-simple? nodes) - (for-all? (cdr nodes) - (lambda (node) (subproblem-simple? (node-value node))))) + (every (lambda (node) (subproblem-simple? (node-value node))) + (cdr nodes))) (define (trivial-assignment node rest) (if (node/noop? node) diff --git a/src/compiler/machines/C/decls.scm b/src/compiler/machines/C/decls.scm index 5b291b1ee..d284bfbbf 100644 --- a/src/compiler/machines/C/decls.scm +++ b/src/compiler/machines/C/decls.scm @@ -208,23 +208,24 @@ USA. (lambda (node) (let ((time (source-node/modification-time node))) (if (and time - (there-exists? (source-node/dependencies node) - (lambda (node*) - (let ((newer? - (let ((time* - (source-node/modification-time node*))) - (or (not time*) - (> time* time))))) - (if newer? - (write-notification-line - (lambda (port) - (write-string "Binary file " port) - (write (source-node/filename node) port) - (write-string " newer than dependency " - port) - (write (source-node/filename node*) - port)))) - newer?)))) + (any (lambda (node*) + (let ((newer? + (let ((time* + (source-node/modification-time + node*))) + (or (not time*) + (> time* time))))) + (if newer? + (write-notification-line + (lambda (port) + (write-string "Binary file " port) + (write (source-node/filename node) port) + (write-string " newer than dependency " + port) + (write (source-node/filename node*) + port)))) + newer?)) + (source-node/dependencies node))) (set-source-node/modification-time! node #f)))) source-nodes) (for-each @@ -259,10 +260,10 @@ USA. (if (not (source-node/modification-time node)) (source-node/syntax! node))) source-nodes/by-rank))) - (if (there-exists? source-nodes/by-rank - (lambda (node) - (and (not (source-node/modification-time node)) - (source-node/circular? node)))) + (if (any (lambda (node) + (and (not (source-node/modification-time node)) + (source-node/circular? node))) + source-nodes/by-rank) (begin (write-notification-line (lambda (port) diff --git a/src/compiler/machines/i386/decls.scm b/src/compiler/machines/i386/decls.scm index f1e9eaebc..e45fbc2ad 100644 --- a/src/compiler/machines/i386/decls.scm +++ b/src/compiler/machines/i386/decls.scm @@ -208,23 +208,24 @@ USA. (lambda (node) (let ((time (source-node/modification-time node))) (if (and time - (there-exists? (source-node/dependencies node) - (lambda (node*) - (let ((newer? - (let ((time* - (source-node/modification-time node*))) - (or (not time*) - (> time* time))))) - (if newer? - (write-notification-line - (lambda (port) - (write-string "Binary file " port) - (write (source-node/filename node) port) - (write-string " newer than dependency " - port) - (write (source-node/filename node*) - port)))) - newer?)))) + (any (lambda (node*) + (let ((newer? + (let ((time* + (source-node/modification-time + node*))) + (or (not time*) + (> time* time))))) + (if newer? + (write-notification-line + (lambda (port) + (write-string "Binary file " port) + (write (source-node/filename node) port) + (write-string " newer than dependency " + port) + (write (source-node/filename node*) + port)))) + newer?)) + (source-node/dependencies node))) (set-source-node/modification-time! node #f)))) source-nodes) (for-each @@ -259,10 +260,10 @@ USA. (if (not (source-node/modification-time node)) (source-node/syntax! node))) source-nodes/by-rank))) - (if (there-exists? source-nodes/by-rank - (lambda (node) - (and (not (source-node/modification-time node)) - (source-node/circular? node)))) + (if (any (lambda (node) + (and (not (source-node/modification-time node)) + (source-node/circular? node))) + source-nodes/by-rank) (begin (write-notification-line (lambda (port) diff --git a/src/compiler/machines/i386/rulrew.scm b/src/compiler/machines/i386/rulrew.scm index cf039b3e5..f50eb5825 100644 --- a/src/compiler/machines/i386/rulrew.scm +++ b/src/compiler/machines/i386/rulrew.scm @@ -366,7 +366,7 @@ OBJECT->FIXNUM not, after all, independent of the tag. (QUALIFIER (and (rtl:offset-address? base) (rtl:simple-subexpressions? base) - (rtl:machine-constant? (rtl:offset-address-offset base)))) + (rtl:machine-constant? (rtl:offset-address-offset base)))) (rtl:make-float-offset base (rtl:make-machine-constant value))) ;; This is here to avoid generating things like @@ -379,9 +379,7 @@ OBJECT->FIXNUM not, after all, independent of the tag. ;; known! (define (rtl:simple-subexpressions? expr) - (for-all? (cdr expr) - (lambda (sub) - (or (rtl:machine-constant? sub) - (rtl:register? sub))))) - - + (every (lambda (sub) + (or (rtl:machine-constant? sub) + (rtl:register? sub))) + (cdr expr))) \ No newline at end of file diff --git a/src/compiler/machines/svm/assembler-compiler.scm b/src/compiler/machines/svm/assembler-compiler.scm index 38335289f..15fa1e1c8 100644 --- a/src/compiler/machines/svm/assembler-compiler.scm +++ b/src/compiler/machines/svm/assembler-compiler.scm @@ -139,16 +139,16 @@ USA. ;; Check for duplicate pattern variables. (do ((pvars (defn-pvars defn) (cdr pvars))) ((not (pair? pvars))) - (if (there-exists? (cdr pvars) - (lambda (pv) - (eq? (pvar-name pv) (pvar-name (car pvars))))) + (if (any (lambda (pv) + (eq? (pvar-name pv) (pvar-name (car pvars)))) + (cdr pvars)) (error "Duplicate pattern variable:" (car pvars)))) ;; Check for missing or extra variable references in coding. (let ((pvars1 (defn-pvars defn)) (pvars2 (defn-coding defn))) (if (not (and (fix:= (length pvars1) (length pvars2)) - (for-all? pvars1 (lambda (pv1) (memq pv1 pvars2))) - (for-all? pvars2 (lambda (pv2) (memq pv2 pvars1))))) + (every (lambda (pv1) (memq pv1 pvars2)) pvars1) + (every (lambda (pv2) (memq pv2 pvars1)) pvars2))) (error "Pattern/coding mismatch:" pvars1 pvars2))) ;; Check for incorrect use of code marker. (if (and (defn-has-code? defn) @@ -365,7 +365,7 @@ USA. pvars has-code? (map (lambda (item) - (guarantee-symbol item #f) + (guarantee symbol? item #f) (or (find-matching-item pvars (lambda (pv) (eq? (pvar-name pv) item))) @@ -402,11 +402,11 @@ USA. (define (independent-coding-type? type coding-types) (let ((implicit-types (delete-matching-items coding-types coding-type-explicit?))) - (for-all? (coding-type-defns type) - (lambda (defn) - (not (there-exists? (defn-pvars defn) - (lambda (pv) - (find-coding-type (pvar-type pv) implicit-types #f)))))))) + (every (lambda (defn) + (not (any (lambda (pv) + (find-coding-type (pvar-type pv) implicit-types #f)) + (defn-pvars defn)))) + (coding-type-defns type)))) (define (expand-coding-type to-substitute to-expand) (let ((type-name (coding-type-name to-substitute))) @@ -475,9 +475,9 @@ USA. (let ((pv (car pvars)) (clash? (lambda (name) - (there-exists? pvars* - (lambda (pv) - (eq? (pvar-name pv) name))))) + (any (lambda (pv) + (eq? (pvar-name pv) name)) + pvars*))) (k (lambda (pv) (loop (cdr pvars) (cons pv pvars*))))) @@ -615,7 +615,7 @@ USA. (defn-name defn) lower-limit)) defns))) - (if (for-all? indices (lambda (i) i)) + (if (every (lambda (i) i) indices) (loop (if (apply = indices) (let ((index (car indices))) (let ((names @@ -651,9 +651,9 @@ USA. #t)) (define (deleteable-name-item? item) - (there-exists? (pvar-types) - (lambda (pvt) - (eq? (pvt-abbreviation pvt) item)))) + (any (lambda (pvt) + (eq? (pvt-abbreviation pvt) item)) + (pvar-types))) (define (deleteable-name-items) (map pvt-abbreviation (pvar-types))) @@ -728,9 +728,9 @@ USA. #t) "_")) (long-form? - (there-exists? (coding-type-defns coding-type) - (lambda (defn) - (pair? (defn-coding defn)))))) + (any (lambda (defn) + (pair? (defn-coding defn))) + (coding-type-defns coding-type)))) (write-c-code-macro prefix "START_CODE" (coding-type-start-index coding-type) diff --git a/src/compiler/machines/svm/assembler-runtime.scm b/src/compiler/machines/svm/assembler-runtime.scm index 22d2231c5..62d31d9ca 100644 --- a/src/compiler/machines/svm/assembler-runtime.scm +++ b/src/compiler/machines/svm/assembler-runtime.scm @@ -478,9 +478,9 @@ USA. (symbol? (caddr pattern)) (null? (cdddr pattern)))) (lose)) - (if (there-exists? pvars - (lambda (pv) - (eq? (pvar-name pv) (pvar-name pattern)))) + (if (any (lambda (pv) + (eq? (pvar-name pv) (pvar-name pattern))) + pvars) ;; Don't add duplicate pvar. pvars (cons pattern pvars))) diff --git a/src/compiler/machines/svm/decls.scm b/src/compiler/machines/svm/decls.scm index be89c1925..4c4332b9b 100644 --- a/src/compiler/machines/svm/decls.scm +++ b/src/compiler/machines/svm/decls.scm @@ -216,23 +216,24 @@ USA. (lambda (node) (let ((time (source-node/modification-time node))) (if (and time - (there-exists? (source-node/dependencies node) - (lambda (node*) - (let ((newer? - (let ((time* - (source-node/modification-time node*))) - (or (not time*) - (> time* time))))) - (if newer? - (write-notification-line - (lambda (port) - (write-string "Binary file " port) - (write (source-node/filename node) port) - (write-string " newer than dependency " - port) - (write (source-node/filename node*) - port)))) - newer?)))) + (any (lambda (node*) + (let ((newer? + (let ((time* + (source-node/modification-time + node*))) + (or (not time*) + (> time* time))))) + (if newer? + (write-notification-line + (lambda (port) + (write-string "Binary file " port) + (write (source-node/filename node) port) + (write-string " newer than dependency " + port) + (write (source-node/filename node*) + port)))) + newer?)) + (source-node/dependencies node))) (set-source-node/modification-time! node #f)))) source-nodes) (for-each @@ -267,10 +268,10 @@ USA. (if (not (source-node/modification-time node)) (source-node/syntax! node))) source-nodes/by-rank))) - (if (there-exists? source-nodes/by-rank - (lambda (node) - (and (not (source-node/modification-time node)) - (source-node/circular? node)))) + (if (any (lambda (node) + (and (not (source-node/modification-time node)) + (source-node/circular? node))) + source-nodes/by-rank) (begin (write-notification-line (lambda (port) diff --git a/src/compiler/machines/svm/lapgen.scm b/src/compiler/machines/svm/lapgen.scm index 778e7fd88..41d7da095 100644 --- a/src/compiler/machines/svm/lapgen.scm +++ b/src/compiler/machines/svm/lapgen.scm @@ -123,8 +123,8 @@ USA. (- (abs max-frame) min-frame 1) (- max-frame min-frame))) (rest? (negative? max-frame))) - (guarantee-exact-nonnegative-integer n-required) - (guarantee-exact-nonnegative-integer n-optional) + (guarantee exact-nonnegative-integer? n-required) + (guarantee exact-nonnegative-integer? n-optional) (if (not (and (< n-required #x80) (< n-optional #x80))) (error "Can't encode procedure arity:" n-required n-optional)) (fix:or n-required @@ -138,7 +138,7 @@ USA. 0))) (if offset (begin - (guarantee-exact-nonnegative-integer offset) + (guarantee exact-nonnegative-integer? offset) (if (not (< offset #x7FF8)) (error "Can't encode continuation offset:" offset)) (+ offset #x8000)) diff --git a/src/compiler/machines/svm/machine.scm b/src/compiler/machines/svm/machine.scm index fe587c32d..6078ccdc1 100644 --- a/src/compiler/machines/svm/machine.scm +++ b/src/compiler/machines/svm/machine.scm @@ -225,7 +225,7 @@ USA. (ea:pre-decrement rref:stack-pointer 'WORD)) (define (ea:stack-ref index) - (guarantee-non-negative-fixnum index 'ea:stack-ref) + (guarantee non-negative-fixnum? index 'ea:stack-ref) (if (zero? index) (ea:indirect rref:stack-pointer) (ea:offset rref:stack-pointer index 'WORD))) diff --git a/src/compiler/machines/svm/rules.scm b/src/compiler/machines/svm/rules.scm index 16481d3c8..639ab9b79 100644 --- a/src/compiler/machines/svm/rules.scm +++ b/src/compiler/machines/svm/rules.scm @@ -1655,7 +1655,7 @@ USA. ;; known! (define (rtl:simple-subexpressions? expr) - (for-all? (cdr expr) - (lambda (sub) - (or (rtl:machine-constant? sub) - (rtl:register? sub))))) \ No newline at end of file + (every (lambda (sub) + (or (rtl:machine-constant? sub) + (rtl:register? sub))) + (cdr expr))) \ No newline at end of file diff --git a/src/compiler/machines/x86-64/decls.scm b/src/compiler/machines/x86-64/decls.scm index 6924a256b..ab7797b97 100644 --- a/src/compiler/machines/x86-64/decls.scm +++ b/src/compiler/machines/x86-64/decls.scm @@ -208,23 +208,24 @@ USA. (lambda (node) (let ((time (source-node/modification-time node))) (if (and time - (there-exists? (source-node/dependencies node) - (lambda (node*) - (let ((newer? - (let ((time* - (source-node/modification-time node*))) - (or (not time*) - (> time* time))))) - (if newer? - (write-notification-line - (lambda (port) - (write-string "Binary file " port) - (write (source-node/filename node) port) - (write-string " newer than dependency " - port) - (write (source-node/filename node*) - port)))) - newer?)))) + (any (lambda (node*) + (let ((newer? + (let ((time* + (source-node/modification-time + node*))) + (or (not time*) + (> time* time))))) + (if newer? + (write-notification-line + (lambda (port) + (write-string "Binary file " port) + (write (source-node/filename node) port) + (write-string " newer than dependency " + port) + (write (source-node/filename node*) + port)))) + newer?)) + (source-node/dependencies node))) (set-source-node/modification-time! node #f)))) source-nodes) (for-each @@ -259,10 +260,10 @@ USA. (if (not (source-node/modification-time node)) (source-node/syntax! node))) source-nodes/by-rank))) - (if (there-exists? source-nodes/by-rank - (lambda (node) - (and (not (source-node/modification-time node)) - (source-node/circular? node)))) + (if (any (lambda (node) + (and (not (source-node/modification-time node)) + (source-node/circular? node))) + source-nodes/by-rank) (begin (write-notification-line (lambda (port) diff --git a/src/compiler/machines/x86-64/rulrew.scm b/src/compiler/machines/x86-64/rulrew.scm index 59c2d3389..a052dff70 100644 --- a/src/compiler/machines/x86-64/rulrew.scm +++ b/src/compiler/machines/x86-64/rulrew.scm @@ -281,9 +281,7 @@ USA. ;; known! (define (rtl:simple-subexpressions? expr) - (for-all? (cdr expr) - (lambda (sub) - (or (rtl:machine-constant? sub) - (rtl:register? sub))))) - - + (every (lambda (sub) + (or (rtl:machine-constant? sub) + (rtl:register? sub))) + (cdr expr))) \ No newline at end of file diff --git a/src/compiler/rtlbase/rtlexp.scm b/src/compiler/rtlbase/rtlexp.scm index 9a10f3f2f..81e4e9c2c 100644 --- a/src/compiler/rtlbase/rtlexp.scm +++ b/src/compiler/rtlbase/rtlexp.scm @@ -133,10 +133,10 @@ USA. (define (rtl:any-subexpression? expression predicate) (and (not (rtl:constant? expression)) - (there-exists? (cdr expression) - (lambda (x) - (and (pair? x) - (predicate x)))))) + (any (lambda (x) + (and (pair? x) + (predicate x))) + (cdr expression)))) (define (rtl:expression-contains? expression predicate) (let loop ((expression expression)) @@ -145,10 +145,10 @@ USA. (define (rtl:all-subexpressions? expression predicate) (or (rtl:constant? expression) - (for-all? (cdr expression) - (lambda (x) - (or (not (pair? x)) - (predicate x)))))) + (every (lambda (x) + (or (not (pair? x)) + (predicate x))) + (cdr expression)))) (define (rtl:reduce-subparts expression operator initial if-expression if-not) (let ((remap @@ -199,7 +199,7 @@ USA. ((rtl:register? expression) (= (rtl:register-number expression) register)) ((rtl:contains-no-substitutable-registers? expression) false) - (else (there-exists? (cdr expression) loop))))) + (else (any loop (cdr expression)))))) (define (rtl:subst-register rtl register substitute) (letrec @@ -307,8 +307,8 @@ USA. y (loop (cdr x) (let ((x (car x))) - (if (there-exists? y - (lambda (y) - (rtl:expression=? x y))) + (if (any (lambda (y) + (rtl:expression=? x y)) + y) y (cons x y)))))))) \ No newline at end of file diff --git a/src/compiler/rtlgen/rtlgen.scm b/src/compiler/rtlgen/rtlgen.scm index 2929e438b..11171dd25 100644 --- a/src/compiler/rtlgen/rtlgen.scm +++ b/src/compiler/rtlgen/rtlgen.scm @@ -128,16 +128,16 @@ USA. ;; provided that all of the procedure calls made by them are ;; reductions. (let loop ((block (procedure-block procedure))) - (for-all? (block-children block) - (lambda (block) - (let ((procedure (block-procedure block))) - (and (procedure? procedure) - (if (procedure-continuation? procedure) - (continuation/always-known-operator? procedure) - ;; Inline-coded child procedures are treated - ;; as an extension of this procedure. - (or (not (procedure-inline-code? procedure)) - (loop block)))))))))))) + (every (lambda (block) + (let ((procedure (block-procedure block))) + (and (procedure? procedure) + (if (procedure-continuation? procedure) + (continuation/always-known-operator? procedure) + ;; Inline-coded child procedures are treated + ;; as an extension of this procedure. + (or (not (procedure-inline-code? procedure)) + (loop block)))))) + (block-children block))))))) (define (generate/procedure-entry/inline procedure) (generate/procedure-header procedure @@ -185,11 +185,11 @@ USA. (define (continuation/avoid-check? continuation) (and (null? (continuation/returns continuation)) - (for-all? - (continuation/combinations continuation) + (every (lambda (combination) (let ((op (rvalue-known-value (combination/operator combination)))) - (and op (operator/needs-no-heap-check? op))))))) + (and op (operator/needs-no-heap-check? op)))) + (continuation/combinations continuation)))) (define (operator/needs-no-heap-check? op) (and (rvalue/constant? op) diff --git a/src/compiler/rtlopt/rdflow.scm b/src/compiler/rtlopt/rdflow.scm index a56d26224..b0742afaf 100644 --- a/src/compiler/rtlopt/rdflow.scm +++ b/src/compiler/rtlopt/rdflow.scm @@ -135,9 +135,9 @@ USA. (define (add-rnode/initial-value! target expression) (let ((values (rnode/initial-values target))) - (if (not (there-exists? values - (lambda (value) - (rtl:expression=? expression value)))) + (if (not (any (lambda (value) + (rtl:expression=? expression value)) + values)) (set-rnode/initial-values! target (cons expression values))))) @@ -174,9 +174,9 @@ USA. (values-substitution-step rnodes (rnode/classified-values rnode)))) - (if (there-exists? values - (lambda (value) - (eq? (car value) 'SUBSTITUTABLE-REGISTERS))) + (if (any (lambda (value) + (eq? (car value) 'SUBSTITUTABLE-REGISTERS)) + values) (set-rnode/classified-values! rnode values) (let ((expression (values-unique-expression values))) (if expression (set! new-constant? true)) @@ -203,9 +203,9 @@ USA. (define (initial-known-value values) (and (not (null? values)) - (not (there-exists? values - (lambda (value) - (rtl:volatile-expression? (cdr value))))) + (not (any (lambda (value) + (rtl:volatile-expression? (cdr value))) + values)) (let loop ((value (car values)) (rest (cdr values))) (cond ((eq? (car value) 'SUBSTITUTABLE-REGISTERS) 'UNDETERMINED) ((null? rest) (values-unique-expression values)) @@ -214,10 +214,10 @@ USA. (define (values-unique-expression values) (let ((class (caar values)) (expression (cdar values))) - (and (for-all? (cdr values) - (lambda (value) - (and (eq? class (car value)) - (rtl:expression=? expression (cdr value))))) + (and (every (lambda (value) + (and (eq? class (car value)) + (rtl:expression=? expression (cdr value)))) + (cdr values)) expression))) (define (values-substitution-step rnodes values) diff --git a/src/compiler/rtlopt/rtlcsm.scm b/src/compiler/rtlopt/rtlcsm.scm index a3700ed65..23377788a 100644 --- a/src/compiler/rtlopt/rtlcsm.scm +++ b/src/compiler/rtlopt/rtlcsm.scm @@ -225,7 +225,7 @@ USA. (if adjustment (cons adjustment adjustments) adjustments))) - (if (for-all? e (lambda (b) (eqv? (car b) (cdr b)))) + (if (every (lambda (b) (eqv? (car b) (cdr b))) e) (loop (cdr rx) (cdr ry) (car rx) (car ry) e adjustments) diff --git a/src/cref/conpkg.scm b/src/cref/conpkg.scm index 1732a056a..41b330a64 100644 --- a/src/cref/conpkg.scm +++ b/src/cref/conpkg.scm @@ -56,16 +56,16 @@ USA. (define (new-extension-packages pmodel) (list-transform-positive (pmodel/extra-packages pmodel) (lambda (package) - (or (there-exists? (package/links package) link/new?) - (there-exists? (package/bindings package) new-internal-binding?))))) + (or (any link/new? (package/links package)) + (any new-internal-binding? (package/bindings package)))))) (define (new-internal-binding? binding) (and (binding/new? binding) (binding/internal? binding) - (not (there-exists? (binding/links binding) - (let ((package (binding/package binding))) - (lambda (link) - (eq? (link/owner link) package))))))) + (not (any (let ((package (binding/package binding))) + (lambda (link) + (eq? (link/owner link) package))) + (binding/links binding))))) (define (package/ancestry package) (let loop ((parent (package/parent package)) diff --git a/src/cref/redpkg.scm b/src/cref/redpkg.scm index 1de973a21..5cf93f644 100644 --- a/src/cref/redpkg.scm +++ b/src/cref/redpkg.scm @@ -279,18 +279,17 @@ USA. (cddr expression)))) ((GLOBAL-DEFINITIONS) (let ((filenames (cdr expression))) - (if (not (for-all? filenames - (lambda (f) (or (string? f) (symbol? f))))) + (if (not (every (lambda (f) (or (string? f) (symbol? f))) filenames)) (lose)) (cons 'GLOBAL-DEFINITIONS filenames))) ((OS-TYPE-CASE) (if (not (and (list? (cdr expression)) - (for-all? (cdr expression) - (lambda (clause) - (and (or (eq? 'ELSE (car clause)) - (and (list? (car clause)) - (for-all? (car clause) symbol?))) - (list? (cdr clause))))))) + (every (lambda (clause) + (and (or (eq? 'ELSE (car clause)) + (and (list? (car clause)) + (every symbol? (car clause)))) + (list? (cdr clause)))) + (cdr expression)))) (lose)) (cons 'NESTED-DESCRIPTIONS (let loop ((clauses (cdr expression))) @@ -306,7 +305,7 @@ USA. ((INCLUDE) (cons 'NESTED-DESCRIPTIONS (let ((filenames (cdr expression))) - (if (not (for-all? filenames string?)) + (if (not (every string? filenames)) (lose)) (append-map (lambda (filename) (read-and-parse-model @@ -473,7 +472,7 @@ USA. (define (check-list items predicate) (and (list? items) - (for-all? items predicate))) + (every predicate items))) ;;;; Packages diff --git a/src/edwin/abbrev.scm b/src/edwin/abbrev.scm index e56690dd4..38b26d3ab 100644 --- a/src/edwin/abbrev.scm +++ b/src/edwin/abbrev.scm @@ -52,8 +52,8 @@ USA. (guarantee-abbrev-table table 'DEFINE-ABBREV) (guarantee-string abbrev 'DEFINE-ABBREV) (guarantee-string expansion 'DEFINE-ABBREV) - (if hook (guarantee-symbol hook 'DEFINE-ABBREV)) - (guarantee-exact-nonnegative-integer count 'DEFINE-ABBREV) + (if hook (guarantee symbol? hook 'DEFINE-ABBREV)) + (guarantee exact-nonnegative-integer? count 'DEFINE-ABBREV) (set! abbrevs-changed? #t) (hash-table/put! table (string-downcase abbrev) diff --git a/src/edwin/basic.scm b/src/edwin/basic.scm index 2dcc88ab0..50b14d24a 100644 --- a/src/edwin/basic.scm +++ b/src/edwin/basic.scm @@ -348,15 +348,15 @@ With argument, saves visited file first." (define (save-buffers-and-exit no-confirmation? noun exit) (save-some-buffers no-confirmation? #t) - (if (and (or (not (there-exists? (buffer-list) - (lambda (buffer) - (and (buffer-modified? buffer) - (buffer-pathname buffer))))) + (if (and (or (not (any (lambda (buffer) + (and (buffer-modified? buffer) + (buffer-pathname buffer))) + (buffer-list))) (prompt-for-yes-or-no? "Modified buffers exist; exit anyway")) - (if (there-exists? (process-list) - (lambda (process) - (and (not (process-kill-without-query process)) - (process-runnable? process)))) + (if (any (lambda (process) + (and (not (process-kill-without-query process)) + (process-runnable? process))) + (process-list)) (and (prompt-for-yes-or-no? "Active processes exist; kill them and exit anyway") (begin diff --git a/src/edwin/bufcom.scm b/src/edwin/bufcom.scm index 48b38eb8a..9d105591a 100644 --- a/src/edwin/bufcom.scm +++ b/src/edwin/bufcom.scm @@ -121,9 +121,9 @@ Reads the new name in the echo area." (define (kill-buffer-interactive buffer) (if (not (other-buffer buffer)) (editor-error "Only one buffer")) (save-buffer-changes buffer) - (if (for-all? (ref-variable kill-buffer-query-procedures buffer) - (lambda (procedure) - (procedure buffer))) + (if (every (lambda (procedure) + (procedure buffer)) + (ref-variable kill-buffer-query-procedures buffer)) (kill-buffer buffer) (message "Buffer not killed."))) @@ -148,7 +148,7 @@ Reads the new name in the echo area." Each procedure is called with one argument, the buffer being killed. If any procedure returns #f, the buffer is not killed." (list kill-buffer-query-modified kill-buffer-query-process) - (lambda (object) (and (list? object) (for-all? object procedure?)))) + (lambda (object) (and (list? object) (every procedure? object)))) (define-command kill-some-buffers "For each buffer, ask whether to kill it." diff --git a/src/edwin/buffer.scm b/src/edwin/buffer.scm index 537b226c7..14ac16a06 100644 --- a/src/edwin/buffer.scm +++ b/src/edwin/buffer.scm @@ -214,7 +214,7 @@ The buffer is guaranteed to be deselected at that time." (set-buffer-windows! buffer (delq! window (buffer-windows buffer)))) (define (buffer-visible? buffer) - (there-exists? (buffer-windows buffer) window-visible?)) + (any window-visible? (buffer-windows buffer))) (define (buffer-x-size buffer) (let ((windows (buffer-windows buffer))) diff --git a/src/edwin/comint.scm b/src/edwin/comint.scm index e679c3b63..a90087813 100644 --- a/src/edwin/comint.scm +++ b/src/edwin/comint.scm @@ -478,10 +478,10 @@ This is a good thing to set in mode hooks." (list comint-dynamic-complete-filename) (lambda (object) (and (list? object) - (for-all? object - (lambda (object) - (and (procedure? object) - (procedure-arity-valid? object 0))))))) + (every (lambda (object) + (and (procedure? object) + (procedure-arity-valid? object 0))) + object)))) (define-command comint-dynamic-complete "Dynamically perform completion at point. diff --git a/src/edwin/comtab.scm b/src/edwin/comtab.scm index 620d5d301..66b1fd962 100644 --- a/src/edwin/comtab.scm +++ b/src/edwin/comtab.scm @@ -131,7 +131,7 @@ USA. (define (list-of-comtabs? object) (and (not (null? object)) (list? object) - (for-all? object comtab?))) + (every comtab? object))) (define (comtab-key? object) (or (key? object) diff --git a/src/edwin/curren.scm b/src/edwin/curren.scm index 601ae68a9..37d6302a6 100644 --- a/src/edwin/curren.scm +++ b/src/edwin/curren.scm @@ -611,9 +611,9 @@ The buffer is guaranteed to be selected at that time." (and (weak-pair? buffers) (or (not (let ((buffer (weak-car buffers))) (and buffer - (there-exists? (buffer-windows buffer) - (lambda (window) - (eq? (window-screen window) screen)))))) + (any (lambda (window) + (eq? (window-screen window) screen)) + (buffer-windows buffer))))) (loop (weak-cdr buffers)))))) (define setting-up-buffer-layout? #f) diff --git a/src/edwin/dabbrev.scm b/src/edwin/dabbrev.scm index 577df5c6c..f3391a938 100644 --- a/src/edwin/dabbrev.scm +++ b/src/edwin/dabbrev.scm @@ -238,11 +238,11 @@ with the next possible expansion not yet tried." (test (if do-case (string-downcase result) result))) - (if (there-exists? (ref-variable last-dabbrev-table) - (lambda (example) - (string=? test - (if do-case - (string-downcase example) - example)))) + (if (any (lambda (example) + (string=? test + (if do-case + (string-downcase example) + example))) + (ref-variable last-dabbrev-table)) (loop (if reverse? start end)) (values end result)))))))) \ No newline at end of file diff --git a/src/edwin/dosfile.scm b/src/edwin/dosfile.scm index ac2236088..8040584fe 100644 --- a/src/edwin/dosfile.scm +++ b/src/edwin/dosfile.scm @@ -66,10 +66,10 @@ Includes the new backup. Must be > 0." (list-copy dos/backup-suffixes)) (lambda (extensions) (and (list? extensions) - (for-all? extensions - (lambda (extension) - (and (string? extension) - (not (string-null? extension)))))))) + (every (lambda (extension) + (and (string? extension) + (not (string-null? extension)))) + extensions)))) ;;;; Filename I/O @@ -287,9 +287,9 @@ Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'." "$TMP\\edwin.bak") (define (os/backup-filename? filename) - (or (there-exists? dos/backup-suffixes - (lambda (suffix) - (string-suffix? suffix filename))) + (or (any (lambda (suffix) + (string-suffix? suffix filename)) + dos/backup-suffixes) (let ((type (pathname-type filename))) (and (string? type) (or (string-ci=? "bak" type) @@ -422,9 +422,9 @@ Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'." (or (os/backup-filename? filename) (os/auto-save-filename? filename) (and (not (file-directory? filename)) - (there-exists? (ref-variable completion-ignored-extensions) - (lambda (extension) - (string-suffix? extension filename)))))) + (any (lambda (extension) + (string-suffix? extension filename)) + (ref-variable completion-ignored-extensions))))) (define (os/init-file-name) "~/edwin.ini") (define (os/abbrev-file-name) "~/abbrevs.scm") diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index 528cf2ed3..9ede2924a 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -147,7 +147,6 @@ USA. (import (runtime character-set) (char-set-table %char-set-table)) (export (edwin) - (guarantee-vector-8b guarantee-string) (set-vector-8b-length! set-string-length!) (vector-8b-length string-length) (vector-8b-maximum-length string-maximum-length) diff --git a/src/edwin/evlcom.scm b/src/edwin/evlcom.scm index a33337744..193aed4c0 100644 --- a/src/edwin/evlcom.scm +++ b/src/edwin/evlcom.scm @@ -284,7 +284,7 @@ Has no effect if evaluate-in-inferior-repl is false." (if (default-object? environment) (evaluation-environment) (begin - (guarantee-environment environment 'PROMPT-FOR-EXPRESSION-VALUE) + (guarantee environment? environment 'PROMPT-FOR-EXPRESSION-VALUE) environment)))) (eval-with-history (apply prompt-for-expression prompt @@ -302,7 +302,7 @@ Has no effect if evaluate-in-inferior-repl is false." (if (default-object? environment) (evaluation-environment) (begin - (guarantee-environment environment 'PROMPT-FOR-EXPRESSION) + (guarantee environment? environment 'PROMPT-FOR-EXPRESSION) environment)))) (read-from-string (apply prompt-for-string diff --git a/src/edwin/fileio.scm b/src/edwin/fileio.scm index 3a4442f08..2503fdc5c 100644 --- a/src/edwin/fileio.scm +++ b/src/edwin/fileio.scm @@ -85,11 +85,11 @@ filename suffix \".bf\"." (define (r/w-file-methods? objects) (and (list? objects) - (for-all? objects - (lambda (object) - (and (pair? object) - (procedure? (car object)) - (procedure? (cdr object))))))) + (every (lambda (object) + (and (pair? object) + (procedure? (car object)) + (procedure? (cdr object)))) + objects))) (define-variable read-file-methods "List of alternate methods to be used for reading a file into a buffer. @@ -303,10 +303,10 @@ of the predicates is satisfied, the file is written in the usual way." (define (string->mode-alist? object) (and (alist? object) - (for-all? object - (lambda (association) - (and (string? (car association)) - (->mode? (cdr association))))))) + (every (lambda (association) + (and (string? (car association)) + (->mode? (cdr association)))) + object))) (define (->mode? object) (or (mode? object) diff --git a/src/edwin/info.scm b/src/edwin/info.scm index 5aac3fb87..0b7c04fe2 100644 --- a/src/edwin/info.scm +++ b/src/edwin/info.scm @@ -929,9 +929,9 @@ The name may be an abbreviation of the reference name." (let ((info-dir (edwin-info-directory))) (if (and info-dir (file-directory? info-dir) - (not (there-exists? directories - (lambda (dir) - (pathname=? info-dir dir))))) + (not (any (lambda (dir) + (pathname=? info-dir dir)) + directories))) (append directories (list info-dir)) directories)))))) (set-variable-local-value! buffer variable directories) diff --git a/src/edwin/input.scm b/src/edwin/input.scm index dc1d7b5e3..70f8e6a64 100644 --- a/src/edwin/input.scm +++ b/src/edwin/input.scm @@ -199,7 +199,7 @@ B 3BAB8C (define (keyboard-peek-no-hang #!optional timeout) (let ((milliseconds (if (default-object? timeout) 0 timeout))) - (guarantee-fixnum milliseconds 'keyboard-peek-no-hang) + (guarantee fixnum? milliseconds 'keyboard-peek-no-hang) (handle-simple-events-until (+ (real-time-clock) milliseconds) (editor-peek-no-hang current-editor) diff --git a/src/edwin/intmod.scm b/src/edwin/intmod.scm index 55e0b49aa..5d151ac9c 100644 --- a/src/edwin/intmod.scm +++ b/src/edwin/intmod.scm @@ -920,9 +920,9 @@ If this is an error, the debugger examines the error condition." (transcript-write value #f)))))) (define (mark-visible? mark) - (there-exists? (buffer-windows (mark-buffer mark)) - (lambda (window) - (window-mark-visible? window mark)))) + (any (lambda (window) + (window-mark-visible? window mark)) + (buffer-windows (mark-buffer mark)))) (define (enqueue-output-string! port string) (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) @@ -937,7 +937,7 @@ If this is an error, the debugger examines the error condition." ;;; We assume here that none of the OPERATORs passed to this procedure ;;; generate any output in the REPL buffer, and consequently we don't ;;; need to update bytes-written here. Review of the current usage of -;;; this procedure confirms the assumption. +;;; this procedure confirms the assumption. (define (enqueue-output-operation! port operator) (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) diff --git a/src/edwin/keymap.scm b/src/edwin/keymap.scm index f14d6e158..fff6d7993 100644 --- a/src/edwin/keymap.scm +++ b/src/edwin/keymap.scm @@ -142,9 +142,9 @@ Previous contents of that buffer are killed first." (if (and (pair? (cdr comtabs)) (comtab? (cadr comtabs)) (or global? - (not (there-exists? global-modes - (lambda (mode) - (eq? (cdr comtabs) (mode-comtabs mode))))))) + (not (any (lambda (mode) + (eq? (cdr comtabs) (mode-comtabs mode))) + global-modes)))) (loop (cdr comtabs)) '())))) diff --git a/src/edwin/linden.scm b/src/edwin/linden.scm index cbc16290a..e49f052b3 100644 --- a/src/edwin/linden.scm +++ b/src/edwin/linden.scm @@ -55,7 +55,7 @@ is used to calculate the indentation for that form." (and (pair? object) (symbol? (car object)) (alist? (cdr object)) - (for-all? (cdr object) (lambda (entry) (string? (car entry))))))) + (every (lambda (entry) (string? (car entry))) (cdr object))))) (define-variable lisp-body-indent "Number of extra columns to indent the body of a special form." diff --git a/src/edwin/nntp.scm b/src/edwin/nntp.scm index 689723e26..7c12770dc 100644 --- a/src/edwin/nntp.scm +++ b/src/edwin/nntp.scm @@ -1376,7 +1376,7 @@ USA. ;; is reasonable since I've already seen bad references during the ;; first few days of testing. (let ((tokens (parse-references-list (news-header:references header)))) - (if (for-all? tokens valid-message-id?) + (if (every valid-message-id? tokens) tokens '())) '())) @@ -1487,11 +1487,11 @@ USA. (let ((relatives (step header))) (list-transform-positive relatives (lambda (child) - (there-exists? relatives - (lambda (child*) - (and (not (eq? child* child)) - (memq child - (compute-header-relatives step table child*))))))))) + (any (lambda (child*) + (and (not (eq? child* child)) + (memq child + (compute-header-relatives step table child*)))) + relatives))))) (define (compute-header-relatives step table header) (let loop ((header header)) diff --git a/src/edwin/print.scm b/src/edwin/print.scm index 7cee3ec83..c419c619a 100644 --- a/src/edwin/print.scm +++ b/src/edwin/print.scm @@ -133,9 +133,9 @@ Variable LPR-SWITCHES is a list of extra switches (strings) to pass to lpr." (list (string-append "-J \"" job-name "\"")) '())) (if (and title - (not (there-exists? switches - (lambda (switch) - (string-prefix? "-T" switch))))) + (not (any (lambda (switch) + (string-prefix? "-T" switch)) + switches))) (list (string-append "-T \"" title "\"")) '()) switches)))) diff --git a/src/edwin/process.scm b/src/edwin/process.scm index 69bb43765..4f858d5a6 100644 --- a/src/edwin/process.scm +++ b/src/edwin/process.scm @@ -45,10 +45,10 @@ Each element is a string (directory name) or #F (try default directory)." '() (lambda (exec-path) (and (list? exec-path) - (for-all? exec-path - (lambda (element) - (or (not element) - (pathname? element))))))) + (every (lambda (element) + (or (not element) + (pathname? element))) + exec-path)))) (define-variable process-connection-type "Control type of device used to communicate with subprocesses. diff --git a/src/edwin/prompt.scm b/src/edwin/prompt.scm index 384cb3ddc..0fe52a720 100644 --- a/src/edwin/prompt.scm +++ b/src/edwin/prompt.scm @@ -353,7 +353,7 @@ USA. (options/seen option-structure))) (if (not (let ((predicate (cadr entry))) (if (pair? predicate) - (there-exists? predicate (lambda (p) (p arg))) + (any (lambda (p) (p arg)) predicate) (predicate arg)))) (error "Not a valid option argument:" arg)) ((cddr entry) option-structure arg) diff --git a/src/edwin/rfc822.scm b/src/edwin/rfc822.scm index ebd28d30a..c59194bdf 100644 --- a/src/edwin/rfc822.scm +++ b/src/edwin/rfc822.scm @@ -79,8 +79,8 @@ USA. (rfc822:strip-quoted-names (rfc822:string->non-ignored-tokens string)))) (if (and address-list - (for-all? (cdr address-list) - (lambda (token) (eqv? token #\,)))) + (every (lambda (token) (eqv? token #\,)) + (cdr address-list))) (car address-list) (rfc822:split-address-tokens (rfc822:string->tokens string))))) diff --git a/src/edwin/rmail.scm b/src/edwin/rmail.scm index 7fed612a9..7b2080a0d 100644 --- a/src/edwin/rmail.scm +++ b/src/edwin/rmail.scm @@ -582,21 +582,21 @@ This variable is ignored if rmail-pop-procedure is #F." '() (lambda (object) (and (list? object) - (for-all? object - (lambda (object) - (and (list? object) - (= 3 (length object)) - (string? (car object)) - (string? (cadr object)) - (let ((password (caddr object))) - (or (string? password) - (symbol? password) - (and (pair? password) - (eq? 'FILE (car password)) - (pair? (cdr password)) - (or (string? (cadr password)) - (pathname? (cadr password))) - (null? (cddr password))))))))))) + (every (lambda (object) + (and (list? object) + (= 3 (length object)) + (string? (car object)) + (string? (cadr object)) + (let ((password (caddr object))) + (or (string? password) + (symbol? password) + (and (pair? password) + (eq? 'FILE (car password)) + (pair? (cdr password)) + (or (string? (cadr password)) + (pathname? (cadr password))) + (null? (cddr password))))))) + object)))) (define (get-mail-from-pop-server server insert buffer) (let ((procedure (ref-variable rmail-pop-procedure buffer))) diff --git a/src/edwin/sendmail.scm b/src/edwin/sendmail.scm index e97af0f95..12175cb10 100644 --- a/src/edwin/sendmail.scm +++ b/src/edwin/sendmail.scm @@ -1005,7 +1005,7 @@ the user from the mailer." message-pathname trace-buffer lookup-context))) - (cond ((not (for-all? responses smtp-response-valid?)) + (cond ((not (every smtp-response-valid? responses)) (pop-up-temporary-buffer "*SMTP-invalid*" '(READ-ONLY FLUSH-ON-SPACE) (lambda (buffer window) @@ -1055,8 +1055,8 @@ the user from the mailer." (define (smtp-responses-ok? responses lookup-context) (if (ref-variable smtp-require-valid-recipients lookup-context) - (for-all? responses smtp-response-valid?) - (there-exists? responses smtp-response-valid?))) + (every smtp-response-valid? responses) + (any smtp-response-valid? responses))) (define (call-with-smtp-socket host-name service trace-buffer receiver) (let ((port #f)) @@ -1163,7 +1163,7 @@ the user from the mailer." (smtp-drain-output port) (let ((response (smtp-read-line port))) (let ((n (smtp-response-number response))) - (if (not (there-exists? numbers (lambda (n*) (= n n*)))) + (if (not (any (lambda (n*) (= n n*)) numbers)) (editor-error response)) (if (smtp-response-continued? response) (let loop ((responses (list response))) @@ -1845,9 +1845,9 @@ This is a list, each element of which is a list of three items: (and (list? x) (= (length x) 3) (or (not (car x)) (string? (car x))) - (there-exists? mime-top-level-types - (lambda (e) - (eq? (cdr e) (cadr x)))) + (any (lambda (e) + (eq? (cdr e) (cadr x))) + mime-top-level-types) (symbol? (caddr x))))))) (define mime-top-level-types diff --git a/src/edwin/simple.scm b/src/edwin/simple.scm index 95d9fca02..a51e1c3b8 100644 --- a/src/edwin/simple.scm +++ b/src/edwin/simple.scm @@ -226,7 +226,7 @@ USA. (else (extract-string start end)))))))) (define (sit-for interval) - (guarantee-fixnum interval 'sit-for) + (guarantee fixnum? interval 'sit-for) (update-screens! 'ignore-input) (keyboard-peek-no-hang interval)) diff --git a/src/edwin/snr.scm b/src/edwin/snr.scm index 55abe403f..f36641b14 100644 --- a/src/edwin/snr.scm +++ b/src/edwin/snr.scm @@ -3276,7 +3276,7 @@ C-c C-q mail-fill-yanked-message (fill what was yanked)." (>= (length entry) 2) (string? (car entry)) (boolean? (cadr entry)) - (for-all? (cddr entry) range?))) + (every range? (cddr entry)))) (define ((convert-groups-init-file-entry-type-1 connection) entry) (make-news-group-1 connection (car entry) (cadr entry) #f (cddr entry) @@ -3288,7 +3288,7 @@ C-c C-q mail-fill-yanked-message (fill what was yanked)." (string? (car entry)) (boolean? (cadr entry)) (valid-group-server-info? (caddr entry)) - (for-all? (cdddr entry) range?))) + (every range? (cdddr entry)))) (define ((convert-groups-init-file-entry-type-2 connection) entry) (make-news-group-1 connection @@ -3305,8 +3305,8 @@ C-c C-q mail-fill-yanked-message (fill what was yanked)." (string? (vector-ref entry 0)) (boolean? (vector-ref entry 1)) (valid-group-server-info? (vector-ref entry 2)) - (for-all? (vector-ref entry 3) range?) - (for-all? (vector-ref entry 4) range?))) + (every range? (vector-ref entry 3)) + (every range? (vector-ref entry 4)))) (define ((convert-groups-init-file-entry-type-3 connection) entry) (make-news-group-1 connection @@ -3323,9 +3323,9 @@ C-c C-q mail-fill-yanked-message (fill what was yanked)." (string? (vector-ref entry 0)) (boolean? (vector-ref entry 1)) (valid-group-server-info? (vector-ref entry 2)) - (for-all? (vector-ref entry 3) range?) - (for-all? (vector-ref entry 4) range?) - (for-all? (vector-ref entry 5) range?))) + (every range? (vector-ref entry 3)) + (every range? (vector-ref entry 4)) + (every range? (vector-ref entry 5)))) (define ((convert-groups-init-file-entry-type-4 connection) entry) (make-news-group-1 connection @@ -3385,7 +3385,7 @@ C-c C-q mail-fill-yanked-message (fill what was yanked)." (* (ref-variable news-group-ignored-subject-retention #f) 86400)))) (and (or (news-group:ignored-subjects-modified? group) - (there-exists? entries (lambda (entry) (< (cdr entry) t)))) + (any (lambda (entry) (< (cdr entry) t)) entries)) (begin (write-init-file (ignored-subjects-file-pathname group) buffer diff --git a/src/edwin/string.scm b/src/edwin/string.scm index 133a7dcc8..fdfb24878 100644 --- a/src/edwin/string.scm +++ b/src/edwin/string.scm @@ -73,7 +73,7 @@ USA. (if (default-object? char) (string-allocate length) (begin - (guarantee-char char 'MAKE-STRING) + (guarantee char? char 'MAKE-STRING) (let ((result (string-allocate length))) (%substring-fill! result 0 length char) result)))) @@ -89,7 +89,7 @@ USA. (define (substring-fill! string start end char) (guarantee-substring string start end 'SUBSTRING-FILL) - (guarantee-char char 'SUBSTRING-FILL) + (guarantee char? char 'SUBSTRING-FILL) (%substring-fill! string start end char)) (define (%substring-fill! string start end char) @@ -736,30 +736,30 @@ USA. (define (string-replace string char1 char2) (guarantee-string string 'STRING-REPLACE) - (guarantee-char char1 'STRING-REPLACE) - (guarantee-char char2 'STRING-REPLACE) + (guarantee char? char1 'STRING-REPLACE) + (guarantee char? char2 'STRING-REPLACE) (let ((string (%string-copy string))) (%substring-replace! string 0 (string-length string) char1 char2) string)) (define (substring-replace string start end char1 char2) (guarantee-substring string start end 'SUBSTRING-REPLACE) - (guarantee-char char1 'SUBSTRING-REPLACE) - (guarantee-char char2 'SUBSTRING-REPLACE) + (guarantee char? char1 'SUBSTRING-REPLACE) + (guarantee char? char2 'SUBSTRING-REPLACE) (let ((string (%string-copy string))) (%substring-replace! string start end char1 char2) string)) (define (string-replace! string char1 char2) (guarantee-string string 'STRING-REPLACE!) - (guarantee-char char1 'STRING-REPLACE!) - (guarantee-char char2 'STRING-REPLACE!) + (guarantee char? char1 'STRING-REPLACE!) + (guarantee char? char2 'STRING-REPLACE!) (%substring-replace! string 0 (string-length string) char1 char2)) (define (substring-replace! string start end char1 char2) (guarantee-substring string start end 'SUBSTRING-REPLACE!) - (guarantee-char char1 'SUBSTRING-REPLACE!) - (guarantee-char char2 'SUBSTRING-REPLACE!) + (guarantee char? char1 'SUBSTRING-REPLACE!) + (guarantee char? char2 'SUBSTRING-REPLACE!) (%substring-replace! string start end char1 char2)) (define (%substring-replace! string start end char1 char2) @@ -1165,7 +1165,7 @@ USA. (if (default-object? char) #\space (begin - (guarantee-char char 'STRING-PAD-RIGHT) + (guarantee char? char 'STRING-PAD-RIGHT) char))))) result)))) @@ -1184,7 +1184,7 @@ USA. (if (default-object? char) #\space (begin - (guarantee-char char 'STRING-PAD-RIGHT) + (guarantee char? char 'STRING-PAD-RIGHT) char))) (%substring-move! string 0 length result i))) result)))) @@ -1193,12 +1193,12 @@ USA. (define (string-find-next-char string char) (guarantee-string string 'STRING-FIND-NEXT-CHAR) - (guarantee-char char 'STRING-FIND-NEXT-CHAR) + (guarantee char? char 'STRING-FIND-NEXT-CHAR) (%substring-find-next-char string 0 (string-length string) char)) (define (substring-find-next-char string start end char) (guarantee-substring string start end 'SUBSTRING-FIND-NEXT-CHAR) - (guarantee-char char 'SUBSTRING-FIND-NEXT-CHAR) + (guarantee char? char 'SUBSTRING-FIND-NEXT-CHAR) (%substring-find-next-char string start end char)) (define (%substring-find-next-char string start end char) @@ -1209,12 +1209,12 @@ USA. (define (string-find-next-char-ci string char) (guarantee-string string 'STRING-FIND-NEXT-CHAR-CI) - (guarantee-char char 'STRING-FIND-NEXT-CHAR-CI) + (guarantee char? char 'STRING-FIND-NEXT-CHAR-CI) (%substring-find-next-char-ci string 0 (string-length string) char)) (define (substring-find-next-char-ci string start end char) (guarantee-substring string start end 'SUBSTRING-FIND-NEXT-CHAR-CI) - (guarantee-char char 'SUBSTRING-FIND-NEXT-CHAR-CI) + (guarantee char? char 'SUBSTRING-FIND-NEXT-CHAR-CI) (%substring-find-next-char-ci string start end char)) (define (%substring-find-next-char-ci string start end char) @@ -1225,12 +1225,12 @@ USA. (define (string-find-previous-char string char) (guarantee-string string 'STRING-FIND-PREVIOUS-CHAR) - (guarantee-char char 'STRING-FIND-PREVIOUS-CHAR) + (guarantee char? char 'STRING-FIND-PREVIOUS-CHAR) (%substring-find-previous-char string 0 (string-length string) char)) (define (substring-find-previous-char string start end char) (guarantee-substring string start end 'SUBSTRING-FIND-PREVIOUS-CHAR) - (guarantee-char char 'SUBSTRING-FIND-PREVIOUS-CHAR) + (guarantee char? char 'SUBSTRING-FIND-PREVIOUS-CHAR) (%substring-find-previous-char string start end char)) (define (%substring-find-previous-char string start end char) @@ -1243,12 +1243,12 @@ USA. (define (string-find-previous-char-ci string char) (guarantee-string string 'STRING-FIND-PREVIOUS-CHAR-CI) - (guarantee-char char 'STRING-FIND-PREVIOUS-CHAR-CI) + (guarantee char? char 'STRING-FIND-PREVIOUS-CHAR-CI) (%substring-find-previous-char-ci string 0 (string-length string) char)) (define (substring-find-previous-char-ci string start end char) (guarantee-substring string start end 'SUBSTRING-FIND-PREVIOUS-CHAR-CI) - (guarantee-char char 'SUBSTRING-FIND-PREVIOUS-CHAR-CI) + (guarantee char? char 'SUBSTRING-FIND-PREVIOUS-CHAR-CI) (%substring-find-previous-char-ci string start end char)) (define (%substring-find-previous-char-ci string start end char) diff --git a/src/edwin/unix.scm b/src/edwin/unix.scm index 5d9b3fe25..b4841b8f9 100644 --- a/src/edwin/unix.scm +++ b/src/edwin/unix.scm @@ -317,9 +317,9 @@ Includes the new backup. Must be > 0." (define (os/completion-ignore-filename? filename) (and (not (file-test-no-errors file-directory? filename)) - (there-exists? (ref-variable completion-ignored-extensions) - (lambda (extension) - (string-suffix? extension filename))))) + (any (lambda (extension) + (string-suffix? extension filename)) + (ref-variable completion-ignored-extensions)))) (define (os/completion-ignored-extensions) (append (list ".bin" ".com" ".ext" ".so" @@ -336,10 +336,10 @@ Includes the new backup. Must be > 0." (os/completion-ignored-extensions) (lambda (extensions) (and (list? extensions) - (for-all? extensions - (lambda (extension) - (and (string? extension) - (not (string-null? extension)))))))) + (every (lambda (extension) + (and (string? extension) + (not (string-null? extension)))) + extensions)))) (define (os/init-file-name) "~/.edwin") (define (os/abbrev-file-name) "~/.abbrev_defs") diff --git a/src/edwin/utils.scm b/src/edwin/utils.scm index 9d4a814ea..496d9c3b9 100644 --- a/src/edwin/utils.scm +++ b/src/edwin/utils.scm @@ -63,7 +63,7 @@ USA. ;; Too much of Edwin relies on fixnum-specific arithmetic for this ;; to be safe. Unfortunately, this means that Edwin can't edit ;; files >32MB. - (guarantee-index-fixnum n-chars 'ALLOCATE-BUFFER-STORAGE) + (guarantee index-fixnum? n-chars 'ALLOCATE-BUFFER-STORAGE) (make-string n-chars)) (define-syntax chars-to-words-shift @@ -254,7 +254,7 @@ USA. (define (list-of-type? object predicate) (and (list? object) - (for-all? object predicate))) + (every predicate object))) (define (dotimes n procedure) (define (loop i) diff --git a/src/edwin/vc.scm b/src/edwin/vc.scm index 84fdc7c0c..9ba335706 100644 --- a/src/edwin/vc.scm +++ b/src/edwin/vc.scm @@ -573,11 +573,11 @@ merge in the changes into your working copy." (vc-start-entry buffer "Enter a change comment for the marked files." - (if (there-exists? files - (lambda (file) - (let ((master (file-vc-master (car file) #f))) - (and master - (eq? (vc-backend-next-action master) 'CHECKIN))))) + (if (any (lambda (file) + (let ((master (file-vc-master (car file) #f))) + (and master + (eq? (vc-backend-next-action master) 'CHECKIN)))) + files) #f "") (lambda (comment) diff --git a/src/edwin/vhdl.scm b/src/edwin/vhdl.scm index 4f01216ab..32e0d67c9 100644 --- a/src/edwin/vhdl.scm +++ b/src/edwin/vhdl.scm @@ -454,9 +454,9 @@ USA. #f) (define (in-configuration? stack) - (there-exists? stack - (lambda (entry) - (equal? 'CONFIGURATION (keyparser-stack-entry/keyword entry))))) + (any (lambda (entry) + (equal? 'CONFIGURATION (keyparser-stack-entry/keyword entry))) + stack)) (define-matched-keyword 'BLOCK-CONFIGURATION "for" (lambda (mark stack) diff --git a/src/etc/ucd-converter.scm b/src/etc/ucd-converter.scm index 009bc7a79..ca364d4f1 100644 --- a/src/etc/ucd-converter.scm +++ b/src/etc/ucd-converter.scm @@ -317,12 +317,12 @@ USA. ;;;; Code-point ranges (define (make-cpr start #!optional end) - (guarantee-index-fixnum start 'make-cpr) + (guarantee index-fixnum? start 'make-cpr) (let ((end (if (default-object? end) (fix:+ start 1) (begin - (guarantee-index-fixnum end 'make-cpr) + (guarantee index-fixnum? end 'make-cpr) (if (not (fix:< start end)) (error:bad-range-argument end 'make-cpr)) end)))) diff --git a/src/imail/imail-imap.scm b/src/imail/imail-imap.scm index ef7573792..36401f77c 100644 --- a/src/imail/imail-imap.scm +++ b/src/imail/imail-imap.scm @@ -2391,7 +2391,7 @@ USA. (define (imap:command:fetch-response connection command arguments) (let ((responses (apply imap:command connection command arguments))) (if (and (pair? (cdr responses)) - (for-all? (cdr responses) imap:response:fetch?)) + (every imap:response:fetch? (cdr responses))) (if (null? (cddr responses)) (cadr responses) ;; Some servers, notably UW IMAP, sometimes return @@ -2494,7 +2494,7 @@ USA. (define (imap:command:multiple-response predicate connection command . arguments) (let ((responses (apply imap:command connection command arguments))) - (if (for-all? (cdr responses) predicate) + (if (every predicate (cdr responses)) (cdr responses) (error "Malformed response from IMAP server:" responses)))) diff --git a/src/imail/imail-mime.scm b/src/imail/imail-mime.scm index 971677f4a..dd0008bb6 100644 --- a/src/imail/imail-mime.scm +++ b/src/imail/imail-mime.scm @@ -298,9 +298,9 @@ USA. (define mime:media-parsers '()) (define (define-mime-media-parser type subtype parser) - (guarantee-interned-symbol type 'DEFINE-MIME-MEDIA-PARSER) + (guarantee interned-symbol? type 'DEFINE-MIME-MEDIA-PARSER) (if subtype - (guarantee-interned-symbol subtype 'DEFINE-MIME-MEDIA-PARSER)) + (guarantee interned-symbol? subtype 'DEFINE-MIME-MEDIA-PARSER)) (guarantee-procedure-of-arity parser (length '(HEADER-FIELDS STRING START END TYPE SUBTYPE PARAMETERS)) diff --git a/src/imail/imail-summary.scm b/src/imail/imail-summary.scm index 47f949d59..a0f4ed40f 100644 --- a/src/imail/imail-summary.scm +++ b/src/imail/imail-summary.scm @@ -96,9 +96,9 @@ FLAGS is a string containing the desired labels, separated by commas." (string-append "Flags " flags-string) (let ((flags (burst-comma-list-string flags-string))) (lambda (m) - (there-exists? (message-flags m) - (lambda (flag) - (flags-member? flag flags)))))))) + (any (lambda (flag) + (flags-member? flag flags)) + (message-flags m))))))) (define-command imail-summary-by-recipients "Display a summary of all messages with the given RECIPIENTS. diff --git a/src/imail/imail-top.scm b/src/imail/imail-top.scm index 9f41b7633..1093eb865 100644 --- a/src/imail/imail-top.scm +++ b/src/imail/imail-top.scm @@ -655,9 +655,9 @@ With prefix argument N moves forward N messages with these flags." flags) (move-relative delta (lambda (message) - (there-exists? flags - (lambda (flag) - (message-flagged? message flag)))) + (any (lambda (flag) + (message-flagged? message flag)) + flags)) (string-append "message with flag" (if (= 1 (length flags)) "" "s") " " @@ -1044,9 +1044,9 @@ With prefix argument, prompt even when point is on an attachment." (loop (cdr alist) (cons (cons (let ((name (caar alist))) (let loop ((name* name) (n 1)) - (if (there-exists? converted - (lambda (entry) - (string=? (car entry) name*))) + (if (any (lambda (entry) + (string=? (car entry) name*)) + converted) (loop (string-append name "<" (number->string n) ">") (+ n 1)) diff --git a/src/microcode/makegen/makegen.scm b/src/microcode/makegen/makegen.scm index 7f03d8d29..c12246011 100644 --- a/src/microcode/makegen/makegen.scm +++ b/src/microcode/makegen/makegen.scm @@ -194,9 +194,9 @@ USA. (define (maybe-update-dependencies deps-filename source-files) (if (let ((mtime (file-modification-time deps-filename))) (or (not mtime) - (there-exists? source-files - (lambda (source-file) - (> (file-modification-time source-file) mtime))))) + (any (lambda (source-file) + (> (file-modification-time source-file) mtime)) + source-files))) (let ((rules (map generate-rule source-files))) (call-with-output-file deps-filename (lambda (output) diff --git a/src/runtime/boole.scm b/src/runtime/boole.scm index f2772856e..662259928 100644 --- a/src/runtime/boole.scm +++ b/src/runtime/boole.scm @@ -39,8 +39,6 @@ USA. (or (eq? object #f) (eq? object #t))) -(define-guarantee boolean "boolean") - (define (boolean=? x y) (if x y (not y))) @@ -58,26 +56,4 @@ USA. (if (car arguments) (loop (cdr arguments)) #f) - #t))) - -(define (there-exists? items predicate) - (let loop ((items* items)) - (if (pair? items*) - (if (predicate (car items*)) - #t - (loop (cdr items*))) - (begin - (if (not (null? items*)) - (error:not-list items 'THERE-EXISTS?)) - #f)))) - -(define (for-all? items predicate) - (let loop ((items* items)) - (if (pair? items*) - (if (predicate (car items*)) - (loop (cdr items*)) - #f) - (begin - (if (not (null? items*)) - (error:not-list items 'FOR-ALL?)) - #t)))) \ No newline at end of file + #t))) \ No newline at end of file diff --git a/src/runtime/condvar.scm b/src/runtime/condvar.scm index be765945f..f1bb14b32 100644 --- a/src/runtime/condvar.scm +++ b/src/runtime/condvar.scm @@ -88,7 +88,7 @@ USA. (if (default-object? timeout) 0 (begin - (guarantee-real timeout) + (guarantee real? timeout) (register-timer-event (- timeout (real-time-clock)) #f))))) (begin0 (let loop () diff --git a/src/runtime/contin.scm b/src/runtime/contin.scm index 3a64856b1..be0397b32 100644 --- a/src/runtime/contin.scm +++ b/src/runtime/contin.scm @@ -39,7 +39,7 @@ USA. (%within-continuation k #f (lambda () (receiver k))))))) (define (within-continuation k thunk) - (guarantee-continuation k 'WITHIN-CONTINUATION) + (guarantee continuation? k 'WITHIN-CONTINUATION) (%within-continuation k #f thunk)) (define (make-continuation control-point dynamic-state block-thread-events?) diff --git a/src/runtime/datime.scm b/src/runtime/datime.scm index b4d8e9c41..2c31d35ef 100644 --- a/src/runtime/datime.scm +++ b/src/runtime/datime.scm @@ -81,7 +81,7 @@ USA. 'MAKE-DECODED-TIME) (let ((zone (if (default-object? zone) #f zone))) (if zone - (guarantee-time-zone zone 'MAKE-DECODED-TIME)) + (guarantee time-zone? zone 'MAKE-DECODED-TIME)) (if zone (%make-decoded-time second minute hour day month year (compute-day-of-week day month year) @@ -106,10 +106,10 @@ USA. (define (check-decoded-time-args second minute hour day month year caller) (let ((check-range (lambda (object min max) - (guarantee-exact-nonnegative-integer object caller) + (guarantee exact-nonnegative-integer? object caller) (if (not (<= min object max)) (error:bad-range-argument object caller))))) - (guarantee-exact-nonnegative-integer year caller) + (guarantee exact-nonnegative-integer? year caller) (check-range month 1 12) (check-range day 1 (month/max-days month)) (check-range hour 0 23) @@ -349,7 +349,7 @@ USA. (write-time-zone tz port)))) (define (write-time-zone tz port) - (guarantee-time-zone tz 'WRITE-TIME-ZONE) + (guarantee time-zone? tz 'WRITE-TIME-ZONE) (let ((minutes (round (* 60 (- tz))))) (let ((qr (integer-divide (abs minutes) 60))) (write-char (if (< minutes 0) #\- #\+) port) @@ -481,7 +481,7 @@ USA. (define (parser:ctime zone) (if zone - (guarantee-time-zone zone 'PARSER:CTIME)) + (guarantee time-zone? zone 'PARSER:CTIME)) (*parser (encapsulate (lambda (v) (make-decoded-time (vector-ref v 5) diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm index 6b0870d28..73f590e28 100644 --- a/src/runtime/defstr.scm +++ b/src/runtime/defstr.scm @@ -264,12 +264,12 @@ differences: (and (syntactic-closure? object) (loop (syntactic-closure/form object))))) (and (identifier? object) - (there-exists? false-expression-names - (lambda (name) - (identifier=? (parser-context/use-environment context) - object - (parser-context/closing-environment context) - name)))))) + (any (lambda (name) + (identifier=? (parser-context/use-environment context) + object + (parser-context/closing-environment context) + name)) + false-expression-names)))) (define (false-marker? object) (or (not object) diff --git a/src/runtime/dosprm.scm b/src/runtime/dosprm.scm index d172e1986..4c23b0d80 100644 --- a/src/runtime/dosprm.scm +++ b/src/runtime/dosprm.scm @@ -382,7 +382,7 @@ USA. (loop (+ index 1)) filename)))) - (guarantee-init-file-specifier specifier 'INIT-FILE-SPECIFIER->PATHNAME) + (guarantee init-file-specifier? specifier 'INIT-FILE-SPECIFIER->PATHNAME) (let ((short-base (merge-pathnames "mitschem.ini/" (user-homedir-pathname)))) (let ((file-map-pathname (merge-pathnames "filemap.dat" short-base))) (let ((port #f)) diff --git a/src/runtime/dospth.scm b/src/runtime/dospth.scm index 914e8f79a..ce039864c 100644 --- a/src/runtime/dospth.scm +++ b/src/runtime/dospth.scm @@ -253,13 +253,13 @@ USA. ((and (list? directory) (not (null? directory)) (memq (car directory) '(RELATIVE ABSOLUTE)) - (for-all? (if (server-directory? directory) - (cddr directory) - (cdr directory)) - (lambda (element) - (if (string? element) - (not (fix:= 0 (string-length element))) - (eq? element 'UP))))) + (every (lambda (element) + (if (string? element) + (not (fix:= 0 (string-length element))) + (eq? element 'UP))) + (if (server-directory? directory) + (cddr directory) + (cdr directory)))) (simplify-directory directory)) (else (error:illegal-pathname-component directory "directory"))) diff --git a/src/runtime/dynamic.scm b/src/runtime/dynamic.scm index 2a91c21ff..23b0f3864 100644 --- a/src/runtime/dynamic.scm +++ b/src/runtime/dynamic.scm @@ -75,9 +75,9 @@ USA. (define (default-parameter-setter set-param value) (set-param value)) (define (make-general-parameter initial-value converter merger getter setter) - (guarantee-procedure converter 'make-general-parameter) - (guarantee-procedure getter 'make-general-parameter) - (if setter (guarantee-procedure setter 'make-general-parameter)) + (guarantee procedure? converter 'make-general-parameter) + (guarantee procedure? getter 'make-general-parameter) + (if setter (guarantee procedure? setter 'make-general-parameter)) (make-general-parameter-1 (converter initial-value) converter merger @@ -108,7 +108,7 @@ USA. parameter)) (define (parameterize* new-bindings thunk) - (guarantee-alist new-bindings 'parameterize*) + (guarantee alist? new-bindings 'parameterize*) (let ((temp (map* bindings (lambda (p) diff --git a/src/runtime/error.scm b/src/runtime/error.scm index 8e87840a2..cf86e8cde 100644 --- a/src/runtime/error.scm +++ b/src/runtime/error.scm @@ -58,7 +58,7 @@ USA. (define (make-condition-type name generalization field-names reporter) (if generalization (guarantee-condition-type generalization 'MAKE-CONDITION-TYPE)) - (guarantee-list-of-unique-symbols field-names 'MAKE-CONDITION-TYPE) + (guarantee list-of-unique-symbols? field-names 'MAKE-CONDITION-TYPE) (let ((type (call-with-values (lambda () @@ -178,8 +178,8 @@ USA. (define (make-condition type continuation restarts field-alist) (guarantee-condition-type type 'MAKE-CONDITION) - (guarantee-continuation continuation 'MAKE-CONDITION) - (guarantee-unique-keyword-list field-alist 'MAKE-CONDITION) + (guarantee continuation? continuation 'MAKE-CONDITION) + (guarantee unique-keyword-list? field-alist 'MAKE-CONDITION) (let ((condition (%make-condition type continuation @@ -195,7 +195,7 @@ USA. (define (condition-constructor type field-names) (guarantee-condition-type type 'CONDITION-CONSTRUCTOR) - (guarantee-list-of-unique-symbols field-names 'CONDITION-CONSTRUCTOR) + (guarantee list-of-unique-symbols? field-names 'CONDITION-CONSTRUCTOR) (let ((indexes (map (lambda (field-name) (%condition-type/field-index type field-name @@ -204,7 +204,7 @@ USA. (letrec ((constructor (lambda (continuation restarts . field-values) - (guarantee-continuation continuation constructor) + (guarantee continuation? continuation constructor) (let ((condition (%make-condition type continuation @@ -246,7 +246,7 @@ USA. (define (condition-accessor type field-name) (guarantee-condition-type type 'CONDITION-ACCESSOR) - (guarantee-symbol field-name 'CONDITION-ACCESSOR) + (guarantee symbol? field-name 'CONDITION-ACCESSOR) (let ((predicate (condition-predicate type)) (index (%condition-type/field-index type @@ -327,7 +327,7 @@ USA. (guarantee-list-of-type object restart? "list of restarts" caller)) (define (with-restart name reporter effector interactor thunk) - (if name (guarantee-symbol name 'WITH-RESTART)) + (if name (guarantee symbol? name 'WITH-RESTART)) (if (not (or (string? reporter) (procedure-of-arity? reporter 1))) (error:wrong-type-argument reporter "reporter" 'WITH-RESTART)) (if (not (procedure? effector)) @@ -444,7 +444,7 @@ USA. (loop (cdr restarts)))))) (define (find-restart name #!optional restarts) - (guarantee-symbol name 'FIND-RESTART) + (guarantee symbol? name 'FIND-RESTART) (%find-restart name (restarts-default restarts 'FIND-RESTART))) (define (abort #!optional restarts) @@ -520,7 +520,7 @@ USA. thunk)) (define-integrable (guarantee-condition-handler object caller) - (guarantee-procedure-of-arity object 1 caller)) + (guarantee unary-procedure? object caller)) (define (break-on-signals types) (guarantee-condition-types types 'BREAK-ON-SIGNALS) diff --git a/src/runtime/fixart.scm b/src/runtime/fixart.scm index 9d88f5a10..03f996a2d 100644 --- a/src/runtime/fixart.scm +++ b/src/runtime/fixart.scm @@ -72,19 +72,9 @@ USA. (define (non-positive-fixnum? object) (and (fixnum? object) (not (fix:positive? object)))) - -(define-guarantee fixnum "fixnum") -(define-guarantee positive-fixnum "positive fixnum") -(define-guarantee negative-fixnum "negative fixnum") -(define-guarantee non-positive-fixnum "non-positive fixnum") -(define-guarantee non-negative-fixnum "non-negative fixnum") -(define (guarantee-index-fixnum object #!optional caller) - (if (not (index-fixnum? object)) - (error:wrong-type-argument object "index integer" caller))) - (define (guarantee-limited-index-fixnum object limit #!optional caller) - (guarantee-index-fixnum object caller) + (guarantee index-fixnum? object caller) (if (not (fix:< object limit)) (error:bad-range-argument object caller))) @@ -260,7 +250,7 @@ USA. ((ucode-primitive integer->flonum 2) n #b10)) (define (->flonum x) - (guarantee-real x '->FLONUM) + (guarantee real? x '->FLONUM) (exact->inexact (real-part x))) ;;;; Exact integers diff --git a/src/runtime/floenv.scm b/src/runtime/floenv.scm index 7489cc3e6..fc9c98eb8 100644 --- a/src/runtime/floenv.scm +++ b/src/runtime/floenv.scm @@ -216,7 +216,7 @@ USA. (thunk))))) (define (%mode-name->number mode caller) - (guarantee-interned-symbol mode caller) + (guarantee interned-symbol? mode caller) (let ((n (vector-length float-rounding-mode-names))) (let loop ((i 0)) (if (not (fix:< i n)) @@ -292,7 +292,7 @@ USA. (if (fix:zero? (fix:and bits exceptions)) tail (cons name tail))) - (guarantee-index-fixnum exceptions 'FLO:EXCEPTIONS->NAMES) + (guarantee index-fixnum? exceptions 'FLO:EXCEPTIONS->NAMES) (if (not (fix:zero? (fix:andc exceptions (flo:supported-exceptions)))) (error:bad-range-argument exceptions 'FLO:EXCEPTIONS->NAMES)) (n 'DIVIDE-BY-ZERO (flo:exception:divide-by-zero) @@ -311,7 +311,7 @@ USA. ((OVERFLOW) (flo:exception:overflow)) ((UNDERFLOW) (flo:exception:underflow)) (else (error:bad-range-argument names 'FLO:NAMES->EXCEPTIONS)))) - (guarantee-list-of-unique-symbols names 'FLO:NAMES->EXCEPTIONS) + (guarantee list-of-unique-symbols? names 'FLO:NAMES->EXCEPTIONS) (reduce fix:or 0 (map name->exceptions names))) ;;;; Floating-point environment utilities diff --git a/src/runtime/gcnote.scm b/src/runtime/gcnote.scm index 839b05906..2ce0fdc82 100644 --- a/src/runtime/gcnote.scm +++ b/src/runtime/gcnote.scm @@ -66,7 +66,7 @@ USA. (define gc-events-mutex (make-thread-mutex)) (define (register-gc-event event) - (guarantee-procedure-of-arity event 1 'register-gc-event) + (guarantee unary-procedure? event 'register-gc-event) (with-thread-mutex-lock gc-events-mutex (lambda () (clean-gc-events) diff --git a/src/runtime/generic.scm b/src/runtime/generic.scm index f51254816..5f84e8ba4 100644 --- a/src/runtime/generic.scm +++ b/src/runtime/generic.scm @@ -38,8 +38,8 @@ USA. (generator (if (default-object? generator) #f generator))) (if (and name (not (symbol? name))) (error:wrong-type-argument name "symbol" 'MAKE-GENERIC-PROCEDURE)) - (if tag (guarantee-dispatch-tag tag 'MAKE-GENERIC-PROCEDURE)) - (guarantee-procedure-arity arity 'MAKE-GENERIC-PROCEDURE) + (if tag (guarantee dispatch-tag? tag 'MAKE-GENERIC-PROCEDURE)) + (guarantee procedure-arity? arity 'MAKE-GENERIC-PROCEDURE) (if (not (fix:> (procedure-arity-min arity) 0)) (error:bad-range-argument arity 'MAKE-GENERIC-PROCEDURE)) (guarantee-generator generator 'MAKE-GENERIC-PROCEDURE) @@ -310,18 +310,18 @@ USA. (define (make-built-in-tag names) (let ((tags (map built-in-dispatch-tag names))) - (if (there-exists? tags (lambda (tag) tag)) + (if (any (lambda (tag) tag) tags) (let ((tag (car tags))) - (if (not (and (for-all? (cdr tags) - (lambda (tag*) - (eq? tag* tag))) + (if (not (and (every (lambda (tag*) + (eq? tag* tag)) + (cdr tags)) (let ((names* (dispatch-tag-contents tag))) - (and (for-all? names - (lambda (name) - (memq name names*))) - (for-all? names* - (lambda (name) - (memq name names))))))) + (and (every (lambda (name) + (memq name names*)) + names) + (every (lambda (name) + (memq name names)) + names*))))) (error "Illegal built-in tag redefinition:" names)) tag) (let ((tag (make-dispatch-tag (list-copy names)))) diff --git a/src/runtime/genio.scm b/src/runtime/genio.scm index c2074e1a8..c7199f54a 100644 --- a/src/runtime/genio.scm +++ b/src/runtime/genio.scm @@ -421,7 +421,7 @@ USA. (else '()))) (define (line-ending channel name for-output? caller) - (guarantee-symbol name caller) + (guarantee symbol? name caller) (if (and for-output? (known-input-line-ending? name) (not (known-output-line-ending? name))) diff --git a/src/runtime/gentag.scm b/src/runtime/gentag.scm index c83303645..b07004af1 100644 --- a/src/runtime/gentag.scm +++ b/src/runtime/gentag.scm @@ -62,13 +62,9 @@ USA. (%record-set! t i x)) (define (dispatch-tag-contents tag) - (guarantee-dispatch-tag tag 'DISPATCH-TAG-CONTENTS) + (guarantee dispatch-tag? tag 'DISPATCH-TAG-CONTENTS) (%record-ref tag 1)) -(define-integrable (guarantee-dispatch-tag tag caller) - (if (not (dispatch-tag? tag)) - (error:wrong-type-argument tag "dispatch tag" caller))) - (declare (integrate-operator next-dispatch-tag-index)) (define (next-dispatch-tag-index index) (and (fix:< (fix:+ index 1) dispatch-tag-index-end) diff --git a/src/runtime/global.scm b/src/runtime/global.scm index 2a6582e95..0aeb00512 100644 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@ -154,7 +154,7 @@ USA. (with-output-to-truncated-string max (lambda () (write object))))) (define (pa procedure) - (guarantee-procedure procedure 'PA) + (guarantee procedure? procedure 'PA) (cond ((procedure-lambda procedure) => (lambda (scode) (pp (unsyntax-lambda-list scode)))) @@ -438,15 +438,8 @@ USA. (define (make-hook-list) (%make-hook-list '())) -(define (guarantee-hook-list object caller) - (if (not (hook-list? object)) - (error:not-hook-list object caller))) - -(define (error:not-hook-list object caller) - (error:wrong-type-argument object "hook list" caller)) - (define (append-hook-to-list hook-list key hook) - (guarantee-hook-list hook-list 'APPEND-HOOK-TO-LIST) + (guarantee hook-list? hook-list 'APPEND-HOOK-TO-LIST) (let loop ((alist (hook-list-hooks hook-list)) (prev #f)) (if (pair? alist) (loop (cdr alist) @@ -463,7 +456,7 @@ USA. (set-hook-list-hooks! hook-list tail)))))) (define (remove-hook-from-list hook-list key) - (guarantee-hook-list hook-list 'REMOVE-HOOK-FROM-LIST) + (guarantee hook-list? hook-list 'REMOVE-HOOK-FROM-LIST) (let loop ((alist (hook-list-hooks hook-list)) (prev #f)) (if (pair? alist) (loop (cdr alist) @@ -476,11 +469,11 @@ USA. alist))))) (define (hook-in-list? hook-list key) - (guarantee-hook-list hook-list 'HOOK-IN-LIST?) + (guarantee hook-list? hook-list 'HOOK-IN-LIST?) (if (assq key (hook-list-hooks hook-list)) #t #f)) (define (run-hooks-in-list hook-list . arguments) - (guarantee-hook-list hook-list 'RUN-HOOKS-IN-LIST) + (guarantee hook-list? hook-list 'RUN-HOOKS-IN-LIST) (for-each (lambda (p) (apply (cdr p) arguments)) (hook-list-hooks hook-list))) diff --git a/src/runtime/hashtb.scm b/src/runtime/hashtb.scm index b25d63023..fb5e64e16 100644 --- a/src/runtime/hashtb.scm +++ b/src/runtime/hashtb.scm @@ -87,13 +87,13 @@ USA. (%make-hash-table type initial-size)) (define (%make-hash-table type #!optional initial-size) - (guarantee-hash-table-type type '%MAKE-HASH-TABLE) + (guarantee hash-table-type? type '%MAKE-HASH-TABLE) (let ((initial-size (if (or (default-object? initial-size) (not initial-size)) #f (begin - (guarantee-exact-nonnegative-integer initial-size - '%MAKE-HASH-TABLE) + (guarantee exact-nonnegative-integer? initial-size + '%MAKE-HASH-TABLE) initial-size)))) (let ((table (make-table type))) (if (and initial-size (> initial-size minimum-size)) @@ -129,19 +129,19 @@ USA. (set-table-needs-rehash?! table #t)))) (define (hash-table/type table) - (guarantee-hash-table table 'HASH-TABLE/TYPE) + (guarantee hash-table? table 'HASH-TABLE/TYPE) (table-type table)) (define (hash-table/key-hash table) - (guarantee-hash-table table 'HASH-TABLE/KEY-HASH) + (guarantee hash-table? table 'HASH-TABLE/KEY-HASH) (table-type-key-hash (table-type table))) (define (hash-table/key=? table) - (guarantee-hash-table table 'HASH-TABLE/KEY=?) + (guarantee hash-table? table 'HASH-TABLE/KEY=?) (table-type-key=? (table-type table))) (define (hash-table/get table key default) - (guarantee-hash-table table 'HASH-TABLE/GET) + (guarantee hash-table? table 'HASH-TABLE/GET) ((table-type-method:get (table-type table)) table key default)) (define (hash-table/lookup table key if-found if-not-found) @@ -151,11 +151,11 @@ USA. (if-found datum)))) (define (hash-table/put! table key datum) - (guarantee-hash-table table 'HASH-TABLE/PUT!) + (guarantee hash-table? table 'HASH-TABLE/PUT!) ((table-type-method:put! (table-type table)) table key datum)) (define (hash-table/modify! table key default procedure) - (guarantee-hash-table table 'HASH-TABLE/MODIFY!) + (guarantee hash-table? table 'HASH-TABLE/MODIFY!) ((table-type-method:modify! (table-type table)) table key default procedure)) (define (hash-table/intern! table key generator) @@ -164,11 +164,11 @@ USA. (if (eq? datum default-marker) (generator) datum)))) (define (hash-table/remove! table key) - (guarantee-hash-table table 'HASH-TABLE/REMOVE!) + (guarantee hash-table? table 'HASH-TABLE/REMOVE!) ((table-type-method:remove! (table-type table)) table key)) (define (hash-table/clean! table) - (guarantee-hash-table table 'HASH-TABLE/CLEAN!) + (guarantee hash-table? table 'HASH-TABLE/CLEAN!) (without-interruption (lambda () ((table-type-method:clean! (table-type table)) table) @@ -182,19 +182,19 @@ USA. (hash-table->alist table))) (define (hash-table->alist table) - (guarantee-hash-table table 'HASH-TABLE->ALIST) + (guarantee hash-table? table 'HASH-TABLE->ALIST) (%hash-table-fold table (lambda (key datum alist) (cons (cons key datum) alist)) '())) (define (hash-table/key-list table) - (guarantee-hash-table table 'HASH-TABLE/KEY-LIST) + (guarantee hash-table? table 'HASH-TABLE/KEY-LIST) (%hash-table-fold table (lambda (key datum alist) datum (cons key alist)) '())) (define (hash-table/datum-list table) - (guarantee-hash-table table 'HASH-TABLE/DATUM-LIST) + (guarantee hash-table? table 'HASH-TABLE/DATUM-LIST) (%hash-table-fold table (lambda (key datum alist) key (cons datum alist)) '())) @@ -203,11 +203,11 @@ USA. ((table-type-method:fold (table-type table)) table procedure initial-value)) (define (hash-table/rehash-threshold table) - (guarantee-hash-table table 'HASH-TABLE/REHASH-THRESHOLD) + (guarantee hash-table? table 'HASH-TABLE/REHASH-THRESHOLD) (table-rehash-threshold table)) (define (set-hash-table/rehash-threshold! table threshold) - (guarantee-hash-table table 'SET-HASH-TABLE/REHASH-THRESHOLD!) + (guarantee hash-table? table 'SET-HASH-TABLE/REHASH-THRESHOLD!) (let ((threshold (check-arg threshold default-rehash-threshold @@ -223,11 +223,11 @@ USA. (new-size! table (table-grow-size table)))))) (define (hash-table/rehash-size table) - (guarantee-hash-table table 'HASH-TABLE/REHASH-SIZE) + (guarantee hash-table? table 'HASH-TABLE/REHASH-SIZE) (table-rehash-size table)) (define (set-hash-table/rehash-size! table size) - (guarantee-hash-table table 'SET-HASH-TABLE/REHASH-SIZE!) + (guarantee hash-table? table 'SET-HASH-TABLE/REHASH-SIZE!) (let ((size (check-arg size default-rehash-size @@ -244,7 +244,7 @@ USA. (maybe-shrink-table! table))))) (define (hash-table/count table) - (guarantee-hash-table table 'HASH-TABLE/COUNT) + (guarantee hash-table? table 'HASH-TABLE/COUNT) (let loop () (let ((count (table-count table))) (if (table-needs-rehash? table) @@ -254,11 +254,11 @@ USA. count)))) (define (hash-table/size table) - (guarantee-hash-table table 'HASH-TABLE/SIZE) + (guarantee hash-table? table 'HASH-TABLE/SIZE) (table-grow-size table)) (define (hash-table/clear! table) - (guarantee-hash-table table 'HASH-TABLE/CLEAR!) + (guarantee hash-table? table 'HASH-TABLE/CLEAR!) (without-interruption (lambda () (if (not (table-initial-size-in-effect? table)) @@ -1308,7 +1308,7 @@ USA. hash-table-entry-type:strong)) (define (alist->hash-table alist #!optional key=? key-hash) - (guarantee-alist alist 'ALIST->HASH-TABLE) + (guarantee alist? alist 'ALIST->HASH-TABLE) (let ((table (make-hash-table key=? key-hash))) (for-each (lambda (p) (hash-table/put! table (car p) (cdr p))) @@ -1358,7 +1358,7 @@ USA. (hash-table-update! table key procedure (lambda () default))) (define (hash-table-copy table) - (guarantee-hash-table table 'HASH-TABLE-COPY) + (guarantee hash-table? table 'HASH-TABLE-COPY) (without-interruption (lambda () (let ((table* (copy-table table)) @@ -1371,8 +1371,8 @@ USA. table*)))) (define (hash-table-merge! table1 table2) - (guarantee-hash-table table1 'HASH-TABLE-MERGE!) - (guarantee-hash-table table2 'HASH-TABLE-MERGE!) + (guarantee hash-table? table1 'HASH-TABLE-MERGE!) + (guarantee hash-table? table2 'HASH-TABLE-MERGE!) (if (not (eq? table2 table1)) (%hash-table-fold table2 (lambda (key datum ignore) diff --git a/src/runtime/http-client.scm b/src/runtime/http-client.scm index b6ec8f1b5..242d5c621 100644 --- a/src/runtime/http-client.scm +++ b/src/runtime/http-client.scm @@ -55,7 +55,7 @@ USA. value))) (define (http-client-request method uri headers body) - (guarantee-absolute-uri uri) + (guarantee absolute-uri? uri) (make-http-request method (make-uri #f #f diff --git a/src/runtime/http-syntax.scm b/src/runtime/http-syntax.scm index f567a7f30..d422599ac 100644 --- a/src/runtime/http-syntax.scm +++ b/src/runtime/http-syntax.scm @@ -240,7 +240,7 @@ USA. (list (http-header-name header))))) (define (make-http-header name value) - (guarantee-http-token name 'MAKE-HTTP-HEADER) + (guarantee http-token? name 'MAKE-HTTP-HEADER) (let ((defn (header-value-defn name))) (if defn (if ((hvdefn-predicate defn) value) @@ -250,15 +250,15 @@ USA. ((hvdefn-writer defn) value port))) value) (begin - (guarantee-http-text value 'MAKE-HTTP-HEADER) + (guarantee http-text? value 'MAKE-HTTP-HEADER) (%make-header name value (%call-parser (hvdefn-parser defn) value #t)))) (begin - (guarantee-http-text value 'MAKE-HTTP-HEADER) + (guarantee http-text? value 'MAKE-HTTP-HEADER) (%make-header name value (%unparsed-value)))))) (define (convert-http-headers headers #!optional caller) - (guarantee-list headers caller) + (guarantee list? headers caller) (map (lambda (header) (cond ((http-header? header) header) @@ -276,9 +276,6 @@ USA. (error:not-http-header header caller)))) headers)) -(define (guarantee-http-headers object #!optional caller) - (guarantee-list-of-type object http-header? "HTTP headers" caller)) - (define (http-header name headers error?) (let ((h (find (lambda (header) @@ -396,7 +393,7 @@ USA. (default-object)) (define (write-http-headers headers port) - (guarantee-http-headers headers 'WRITE-HTTP-HEADERS) + (guarantee-list-of http-header? headers 'WRITE-HTTP-HEADERS) (for-each (lambda (header) (let ((name (http-header-name header))) (let ((defn (header-value-defn name))) diff --git a/src/runtime/httpio.scm b/src/runtime/httpio.scm index a12228488..cfb7db94b 100644 --- a/src/runtime/httpio.scm +++ b/src/runtime/httpio.scm @@ -41,12 +41,10 @@ USA. (headers http-request-headers) (body http-request-body)) -(define-guarantee http-request "HTTP request") - (define (make-http-request method uri version headers body) - (guarantee-http-token-string method 'MAKE-HTTP-REQUEST) - (guarantee-http-request-uri uri 'MAKE-HTTP-REQUEST) - (guarantee-http-version version 'MAKE-HTTP-REQUEST) + (guarantee http-token-string? method 'MAKE-HTTP-REQUEST) + (guarantee http-request-uri? uri 'MAKE-HTTP-REQUEST) + (guarantee http-version? version 'MAKE-HTTP-REQUEST) (receive (headers body) (guarantee-headers&body headers body 'MAKE-HTTP-REQUEST) (%make-http-request method uri version headers body))) @@ -66,12 +64,10 @@ USA. (headers http-response-headers) (body http-response-body)) -(define-guarantee http-response "HTTP response") - (define (make-http-response version status reason headers body) - (guarantee-http-version version 'MAKE-HTTP-RESPONSE) - (guarantee-http-status status 'MAKE-HTTP-RESPONSE) - (guarantee-http-text reason 'MAKE-HTTP-RESPONSE) + (guarantee http-version? version 'MAKE-HTTP-RESPONSE) + (guarantee http-status? status 'MAKE-HTTP-RESPONSE) + (guarantee http-text? reason 'MAKE-HTTP-RESPONSE) (receive (headers body) (guarantee-headers&body headers body 'MAKE-HTTP-RESPONSE) (%make-http-response version status reason headers body))) @@ -82,7 +78,7 @@ USA. (list (http-response-status response))))) (define (guarantee-headers&body headers body caller) - (guarantee-http-headers headers caller) + (guarantee-list-of http-header? headers caller) (if body (begin (guarantee string? body caller) @@ -106,7 +102,7 @@ USA. (define-guarantee simple-http-request "simple HTTP request") (define (make-simple-http-request uri) - (guarantee-simple-http-request-uri uri 'MAKE-HTTP-REQUEST) + (guarantee simple-http-request-uri? uri 'MAKE-HTTP-REQUEST) (%make-http-request '|GET| uri #f '() "")) (define (simple-http-response? object) @@ -362,7 +358,7 @@ USA. ;;;; Status descriptions (define (http-status-description code) - (guarantee-http-status code 'HTTP-STATUS-DESCRIPTION) + (guarantee http-status? code 'HTTP-STATUS-DESCRIPTION) (let loop ((low 0) (high (vector-length known-status-codes))) (if (< low high) (let ((index (quotient (+ low high) 2))) diff --git a/src/runtime/integer-bits.scm b/src/runtime/integer-bits.scm index d35e41396..22bf9c12a 100644 --- a/src/runtime/integer-bits.scm +++ b/src/runtime/integer-bits.scm @@ -173,7 +173,7 @@ USA. (bits '() (cons (odd? integer) bits))) ((zero? integer) bits)) (begin - (guarantee-index-fixnum length 'INTEGER->LIST) + (guarantee index-fixnum? length 'INTEGER->LIST) (do ((length length (- length 1)) (integer integer (shift-right integer 1)) (bits '() (cons (odd? integer) bits))) diff --git a/src/runtime/lambda-list.scm b/src/runtime/lambda-list.scm index 38993209c..78746bd06 100644 --- a/src/runtime/lambda-list.scm +++ b/src/runtime/lambda-list.scm @@ -38,8 +38,6 @@ USA. (not (memq (car object) seen)) (loop (cdr object) (cons (car object) seen))))))) -(define-guarantee r4rs-lambda-list "R4RS lambda list") - (define (parse-r4rs-lambda-list bvl) (let loop ((bvl* bvl) (required '())) (cond ((and (pair? bvl*) @@ -51,7 +49,7 @@ USA. ((identifier? bvl*) (values (reverse! required) bvl*)) (else - (error:not-r4rs-lambda-list bvl))))) + (error:not-a r4rs-lambda-list? bvl))))) (define (map-r4rs-lambda-list procedure bvl) (let loop ((bvl* bvl)) @@ -64,7 +62,7 @@ USA. ((identifier? bvl*) (procedure bvl*)) (else - (error:not-r4rs-lambda-list bvl))))) + (error:not-a r4rs-lambda-list? bvl))))) (define (mit-lambda-list? object) (letrec @@ -118,8 +116,6 @@ USA. (k (cons (car object) seen))))))) (parse-required object '()))) -(define-guarantee mit-lambda-list "MIT/GNU Scheme lambda list") - (define lambda-tag:optional (object-new-type (ucode-type constant) 3)) (define lambda-tag:rest (object-new-type (ucode-type constant) 4)) (define lambda-tag:key (object-new-type (ucode-type constant) 5)) @@ -188,7 +184,7 @@ USA. (values required optional rest))) (define (bad-lambda-list pattern) - (error:not-mit-lambda-list pattern 'PARSE-MIT-LAMBDA-LIST)) + (error:not-a mit-lambda-list? pattern 'PARSE-MIT-LAMBDA-LIST)) (parse-parameters required lambda-list))) @@ -206,11 +202,11 @@ USA. ;;; Aux is almost always the empty list. (define (make-lambda-list required optional rest aux) - (guarantee-list-of-unique-symbols required) - (guarantee-list-of-unique-symbols optional) + (guarantee list-of-unique-symbols? required) + (guarantee list-of-unique-symbols? optional) (if rest - (guarantee-symbol rest)) - (guarantee-list-of-unique-symbols aux) + (guarantee symbol? rest)) + (guarantee list-of-unique-symbols? aux) (let ((rest-aux-tail (if (not rest) (if (null? aux) '() diff --git a/src/runtime/list.scm b/src/runtime/list.scm index 5d35b4493..d9c4a8ea3 100644 --- a/src/runtime/list.scm +++ b/src/runtime/list.scm @@ -88,7 +88,7 @@ USA. this-element))) (define (make-list length #!optional value) - (guarantee-index-fixnum length 'MAKE-LIST) + (guarantee index-fixnum? length 'MAKE-LIST) (let ((value (if (default-object? value) '() value))) (let loop ((n length) (result '())) (if (fix:zero? n) @@ -104,7 +104,7 @@ USA. items) (define (make-circular-list length #!optional value) - (guarantee-index-fixnum length 'MAKE-CIRCULAR-LIST) + (guarantee index-fixnum? length 'MAKE-CIRCULAR-LIST) (if (fix:> length 0) (let ((value (if (default-object? value) '() value))) (let ((last (cons value '()))) @@ -117,7 +117,7 @@ USA. '())) (define (make-initialized-list length initialization) - (guarantee-index-fixnum length 'MAKE-INITIALIZED-LIST) + (guarantee index-fixnum? length 'MAKE-INITIALIZED-LIST) (let loop ((index (fix:- length 1)) (result '())) (if (fix:< index 0) result @@ -128,18 +128,18 @@ USA. (cons a d)) (define (iota count #!optional start step) - (guarantee-index-fixnum count 'IOTA) + (guarantee index-fixnum? count 'IOTA) (let ((start (if (default-object? start) 0 (begin - (guarantee-number start 'IOTA) + (guarantee number? start 'IOTA) start))) (step (if (default-object? step) 1 (begin - (guarantee-number step 'IOTA) + (guarantee number? step 'IOTA) step)))) (make-initialized-list count (lambda (index) (+ start (* index step)))))) @@ -178,11 +178,6 @@ USA. (and (pair? object) (list? (cdr object)))) -(define-guarantee pair "pair") -(define-guarantee list "list") -(define-guarantee dotted-list "improper list") -(define-guarantee circular-list "circular list") - (define (list-of-type? object predicate) (let loop ((l1 object) (l2 object)) (if (pair? l1) @@ -230,7 +225,7 @@ USA. (define (guarantee-list->length object #!optional caller) (let ((n (list?->length object))) (if (not n) - (error:not-list object caller)) + (error:not-a list? object caller)) n)) (define (guarantee-list-of-type->length object predicate description @@ -250,19 +245,19 @@ USA. (cond ((pair? list) (and (fix:positive? n) (%length=? (fix:- n 1) (cdr list)))) ((null? list) (fix:zero? n)) - (else (error:not-list list 'length=?)))) + (else (error:not-a list? list 'length=?)))) (define (%same-length left right) (cond ((pair? left) (cond ((pair? right) (%same-length (cdr left) (cdr right))) ((null? right) #f) - (else (error:not-list right 'length=?)))) + (else (error:not-a list? right 'length=?)))) ((null? left) (cond ((pair? right) #f) ((null? right) #t) - (else (error:not-list right 'length=?)))) + (else (error:not-a list? right 'length=?)))) (else - (error:not-list left 'length=?)))) + (error:not-a list? left 'length=?)))) ;; Take arguments in either order to make this easy to use. (cond ((pair? left) @@ -290,7 +285,7 @@ USA. (define (null-list? l #!optional caller) (cond ((pair? l) #f) ((null? l) #t) - (else (error:not-list l caller)))) + (else (error:not-a list? l caller)))) (define (list= predicate . lists) @@ -316,7 +311,7 @@ USA. (define (lose) (for-each (lambda (list) - (guarantee-list list 'LIST=)) + (guarantee list? list 'LIST=)) lists)) (if (and (pair? lists) @@ -337,7 +332,7 @@ USA. (set-car! tail new-value))) (define (list-tail list index) - (guarantee-index-fixnum index 'LIST-TAIL) + (guarantee index-fixnum? index 'LIST-TAIL) (let loop ((list list) (index* index)) (if (fix:zero? index*) list @@ -347,7 +342,7 @@ USA. (loop (cdr list) (fix:- index* 1)))))) (define (list-head list index) - (guarantee-index-fixnum index 'LIST-HEAD) + (guarantee index-fixnum? index 'LIST-HEAD) (let loop ((list list) (index* index)) (if (fix:zero? index*) '() @@ -360,7 +355,7 @@ USA. (list-head (list-tail list start) (- end start))) (define (list-copy items) - (let ((lose (lambda () (error:not-list items 'LIST-COPY)))) + (let ((lose (lambda () (error:not-a list? items 'LIST-COPY)))) (cond ((pair? items) (let ((head (cons (car items) '()))) (let loop ((list (cdr items)) (previous head)) @@ -418,7 +413,7 @@ USA. result)))) (begin (if (not (null? items*)) - (error:not-weak-list items 'WEAK-LIST->LIST)) + (error:not-a weak-list? items 'WEAK-LIST->LIST)) (reverse! result))))) (define (list->weak-list items) @@ -428,7 +423,7 @@ USA. (weak-cons (car items*) result)) (begin (if (not (null? items*)) - (error:not-list items 'LIST->WEAK-LIST)) + (error:not-a list? items 'LIST->WEAK-LIST)) result)))) (define weak-pair/false @@ -443,8 +438,6 @@ USA. (loop (weak-cdr l1) (weak-cdr l2)) (null? l1)))) (null? l1)))) - -(define-guarantee weak-list "weak list") (define (weak-memq object items) (let ((object (or object weak-pair/false))) @@ -455,7 +448,7 @@ USA. (loop (system-pair-cdr items*))) (begin (if (not (null? items*)) - (error:not-weak-list items 'WEAK-MEMQ)) + (error:not-a weak-list? items 'WEAK-MEMQ)) #f))))) (define (weak-delq! item items) @@ -471,7 +464,7 @@ USA. items*)) (begin (if (not (null? items*)) - (error:not-weak-list items 'WEAK-DELQ!)) + (error:not-a weak-list? items 'WEAK-DELQ!)) '())))) (locate-initial-segment (lambda (last this) @@ -482,7 +475,7 @@ USA. (trim-initial-segment (system-pair-cdr this))) (locate-initial-segment this (system-pair-cdr this))) (if (not (null? this)) - (error:not-weak-list items 'WEAK-DELQ!)))))) + (error:not-a weak-list? items 'WEAK-DELQ!)))))) (trim-initial-segment items))) ;;;; General CAR CDR @@ -490,7 +483,7 @@ USA. ;;; Return a list of car and cdr symbols that the code ;;; represents. Leftmost operation is outermost. (define (decode-general-car-cdr code) - (guarantee-positive-fixnum code) + (guarantee positive-fixnum? code) (do ((code code (fix:lsh code -1)) (result '() (cons (if (even? code) 'cdr 'car) result))) ((= code 1) result))) @@ -515,10 +508,10 @@ USA. (declare (integrate-operator safe-car safe-cdr)) (define (safe-car x) - (if (pair? x) (car x) (error:not-pair x 'SAFE-CAR))) + (if (pair? x) (car x) (error:not-a pair? x 'SAFE-CAR))) (define (safe-cdr x) - (if (pair? x) (cdr x) (error:not-pair x 'SAFE-CDR))) + (if (pair? x) (cdr x) (error:not-a pair? x 'SAFE-CDR))) (define (caar x) (safe-car (safe-car x))) (define (cadr x) (safe-car (safe-cdr x))) @@ -612,12 +605,13 @@ USA. ((null? next) (set-cdr! cell accum)) (else - (error:not-list (car rest) 'APPEND)))) + (error:not-a list? (car rest) + 'APPEND)))) root)) ((null? l1) accum) (else - (error:not-list (car rest) 'APPEND)))) + (error:not-a list? (car rest) 'APPEND)))) (cdr rest)) accum)) '()))) @@ -632,7 +626,7 @@ USA. head) (else (if (not (null? head)) - (error:not-list (car lists) 'APPEND!)) + (error:not-a list? (car lists) 'APPEND!)) (loop (car tail) (cdr tail))))) '())) @@ -645,7 +639,7 @@ USA. (loop (cdr rest) (cons (car rest) so-far)) (begin (if (not (null? rest)) - (error:not-list l 'REVERSE*)) + (error:not-a list? l 'REVERSE*)) so-far)))) (define (reverse*! l tail) @@ -656,7 +650,7 @@ USA. (loop next current)) (begin (if (not (null? current)) - (error:not-list l 'REVERSE*!)) + (error:not-a list? l 'REVERSE*!)) new-cdr)))) ;;;; Mapping Procedures @@ -725,7 +719,7 @@ USA. (define (mapper-error lists caller) (for-each (lambda (list) (if (dotted-list? list) - (error:not-list list caller))) + (error:not-a list? list caller))) lists)) (define for-each) @@ -806,7 +800,7 @@ USA. (cdr remaining)) (begin (if (not (null? remaining)) - (error:not-list list caller)) + (error:not-a list? list caller)) state)))) ;; N-ary version @@ -869,7 +863,7 @@ USA. (cdr list)) (begin (if (not (null? list)) - (error:not-list list 'REDUCE)) + (error:not-a list? list 'REDUCE)) default))) (define (reduce-left procedure initial list) @@ -882,11 +876,11 @@ USA. (procedure first (loop (car rest) (cdr rest))) (begin (if (not (null? rest)) - (error:not-list list 'REDUCE-RIGHT)) + (error:not-a list? list 'REDUCE-RIGHT)) first))) (begin (if (not (null? list)) - (error:not-list list 'REDUCE-RIGHT)) + (error:not-a list? list 'REDUCE-RIGHT)) initial))) (define (fold-right procedure initial first . rest) @@ -909,7 +903,7 @@ USA. (procedure (car list) (loop (cdr list))) (begin (if (not (null? list)) - (error:not-list first 'FOLD-RIGHT)) + (error:not-a list? first 'FOLD-RIGHT)) initial))))) ;;;; Generalized list operations @@ -922,7 +916,7 @@ USA. (loop (cdr items*))) (begin (if (not (null? items*)) - (error:not-list items 'FIND-MATCHING-ITEM)) + (error:not-a list? items 'FIND-MATCHING-ITEM)) #f)))) (define (find-non-matching-item items predicate) @@ -933,20 +927,20 @@ USA. (car items*)) (begin (if (not (null? items*)) - (error:not-list items 'FIND-MATCHING-ITEM)) + (error:not-a list? items 'FIND-MATCHING-ITEM)) #f)))) (define (find-unique-matching-item items predicate) (let loop ((items* items)) (if (pair? items*) (if (predicate (car items*)) - (if (there-exists? (cdr items*) predicate) + (if (any predicate (cdr items*)) #f (car items*)) (loop (cdr items*))) (begin (if (not (null? items*)) - (error:not-list items 'FIND-UNIQUE-MATCHING-ITEM)) + (error:not-a list? items 'FIND-UNIQUE-MATCHING-ITEM)) #f)))) (define (find-unique-non-matching-item items predicate) @@ -954,12 +948,12 @@ USA. (if (pair? items*) (if (predicate (car items*)) (loop (cdr items*)) - (if (for-all? (cdr items*) predicate) + (if (every predicate (cdr items*)) (car items*) #f)) (begin (if (not (null? items*)) - (error:not-list items 'FIND-UNIQUE-NON-MATCHING-ITEM)) + (error:not-a list? items 'FIND-UNIQUE-NON-MATCHING-ITEM)) #f)))) (define (count-matching-items items predicate) @@ -967,7 +961,7 @@ USA. (n 0 (if (predicate (car items*)) (fix:+ n 1) n))) ((not (pair? items*)) (if (not (null? items*)) - (error:not-list items 'COUNT-MATCHING-ITEMS)) + (error:not-a list? items 'COUNT-MATCHING-ITEMS)) n))) (define (count-non-matching-items items predicate) @@ -975,11 +969,11 @@ USA. (n 0 (if (predicate (car items*)) n (fix:+ n 1)))) ((not (pair? items*)) (if (not (null? items*)) - (error:not-list items 'COUNT-NON-MATCHING-ITEMS)) + (error:not-a list? items 'COUNT-NON-MATCHING-ITEMS)) n))) (define (keep-matching-items items predicate) - (let ((lose (lambda () (error:not-list items 'KEEP-MATCHING-ITEMS)))) + (let ((lose (lambda () (error:not-a list? items 'KEEP-MATCHING-ITEMS)))) (cond ((pair? items) (let ((head (cons (car items) '()))) (let loop ((items* (cdr items)) (previous head)) @@ -997,7 +991,7 @@ USA. (else (lose))))) (define (delete-matching-items items predicate) - (let ((lose (lambda () (error:not-list items 'DELETE-MATCHING-ITEMS)))) + (let ((lose (lambda () (error:not-a list? items 'DELETE-MATCHING-ITEMS)))) (cond ((pair? items) (let ((head (cons (car items) '()))) (let loop ((items* (cdr items)) (previous head)) @@ -1038,7 +1032,7 @@ USA. (lose))))) (lose (lambda () - (error:not-list items 'DELETE-MATCHING-ITEMS!)))) + (error:not-a list? items 'DELETE-MATCHING-ITEMS!)))) (trim-initial-segment items))) (define (keep-matching-items! items predicate) @@ -1065,7 +1059,7 @@ USA. (lose))))) (lose (lambda () - (error:not-list items 'KEEP-MATCHING-ITEMS!)))) + (error:not-a list? items 'KEEP-MATCHING-ITEMS!)))) (trim-initial-segment items))) (define ((list-deletor predicate) items) @@ -1097,7 +1091,7 @@ USA. (cons item items)))) (define-integrable (%member item items = caller) - (let ((lose (lambda () (error:not-list items caller)))) + (let ((lose (lambda () (error:not-a list? items caller)))) (let loop ((items items)) (if (pair? items) (if (= (car items) item) @@ -1122,7 +1116,7 @@ USA. (%delete item items = 'DELETE))) (define-integrable (%delete item items = caller) - (let ((lose (lambda () (error:not-list items caller)))) + (let ((lose (lambda () (error:not-a list? items caller)))) (if (pair? items) (let ((head (cons (car items) '()))) (let loop ((items (cdr items)) (previous head)) @@ -1174,10 +1168,10 @@ USA. (trim-initial-segment (cdr this))) (locate-initial-segment this (cdr this))) (if (not (null? this)) - (error:not-list items caller))))) + (error:not-a list? items caller))))) (lose (lambda () - (error:not-list items caller)))) + (error:not-a list? items caller)))) (trim-initial-segment items))) ;;;; Association lists @@ -1185,13 +1179,11 @@ USA. (define (alist? object) (list-of-type? object pair?)) -(define-guarantee alist "association list") - (define-integrable (alist-cons key datum alist) (cons (cons key datum) alist)) (define (alist-copy alist) - (let ((lose (lambda () (error:not-alist alist 'ALIST-COPY)))) + (let ((lose (lambda () (error:not-a alist? alist 'ALIST-COPY)))) (cond ((pair? alist) (if (pair? (car alist)) (let ((head (cons (car alist) '()))) @@ -1213,7 +1205,7 @@ USA. (define (association-procedure predicate selector #!optional caller) (lambda (key items) - (let ((lose (lambda () (error:not-list items caller)))) + (let ((lose (lambda () (error:not-a list? items caller)))) (let loop ((items items)) (if (pair? items) (if (predicate (selector (car items)) key) @@ -1238,7 +1230,7 @@ USA. (%assoc key alist = 'ASSOC))) (define-integrable (%assoc key alist = caller) - (let ((lose (lambda () (error:not-alist alist caller)))) + (let ((lose (lambda () (error:not-a alist? alist caller)))) (declare (no-type-checks)) (let loop ((alist alist)) (if (pair? alist) @@ -1267,7 +1259,7 @@ USA. (%alist-delete key alist = 'ALIST-DELETE))) (define-integrable (%alist-delete key alist = caller) - (let ((lose (lambda () (error:not-alist alist caller)))) + (let ((lose (lambda () (error:not-a alist? alist caller)))) (if (pair? alist) (begin (if (not (pair? (car alist))) @@ -1336,7 +1328,7 @@ USA. (lose))))) (lose (lambda () - (error:not-alist items caller)))) + (error:not-a alist? items caller)))) (trim-initial-segment items))) ;;;; Keyword lists @@ -1350,8 +1342,6 @@ USA. (loop (cdr (cdr l1)) (cdr l1))) (null? l1)))) -(define-guarantee keyword-list "keyword list") - (define (restricted-keyword-list? object keywords) (let loop ((l1 object) (l2 object)) (if (pair? l1) @@ -1379,8 +1369,6 @@ USA. (not (eq? (cdr l1) l2)) (loop (cdr (cdr l1)) (cdr l1) (cons (car l1) symbols))) (null? l1)))) - -(define-guarantee unique-keyword-list "unique keyword list") (define (get-keyword-value klist key #!optional default-value) (let ((lose (lambda () (error:not-a keyword-list? klist 'get-keyword-value)))) @@ -1475,14 +1463,16 @@ USA. (car (last-pair list))) (define (last-pair list) - (guarantee-pair list 'LAST-PAIR) + (if (not (pair? list)) + (error:not-a pair? list 'last-pair)) (let loop ((list list)) (if (pair? (cdr list)) (loop (cdr list)) list))) (define (except-last-pair list) - (guarantee-pair list 'EXCEPT-LAST-PAIR) + (if (not (pair? list)) + (error:not-a pair? list 'except-last-pair)) (if (not (pair? (cdr list))) '() (let ((head (cons (car list) '()))) @@ -1494,7 +1484,8 @@ USA. head))))) (define (except-last-pair! list) - (guarantee-pair list 'EXCEPT-LAST-PAIR!) + (if (not (pair? list)) + (error:not-a pair? list 'except-last-pair!)) (if (pair? (cdr list)) (begin (let loop ((list list)) diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index 01cc4619a..170e4d4db 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -395,7 +395,7 @@ USA. ,(single-test (cadddr items)))) (else `(,(rename - (if (for-all? items eq-testable?) 'MEMQ 'MEMV)) + (if (every eq-testable? items) 'MEMQ 'MEMV)) ,(rename 'TEMP) ',items))))) (single-test diff --git a/src/runtime/ntprm.scm b/src/runtime/ntprm.scm index 58a7cd59c..a7b22b431 100644 --- a/src/runtime/ntprm.scm +++ b/src/runtime/ntprm.scm @@ -427,7 +427,7 @@ USA. (loop (+ index 1)) filename)))) - (guarantee-init-file-specifier specifier 'INIT-FILE-SPECIFIER->PATHNAME) + (guarantee init-file-specifier? specifier 'INIT-FILE-SPECIFIER->PATHNAME) (let ((long-base (merge-pathnames ".mit-scheme/" (user-homedir-pathname)))) (if (dos/fs-long-filenames? long-base) (if (pair? specifier) diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm index 824f652f9..3d7187362 100644 --- a/src/runtime/parse.scm +++ b/src/runtime/parse.scm @@ -293,8 +293,7 @@ USA. (make-parser-table initial special))) (define (boolean-converter value) - (guarantee-boolean value) - value) + (guarantee boolean? value)) (define (char-set-converter value) (guarantee char-set? value) @@ -306,7 +305,7 @@ USA. value) (define (parser-table-converter value) - (guarantee-parser-table value) + (guarantee parser-table? value) value) (define (radix-converter value) @@ -633,9 +632,8 @@ USA. (loop (cons object objects)))))) (define (define-bracketed-object-parser-method name method) - (guarantee-interned-symbol name 'DEFINE-BRACKETED-OBJECT-PARSER-METHOD) - (guarantee-procedure-of-arity method 2 - 'DEFINE-BRACKETED-OBJECT-PARSER-METHOD) + (guarantee interned-symbol? name 'DEFINE-BRACKETED-OBJECT-PARSER-METHOD) + (guarantee binary-procedure? method 'DEFINE-BRACKETED-OBJECT-PARSER-METHOD) (hash-table/put! hashed-object-interns name method)) (define hashed-object-interns) diff --git a/src/runtime/pathnm.scm b/src/runtime/pathnm.scm index 6b6510f72..9c7273eab 100644 --- a/src/runtime/pathnm.scm +++ b/src/runtime/pathnm.scm @@ -127,7 +127,7 @@ these rules: (define (pathname-arg object defaults operator) (cond ((pathname? object) object) ((string? object) (parse-namestring object #f defaults)) - (else (error:not-pathname object operator)))) + (else (error:not-a pathname? object operator)))) (define (make-pathname host device directory name type version) (let ((host (if host (guarantee-host host 'MAKE-PATHNAME) local-host))) diff --git a/src/runtime/pgsql.scm b/src/runtime/pgsql.scm index 7b1b13183..d3ac49a81 100644 --- a/src/runtime/pgsql.scm +++ b/src/runtime/pgsql.scm @@ -81,7 +81,7 @@ USA. (ill-formed-syntax form))))) (define (index->name index enum) - (guarantee-index-fixnum index 'INDEX->NAME) + (guarantee index-fixnum? index 'INDEX->NAME) (if (not (fix:< index (vector-length enum))) (error:bad-range-argument index 'INDEX->NAME)) (vector-ref enum index)) diff --git a/src/runtime/process.scm b/src/runtime/process.scm index 055c1c66e..62b7d6b90 100644 --- a/src/runtime/process.scm +++ b/src/runtime/process.scm @@ -278,8 +278,8 @@ USA. (define (register-subprocess-event subprocess status thread event) (guarantee-subprocess subprocess 'register-subprocess-event) - (guarantee-thread thread 'register-subprocess-event) - (guarantee-procedure-of-arity event 1 'register-subprocess-event) + (guarantee thread? thread 'register-subprocess-event) + (guarantee unary-procedure? event 'register-subprocess-event) (let ((registration (make-subprocess-registration subprocess status thread event))) (without-interrupts diff --git a/src/runtime/record.scm b/src/runtime/record.scm index bc0d34b9a..e1eb43001 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -138,7 +138,8 @@ USA. #!optional default-inits unparser-method entity-unparser-method) (let ((caller 'MAKE-RECORD-TYPE)) - (guarantee-list-of-unique-symbols field-names caller) + (if (not (list-of-unique-symbols? field-names)) + (error:not-a list-of-unique-symbols? field-names caller)) (let* ((names ((ucode-primitive list->vector) field-names)) (n (vector-length names)) (record-type @@ -315,8 +316,8 @@ USA. (define set-record-type-unparser-method!/after-boot (named-lambda (set-record-type-unparser-method! record-type method) (guarantee-record-type record-type 'SET-RECORD-TYPE-UNPARSER-METHOD!) - (if method - (guarantee-unparser-method method 'SET-RECORD-TYPE-UNPARSER-METHOD!)) + (if (and method (not (unparser-method? method))) + (error:not-a unparser-method? method 'SET-RECORD-TYPE-UNPARSER-METHOD!)) (let ((tag (%record-type-dispatch-tag record-type))) (remove-generic-procedure-generators unparse-record @@ -330,9 +331,9 @@ USA. ;; It's not kosher to use this during the cold load. (define (set-record-type-entity-unparser-method! record-type method) (guarantee-record-type record-type 'SET-RECORD-TYPE-ENTITY-UNPARSER-METHOD!) - (if method - (guarantee-unparser-method method - 'SET-RECORD-TYPE-ENTITY-UNPARSER-METHOD!)) + (if (and method (not (unparser-method? method))) + (error:not-a unparser-method? method + 'SET-RECORD-TYPE-ENTITY-UNPARSER-METHOD!)) (let ((tag (%record-type-dispatch-tag record-type))) (remove-generic-procedure-generators record-entity-unparser (list tag)) (if method @@ -372,7 +373,7 @@ USA. (define (set-record-type-describer! record-type describer) (guarantee-record-type record-type 'SET-RECORD-TYPE-DESCRIBER!) (if describer - (guarantee-procedure-of-arity describer 1 'SET-RECORD-TYPE-DESCRIBER!)) + (guarantee unary-procedure? describer 'SET-RECORD-TYPE-DESCRIBER!)) (define-unary-generic-handler record-description record-type describer)) (define (record-entity-description entity) @@ -390,8 +391,7 @@ USA. (define (set-record-type-entity-describer! record-type describer) (guarantee-record-type record-type 'SET-RECORD-TYPE-ENTITY-DESCRIBER!) (if describer - (guarantee-procedure-of-arity describer 1 - 'SET-RECORD-TYPE-ENTITY-DESCRIBER!)) + (guarantee unary-procedure? describer 'SET-RECORD-TYPE-ENTITY-DESCRIBER!)) (define-unary-generic-handler record-entity-describer record-type ;; Kludge to make generic dispatch work. (lambda (extra) @@ -415,7 +415,8 @@ USA. (equal? field-names (record-type-field-names record-type))) (%record-constructor-default-names record-type) (begin - (guarantee-list field-names 'RECORD-CONSTRUCTOR) + (if (not (list? field-names)) + (error:not-a list? field-names 'RECORD-CONSTRUCTOR)) (%record-constructor-given-names record-type field-names)))) (define %record-constructor-default-names @@ -524,7 +525,7 @@ USA. (symbol? (car kl)) (pair? (cdr kl)))) (if (not (null? kl)) - (error:not-keyword-list keyword-list constructor))) + (error:not-a keyword-list? keyword-list constructor))) (let ((i (record-type-field-index record-type (car kl) #t))) (if (not (vector-ref seen? i)) (begin @@ -620,7 +621,6 @@ USA. (else (error "Improper list.")))) #t)))) -(define-guarantee list-of-unique-symbols "list of unique symbols") (define-guarantee record-type "record type") (define-guarantee record "record") @@ -773,7 +773,7 @@ USA. (do ((args arguments (cddr args))) ((not (pair? args))) (if (not (pair? (cdr args))) - (error:not-keyword-list arguments #f)) + (error:not-a keyword-list? arguments #f)) (let ((field-name (car args))) (let loop ((i 0)) (if (not (fix:< i n)) diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index 40ddb5798..5e0930e98 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -443,7 +443,7 @@ USA. ((dequeue! queue) repl))))) (define (run-in-nearest-repl procedure) - (guarantee-procedure-of-arity procedure 1 'run-in-nearest-repl) + (guarantee unary-procedure? procedure 'run-in-nearest-repl) (enqueue! (repl/input-queue (nearest-repl)) procedure)) (define (repl-read #!optional environment repl) @@ -520,13 +520,11 @@ USA. (if (default-object? repl) (nearest-repl) (begin - (guarantee-repl repl caller) + (guarantee repl? repl caller) repl)))) (values (if (default-object? environment) (repl/environment repl) - (begin - (guarantee-environment environment caller) - environment)) + (guarantee environment? environment caller)) repl))) (define (repl/start repl #!optional message) diff --git a/src/runtime/rexp.scm b/src/runtime/rexp.scm index bce01aca0..583aff844 100644 --- a/src/runtime/rexp.scm +++ b/src/runtime/rexp.scm @@ -43,7 +43,7 @@ USA. (rexp? (cadr rexp)))))) (case (car rexp) ((ALTERNATIVES SEQUENCE) - (for-all? (cdr rexp) rexp?)) + (every rexp? (cdr rexp))) ((GROUP OPTIONAL * +) (and (one-arg) (not (or (and (string? rexp) @@ -242,8 +242,8 @@ USA. (apply char-set chars*)))) (define (rexp-n*m n m . rexps) - (guarantee-exact-nonnegative-integer n 'REXP-N*M) - (guarantee-exact-nonnegative-integer m 'REXP-N*M) + (guarantee exact-nonnegative-integer? n 'REXP-N*M) + (guarantee exact-nonnegative-integer? m 'REXP-N*M) (if (not (<= n m)) (error:bad-range-argument m 'REXP-N*M)) (let ((rexp (apply rexp-sequence rexps))) @@ -262,7 +262,7 @@ USA. (apply rexp-n*m 0 n rexps)) (define (rexp-n* n . rexps) - (guarantee-exact-nonnegative-integer n 'REXP-N*) + (guarantee exact-nonnegative-integer? n 'REXP-N*) (let ((rexp (apply rexp-sequence rexps))) (if (= n 0) (rexp* rexp) diff --git a/src/runtime/rfc2822-headers.scm b/src/runtime/rfc2822-headers.scm index 2d8535c9e..ffb880dc4 100644 --- a/src/runtime/rfc2822-headers.scm +++ b/src/runtime/rfc2822-headers.scm @@ -68,20 +68,14 @@ USA. (loop (fix:+ i 1))) #t)))) -(define (guarantee-rfc2822-headers object #!optional caller) - (guarantee-list-of-type object - rfc2822-header? - "list of RFC 2822 header fields" - caller)) - (define (first-rfc2822-header name headers) - (guarantee-rfc2822-headers headers 'FIRST-RFC2822-HEADER) + (guarantee-list-of rfc2822-header? headers 'FIRST-RFC2822-HEADER) (find (lambda (header) (eq? (rfc2822-header-name header) name)) headers)) (define (all-rfc2822-headers name headers) - (guarantee-rfc2822-headers headers 'ALL-RFC2822-HEADERS) + (guarantee-list-of rfc2822-header? headers 'ALL-RFC2822-HEADERS) (filter (lambda (header) (eq? (rfc2822-header-name header) name)) headers)) @@ -94,7 +88,7 @@ USA. (write-rfc2822-headers headers port)))) (define (write-rfc2822-headers headers port) - (guarantee-rfc2822-headers headers 'WRITE-RFC2822-HEADERS) + (guarantee-list-of rfc2822-header? headers 'WRITE-RFC2822-HEADERS) (for-each (lambda (header) (write-header header port)) headers) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 043e464ba..39d76e98f 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -121,8 +121,6 @@ USA. (define-package (runtime boolean) (files "boole") (parent (runtime)) - (export () deprecated:boolean - guarantee-boolean) (export () (false? not) boolean/and @@ -130,17 +128,12 @@ USA. boolean=? boolean? false - for-all? not - there-exists? true)) (define-package (runtime boot-definitions) (files "boot") (parent (runtime)) - (export () deprecated:boot-definitions - error:not-unparser-method - guarantee-unparser-method) (export () bracketed-unparser-method default-object @@ -184,14 +177,7 @@ USA. (parent (runtime)) (export () deprecated:fixnum-arithmetic (largest-fixnum fix:largest-value) - (smallest-fixnum fix:smallest-value) - guarantee-fixnum - guarantee-index-fixnum - guarantee-limited-index-fixnum - guarantee-negative-fixnum - guarantee-non-negative-fixnum - guarantee-non-positive-fixnum - guarantee-positive-fixnum) + (smallest-fixnum fix:smallest-value)) (export () (exact-integer? int:integer?) ->flonum @@ -292,6 +278,7 @@ USA. flo:y1 flo:yn flo:zero? + guarantee-limited-index-fixnum index-fixnum? int:* int:+ @@ -442,9 +429,6 @@ USA. (define-package (runtime miscellaneous-global) (files "global") (parent (runtime)) - (export () deprecated:miscellaneous-global - error:not-hook-list - guarantee-hook-list) (export () %exit %quit @@ -632,16 +616,6 @@ USA. (define-package (runtime simple-file-ops) (files "sfile") (parent (runtime)) - (export () deprecated:simple-file-ops - error:not-mime-token - error:not-mime-token-string - error:not-mime-type - error:not-mime-type-string - guarantee-init-file-specifier - guarantee-mime-token - guarantee-mime-token-string - guarantee-mime-type - guarantee-mime-type-string) (export () allocate-temporary-file @@ -709,13 +683,7 @@ USA. (export () deprecated:symbol (substring->symbol string->symbol) (symbol-append symbol) - (symbol-name symbol->string) - error:not-interned-symbol - error:not-symbol - error:not-uninterned-symbol - guarantee-interned-symbol - guarantee-symbol - guarantee-uninterned-symbol) + (symbol-name symbol->string)) (export () intern intern-soft @@ -733,8 +701,6 @@ USA. (define-package (runtime microcode-data) (files "udata") (parent (runtime)) - (export () deprecated:microcode-data - guarantee-promise) (export () compiled-code-address->block compiled-code-address->offset @@ -790,9 +756,6 @@ USA. (define-package (runtime vector) (files "vector") (parent (runtime)) - (export () deprecated:vector - guarantee-vector - guarantee-vector-of-unique-symbols) (export () for-each-vector-element guarantee-subvector @@ -1209,17 +1172,7 @@ USA. (parent (runtime)) (export () deprecated:character (code->char integer->char) - (error:not-wide-char error:not-unicode-char) - (guarantee-wide-char guarantee-unicode-char) - (wide-char? unicode-char?) - error:not-char - error:not-radix - error:not-unicode-char - error:not-unicode-scalar-value - guarantee-char - guarantee-radix - guarantee-unicode-char - guarantee-unicode-scalar-value) + (wide-char? unicode-char?)) (export () 8-bit-char? ascii-char? @@ -1376,9 +1329,7 @@ USA. (chars->char-set char-set*) (scalar-values->char-set char-set*) (well-formed-scalar-value-list? code-point-list?) - char-set-member? - error:not-8-bit-char-set - guarantee-8-bit-char-set) + char-set-member?) (export () 8-bit-char-set? ascii-range->char-set @@ -1502,9 +1453,6 @@ USA. (define-package (runtime continuation) (files "contin") (parent (runtime)) - (export () deprecated:continuation - error:not-continuation - guarantee-continuation) (export () call-with-current-continuation continuation/block-thread-events? @@ -1578,11 +1526,6 @@ USA. (define-package (runtime date/time) (files "datime") (parent (runtime)) - (export () deprecated:date/time - error:not-decoded-time - error:not-time-zone - guarantee-decoded-time - guarantee-time-zone) (export () (decode-universal-time universal-time->local-decoded-time) (decoded-time->string decoded-time->rfc2822-string) @@ -1748,19 +1691,6 @@ USA. (define-package (runtime procedure) (files "uproc") (parent (runtime)) - (export () deprecated:procedure - error:not-compiled-procedure - error:not-compound-procedure - error:not-primitive-procedure - error:not-procedure - error:not-procedure-arity - error:not-thunk - guarantee-compiled-procedure - guarantee-compound-procedure - guarantee-primitive-procedure - guarantee-procedure - guarantee-procedure-arity - guarantee-thunk) (export () %entity-extra %entity-procedure @@ -1949,8 +1879,6 @@ USA. (define-package (runtime environment) (files "uenvir") (parent (runtime)) - (export () deprecated:environment - guarantee-environment) (export () compiled-procedure/environment environment-arguments @@ -2392,9 +2320,6 @@ USA. (parent (runtime)) (import (runtime population) add-to-population!/unsafe) - (export () deprecated:hash-table - error:not-hash-table - guarantee-hash-table) (export () (eq-hash-table-type key-weak-eq-hash-table-type) (eqv-hash-table-type key-weak-eqv-hash-table-type) @@ -2636,10 +2561,6 @@ USA. (port/with-input-terminal-mode with-input-port-terminal-mode) (port/with-output-blocking-mode with-output-port-blocking-mode) (port/with-output-terminal-mode with-output-port-terminal-mode) - guarantee-i/o-port - guarantee-input-port - guarantee-output-port - guarantee-port set-current-input-port! set-current-output-port! set-interaction-i/o-port! @@ -2862,23 +2783,6 @@ USA. (define-package (runtime list) (files "list") (parent (runtime)) - (export () deprecated:list - error:not-alist - error:not-circular-list - error:not-dotted-list - error:not-keyword-list - error:not-list - error:not-pair - error:not-unique-keyword-list - error:not-weak-list - guarantee-alist - guarantee-circular-list - guarantee-dotted-list - guarantee-keyword-list - guarantee-list - guarantee-pair - guarantee-unique-keyword-list - guarantee-weak-list) (export () (improper-list? dotted-list?) (list-search-negative find-non-matching-item) @@ -3057,11 +2961,6 @@ USA. (define-package (runtime lambda-list) (files "lambda-list") (parent (runtime)) - (export () deprecated:lambda-list - error:not-mit-lambda-list - error:not-r4rs-lambda-list - guarantee-mit-lambda-list - guarantee-r4rs-lambda-list) (export () lambda-tag:aux lambda-tag:key @@ -3079,6 +2978,9 @@ USA. (define-package (runtime srfi-1) (files "srfi-1") (parent (runtime)) + (export () deprecated:srfi-1 + for-all? + there-exists?) (export () any append-reverse @@ -3262,37 +3164,6 @@ USA. (define-package (runtime number) (files "arith" "dragon4") (parent (runtime)) - (export () deprecated:number - error:not-complex - error:not-exact - error:not-exact-integer - error:not-exact-nonnegative-integer - error:not-exact-positive-integer - error:not-exact-rational - error:not-inexact - error:not-integer - error:not-negative - error:not-non-negative - error:not-non-positive - error:not-number - error:not-positive - error:not-rational - error:not-real - guarantee-complex - guarantee-exact - guarantee-exact-integer - guarantee-exact-nonnegative-integer - guarantee-exact-positive-integer - guarantee-exact-rational - guarantee-inexact - guarantee-integer - guarantee-negative - guarantee-non-negative - guarantee-non-positive - guarantee-number - guarantee-positive - guarantee-rational - guarantee-real) (export () (-1+ complex:-1+) (1+ complex:1+) @@ -3484,9 +3355,6 @@ USA. (define-package (runtime parser-table) (files "partab") (parent (runtime)) - (export () deprecated:parser-table - error:not-parser-table - guarantee-parser-table) (export () make-parser-table parser-table/copy @@ -3500,9 +3368,6 @@ USA. (define-package (runtime pathname) (files "pathnm") (parent (runtime)) - (export () deprecated:pathname - error:not-pathname - guarantee-pathname) (export () *default-pathname-defaults* ->namestring @@ -3620,13 +3485,6 @@ USA. (define-package (runtime primitive-io) (files "io") (parent (runtime)) - (export () deprecated:primitive-io - error:not-channel - error:not-directory-channel - error:not-dld-handle - guarantee-channel - guarantee-directory-channel - guarantee-dld-handle) (export () all-dld-handles all-open-channels @@ -3816,13 +3674,6 @@ USA. (define-package (runtime record) (files "record") (parent (runtime)) - (export () deprecated:record - error:not-list-of-unique-symbols - error:not-record - error:not-record-type - guarantee-list-of-unique-symbols - guarantee-record - guarantee-record-type) (export () %copy-record %make-record @@ -3921,11 +3772,6 @@ USA. (define-package (runtime rep) (files "rep") (parent (runtime)) - (export () deprecated:rep - error:not-cmdl - error:not-repl - guarantee-cmdl - guarantee-repl) (export () ->environment abort->nearest @@ -4541,9 +4387,6 @@ USA. (define-package (runtime stream) (files "stream") (parent (runtime)) - (export () deprecated:stream - error:not-stream-pair - guarantee-stream-pair) (export () condition-type:illegal-stream-element empty-stream? @@ -4608,13 +4451,6 @@ USA. (define-package (runtime syntax top-level) (files "syntax") (parent (runtime syntax)) - (export () deprecated:syntax-top-level - error:not-identifier - error:not-syntactic-closure - error:not-synthetic-identifier - guarantee-identifier - guarantee-syntactic-closure - guarantee-synthetic-identifier) (export () capture-syntactic-environment @@ -4693,9 +4529,6 @@ USA. (define-package (runtime syntax environment) (files "syntax-environment") (parent (runtime syntax)) - (export () deprecated:syntax-environment - error:not-syntactic-environment - guarantee-syntactic-environment) (export () syntactic-environment?) (export (runtime syntax) @@ -5018,8 +4851,6 @@ USA. (define-package (runtime thread) (files "thread-low" "thread") (parent (runtime)) - (export () deprecated:thread - guarantee-thread) (export () assert-thread-mutex-owned block-thread-events @@ -5260,9 +5091,6 @@ USA. (define-package (runtime generic-procedure) (files "gentag" "gencache" "generic") (parent (runtime)) - (export () deprecated:generic-procedure - ;; tag.scm: - guarantee-dispatch-tag) (export () dispatch-tag-contents dispatch-tag? @@ -5402,9 +5230,6 @@ USA. (define-package (runtime regular-sexpression) (files "regsexp") (parent (runtime)) - (export () deprecated:regular-sexpression - error:not-compiled-regsexp - guarantee-compiled-regsexp) (export () compile-regsexp compiled-regsexp? @@ -5601,24 +5426,6 @@ USA. (define-package (runtime uri) (files "url") (parent (runtime)) - (export () deprecated:uri - error:not-partial-uri - error:not-uri-authority - error:not-uri-host - error:not-uri-path - error:not-uri-port - error:not-uri-scheme - error:not-uri-userinfo - guarantee-absolute-uri - guarantee-partial-uri - guarantee-relative-uri - guarantee-uri - guarantee-uri-authority - guarantee-uri-host - guarantee-uri-path - guarantee-uri-port - guarantee-uri-scheme - guarantee-uri-userinfo) (export () (url:decode-string decode-component) (url:match:escape matcher:pct-encoded) @@ -5733,9 +5540,6 @@ USA. (define-package (runtime rfc2822-headers) (files "rfc2822-headers") (parent (runtime)) - (export () deprecated:rfc2822-headers - error:not-rfc2822-header - guarantee-rfc2822-header) (export () all-rfc2822-headers char-set:rfc2822-name @@ -5759,26 +5563,12 @@ USA. (define-package (runtime http-syntax) (files "http-syntax") (parent (runtime)) - (export () deprecated:http-syntax - error:not-http-header - error:not-http-status - error:not-http-text - error:not-http-token - error:not-http-token-string - error:not-http-version - guarantee-http-header - guarantee-http-status - guarantee-http-text - guarantee-http-token - guarantee-http-token-string - guarantee-http-version) (export () char-set:http-text char-set:http-token convert-http-headers default-http-user-agent - guarantee-http-headers http-header http-header-name http-header-parsed-value @@ -5810,21 +5600,6 @@ USA. (define-package (runtime http-i/o) (files "httpio") (parent (runtime)) - (export () deprecated:http-i/o - error:not-http-message - error:not-http-request - error:not-http-request-uri - error:not-http-response - error:not-simple-http-request - error:not-simple-http-request-uri - error:not-simple-http-response - guarantee-http-message - guarantee-http-request - guarantee-http-request-uri - guarantee-http-response - guarantee-simple-http-request - guarantee-simple-http-request-uri - guarantee-simple-http-response) (export () http-message-body http-message-body-port @@ -5883,9 +5658,6 @@ USA. (define-package (runtime structure-parser) (files "structure-parser") (parent (runtime)) - (export () deprecated:structure-parser - error:not-structure-parser-values - guarantee-structure-parser-values) (export () apply-list-parser apply-object-parser diff --git a/src/runtime/scode.scm b/src/runtime/scode.scm index 37fc95859..834edca66 100644 --- a/src/runtime/scode.scm +++ b/src/runtime/scode.scm @@ -96,7 +96,7 @@ USA. ;;;; Variable (define (make-variable name) - (guarantee-symbol name 'MAKE-VARIABLE) + (guarantee symbol? name 'MAKE-VARIABLE) (system-hunk3-cons (ucode-type variable) name #t '())) (define (variable? object) @@ -114,7 +114,7 @@ USA. ;;;; Definition/Assignment (define (make-definition name value) - (guarantee-symbol name 'MAKE-DEFINITION) + (guarantee symbol? name 'MAKE-DEFINITION) (&typed-pair-cons (ucode-type definition) name value)) (define (definition? object) @@ -156,7 +156,7 @@ USA. (assignment-value assignment))) (define (make-assignment name value) - (guarantee-symbol name 'MAKE-ASSIGNMENT) + (guarantee symbol? name 'MAKE-ASSIGNMENT) (make-assignment-from-variable (make-variable name) value)) (define (assignment-name assignment) @@ -243,7 +243,7 @@ USA. ;;;; Access (define (make-access environment name) - (guarantee-symbol name 'MAKE-ACCESS) + (guarantee symbol? name 'MAKE-ACCESS) (&typed-pair-cons (ucode-type access) environment name)) (define (access? object) diff --git a/src/runtime/sfile.scm b/src/runtime/sfile.scm index fec7f0d94..619ed9888 100644 --- a/src/runtime/sfile.scm +++ b/src/runtime/sfile.scm @@ -237,16 +237,12 @@ USA. ;;;; Init files -(define (guarantee-init-file-specifier object procedure) - (if (not (init-file-specifier? object)) - (error:wrong-type-argument object "init-file specifier" procedure))) - (define (init-file-specifier? object) (and (list? object) - (for-all? object - (lambda (object) - (and (string? object) - (not (fix:= 0 (string-length object)))))))) + (every (lambda (object) + (and (string? object) + (not (fix:= 0 (string-length object))))) + object))) (define (guarantee-init-file-directory pathname) (let ((directory (user-homedir-pathname))) @@ -284,7 +280,7 @@ USA. (define (associate-pathname-type-with-mime-type type mime-type) (guarantee string? type 'ASSOCIATE-PATHNAME-TYPE-WITH-MIME-TYPE) - (guarantee-mime-type mime-type 'ASSOCIATE-PATHNAME-TYPE-WITH-MIME-TYPE) + (guarantee mime-type? mime-type 'ASSOCIATE-PATHNAME-TYPE-WITH-MIME-TYPE) (hash-table/put! local-type-map type mime-type)) (define (disassociate-pathname-type-from-mime-type type) @@ -298,8 +294,8 @@ USA. (subtype mime-type/subtype)) (define (make-mime-type top-level subtype) - (guarantee-mime-token top-level 'MAKE-MIME-TYPE) - (guarantee-mime-token subtype 'MAKE-MIME-TYPE) + (guarantee mime-token? top-level 'MAKE-MIME-TYPE) + (guarantee mime-token? subtype 'MAKE-MIME-TYPE) (%make-mime-type top-level subtype)) (define (%make-mime-type top-level subtype) @@ -354,14 +350,14 @@ USA. (write-mime-type mime-type port)))) (define (write-mime-type mime-type port) - (guarantee-mime-type mime-type 'WRITE-MIME-TYPE) + (guarantee mime-type? mime-type 'WRITE-MIME-TYPE) (write-string (symbol->string (mime-type/top-level mime-type)) port) (write-string "/" port) (write-string (symbol->string (mime-type/subtype mime-type)) port)) (define (string->mime-type string #!optional start end) (vector-ref (or (*parse-string parser:mime-type string start end) - (error:not-mime-type-string string 'STRING->MIME-TYPE)) + (error:not-a mime-type-string? string 'STRING->MIME-TYPE)) 0)) (define (mime-type-string? object) @@ -396,9 +392,4 @@ USA. (*parser (map intern (match matcher:mime-token)))) (define matcher:mime-token - (*matcher (* (char-set char-set:mime-token)))) - -(define-guarantee mime-type "MIME type") -(define-guarantee mime-type-string "MIME type string") -(define-guarantee mime-token "MIME token") -(define-guarantee mime-token-string "MIME token string") \ No newline at end of file + (*matcher (* (char-set char-set:mime-token)))) \ No newline at end of file diff --git a/src/runtime/srfi-1.scm b/src/runtime/srfi-1.scm index 34521b684..6c43f3bbf 100644 --- a/src/runtime/srfi-1.scm +++ b/src/runtime/srfi-1.scm @@ -245,7 +245,7 @@ USA. ;;;; Selectors (define (take lis k) - (guarantee-index-fixnum k 'TAKE) + (guarantee index-fixnum? k 'TAKE) (let recur ((lis lis) (k k)) (if (fix:> k 0) (cons (car lis) @@ -253,7 +253,7 @@ USA. '()))) (define (drop lis k) - (guarantee-index-fixnum k 'DROP) + (guarantee index-fixnum? k 'DROP) (%drop lis k)) (define (%drop lis k) @@ -263,7 +263,7 @@ USA. lis))) (define (take! lis k) - (guarantee-index-fixnum k 'TAKE!) + (guarantee index-fixnum? k 'TAKE!) (if (fix:> k 0) (begin (set-cdr! (drop lis (fix:- k 1)) '()) @@ -275,14 +275,14 @@ USA. ;;; the end. (define (take-right lis k) - (guarantee-index-fixnum k 'TAKE-RIGHT) + (guarantee index-fixnum? k 'TAKE-RIGHT) (let lp ((lag lis) (lead (%drop lis k))) (if (pair? lead) (lp (cdr lag) (cdr lead)) lag))) (define (drop-right lis k) - (guarantee-index-fixnum k 'DROP-RIGHT) + (guarantee index-fixnum? k 'DROP-RIGHT) (let recur ((lag lis) (lead (%drop lis k))) (if (pair? lead) (cons (car lag) (recur (cdr lag) (cdr lead))) @@ -292,7 +292,7 @@ USA. ;;; us stop LAG one step early, in time to smash its cdr to (). (define (drop-right! lis k) - (guarantee-index-fixnum k 'DROP-RIGHT!) + (guarantee index-fixnum? k 'DROP-RIGHT!) (let ((lead (%drop lis k))) (if (pair? lead) ;; Standard case @@ -306,7 +306,7 @@ USA. '()))) (define (split-at x k) - (guarantee-index-fixnum k 'SPLIT-AT) + (guarantee index-fixnum? k 'SPLIT-AT) (let recur ((lis x) (k k)) (if (fix:> k 0) (receive (prefix suffix) (recur (cdr lis) (fix:- k 1)) @@ -314,7 +314,7 @@ USA. (values '() lis)))) (define (split-at! x k) - (guarantee-index-fixnum k 'SPLIT-AT!) + (guarantee index-fixnum? k 'SPLIT-AT!) (if (fix:> k 0) (let* ((prev (%drop x (fix:- k 1))) (suffix (cdr prev))) @@ -1060,4 +1060,12 @@ USA. (loop (cdr lists) (cons (caar lists) cars) (cons (cdar lists) cdrs)) - (values (reverse! cars) (reverse! cdrs))))) \ No newline at end of file + (values (reverse! cars) (reverse! cdrs))))) + +;;;; Backwards compatibility + +(define (there-exists? items predicate) + (any predicate items)) + +(define (for-all? items predicate) + (every predicate items)) \ No newline at end of file diff --git a/src/runtime/stream.scm b/src/runtime/stream.scm index 2b592cf39..9a6f6edc6 100644 --- a/src/runtime/stream.scm +++ b/src/runtime/stream.scm @@ -36,11 +36,11 @@ USA. (define-guarantee stream-pair "stream pair") (define (stream-car stream) - (guarantee-stream-pair stream 'STREAM-CAR) + (guarantee stream-pair? stream 'STREAM-CAR) (car stream)) (define (stream-cdr stream) - (guarantee-stream-pair stream 'STREAM-CDR) + (guarantee stream-pair? stream 'STREAM-CDR) (force (cdr stream))) (define the-empty-stream '()) @@ -70,7 +70,7 @@ USA. (car tail))) (define (stream-head stream index) - (guarantee-exact-nonnegative-integer index 'STREAM-HEAD) + (guarantee exact-nonnegative-integer? index 'STREAM-HEAD) (let loop ((stream stream) (index index)) (if (> index 0) (begin @@ -81,7 +81,7 @@ USA. '()))) (define (stream-tail stream index) - (guarantee-exact-nonnegative-integer index 'STREAM-TAIL) + (guarantee exact-nonnegative-integer? index 'STREAM-TAIL) (let loop ((stream stream) (index index)) (if (> index 0) (begin @@ -261,7 +261,7 @@ USA. (cons-stream (car list) (list->stream (cdr list))) (begin (if (not (null? list)) - (error:not-list list 'LIST->STREAM)) + (error:not-a list? list 'LIST->STREAM)) '()))) (define (stream->list stream) diff --git a/src/runtime/structure-parser.scm b/src/runtime/structure-parser.scm index 71591920f..da4bbcb6c 100644 --- a/src/runtime/structure-parser.scm +++ b/src/runtime/structure-parser.scm @@ -642,9 +642,9 @@ USA. (loop (cdr vals*) tail)))) (else - (error:not-structure-parser-values - vals - 'STRUCTURE-PARSER-VALUES->LIST))))) + (error:not-a structure-parser-values? + vals + 'STRUCTURE-PARSER-VALUES->LIST))))) (define (list->structure-parser-values items) (map (lambda (item) @@ -665,8 +665,8 @@ USA. (cons (loop (car vals*)) (loop (cdr vals*))))) (else - (error:not-structure-parser-values vals - 'MAP-STRUCTURE-PARSER-VALUES))))) + (error:not-a structure-parser-values? vals + 'MAP-STRUCTURE-PARSER-VALUES))))) (define (structure-parser-values? object) (let loop ((object object)) @@ -676,8 +676,6 @@ USA. (and (loop (car object)) (loop (cdr object)))))))) -(define-guarantee structure-parser-values "object-parser values") - (define (structure-parser-values-length vals) (let loop ((vals* vals)) (cond ((null? vals*) @@ -688,9 +686,9 @@ USA. (+ (loop (car vals*)) (loop (cdr vals*))))) (else - (error:not-structure-parser-values - vals - 'STRUCTURE-PARSER-VALUES-LENGTH))))) + (error:not-a structure-parser-values? + vals + 'STRUCTURE-PARSER-VALUES-LENGTH))))) (define (structure-parser-values-ref vals index) (let ((caller 'STRUCTURE-PARSER-VALUES-REF)) @@ -705,7 +703,7 @@ USA. (cdr vals*)) (push vals* i stack))) (else - (error:not-structure-parser-values vals caller)))) + (error:not-a structure-parser-values? vals caller)))) (define (push vals* i stack) (loop (car vals*) diff --git a/src/runtime/syntax-environment.scm b/src/runtime/syntax-environment.scm index d2747895b..a8c42782a 100644 --- a/src/runtime/syntax-environment.scm +++ b/src/runtime/syntax-environment.scm @@ -51,7 +51,7 @@ USA. ((syntactic-environment? object) object) (else - (error:not-syntactic-environment object caller)))) + (error:not-a syntactic-environment? object caller)))) (define (senv-type senv) ((senv-ops:type (senv-ops senv)) (senv-state senv))) @@ -108,7 +108,7 @@ USA. ;;; modified. (define (runtime-environment->syntactic-environment env) - (guarantee-environment env 'environment->syntactic-environment) + (guarantee environment? env 'environment->syntactic-environment) (make-senv runtime-senv-ops env)) (define runtime-senv-ops @@ -134,7 +134,7 @@ USA. ;;; They are always layered over a real syntactic environment. (define (make-top-level-syntactic-environment parent) - (guarantee-syntactic-environment parent 'make-top-level-syntactic-environment) + (guarantee syntactic-environment? parent 'make-top-level-syntactic-environment) (if (not (let ((type (senv-type parent))) (or (eq? type 'top-level) (eq? type 'runtime-top-level) @@ -175,7 +175,7 @@ USA. ;;; procedure application. (define (make-internal-syntactic-environment parent) - (guarantee-syntactic-environment parent 'make-internal-syntactic-environment) + (guarantee syntactic-environment? parent 'make-internal-syntactic-environment) (make-senv internal-senv-ops (make-internal-state parent '() '() (make-rename-id)))) @@ -226,11 +226,11 @@ USA. ;;; closures that have free names. (define (make-partial-syntactic-environment names names-senv else-senv) - (guarantee-list-of-unique-symbols names 'make-partial-syntactic-environment) - (guarantee-syntactic-environment names-senv - 'make-partial-syntactic-environment) - (guarantee-syntactic-environment else-senv - 'make-partial-syntactic-environment) + (guarantee list-of-unique-symbols? names 'make-partial-syntactic-environment) + (guarantee syntactic-environment? names-senv + 'make-partial-syntactic-environment) + (guarantee syntactic-environment? else-senv + 'make-partial-syntactic-environment) (if (or (null? names) (eq? names-senv else-senv)) else-senv diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm index 8e71ed5bd..69cdb70de 100644 --- a/src/runtime/syntax.scm +++ b/src/runtime/syntax.scm @@ -47,7 +47,7 @@ USA. (syntax* (list form) environment)) (define (syntax* forms environment) - (guarantee-list forms 'SYNTAX*) + (guarantee list? forms 'SYNTAX*) (let ((senv (->syntactic-environment environment 'SYNTAX*))) (parameterize* (list (cons *rename-database* (initial-rename-database))) (lambda () @@ -133,7 +133,7 @@ USA. (loop (syntactic-closure/form identifier)) (and (symbol? identifier) identifier))) - (error:not-identifier identifier 'IDENTIFIER->SYMBOL))) + (error:not-a identifier? identifier 'IDENTIFIER->SYMBOL))) (define (identifier=? environment-1 identifier-1 environment-2 identifier-2) (let ((item-1 (lookup-identifier identifier-1 environment-1)) @@ -161,7 +161,7 @@ USA. (lookup-identifier (syntactic-closure/form identifier) (syntactic-closure/environment identifier))) (else - (error:not-identifier identifier 'LOOKUP-IDENTIFIER))))) + (error:not-a identifier? identifier 'LOOKUP-IDENTIFIER))))) ;;;; Utilities diff --git a/src/runtime/thread-barrier.scm b/src/runtime/thread-barrier.scm index c92496b71..be418072a 100644 --- a/src/runtime/thread-barrier.scm +++ b/src/runtime/thread-barrier.scm @@ -38,10 +38,8 @@ USA. current (generation 0)) -(define-guarantee thread-barrier "thread barrier") - (define (make-thread-barrier count #!optional name) - (guarantee-exact-positive-integer count 'MAKE-THREAD-BARRIER) + (guarantee exact-positive-integer? count 'MAKE-THREAD-BARRIER) (let ((current count) (condvar (make-condition-variable @@ -49,7 +47,7 @@ USA. (%make-thread-barrier count current condvar))) (define (thread-barrier-wait barrier) - (guarantee-thread-barrier barrier 'THREAD-BARRIER-WAIT) + (guarantee thread-barrier? barrier 'THREAD-BARRIER-WAIT) (let ((lock (thread-barrier.lock barrier)) (condvar (thread-barrier.condvar barrier))) (with-thread-mutex-lock lock diff --git a/src/runtime/thread-queue.scm b/src/runtime/thread-queue.scm index 9b1c5d4f9..b5b5fd560 100644 --- a/src/runtime/thread-queue.scm +++ b/src/runtime/thread-queue.scm @@ -151,7 +151,7 @@ USA. (define (thread-queue/dequeue-no-hang! queue msec) (guarantee-thread-queue queue 'thread-queue/dequeue-no-hang!) - (guarantee-non-negative-fixnum msec 'thread-queue/dequeue-no-hang!) + (guarantee non-negative-fixnum? msec 'thread-queue/dequeue-no-hang!) (thread-queue/dequeue-until! queue (+ (real-time-clock) (internal-time/seconds->ticks (/ msec 1000))))) @@ -192,7 +192,7 @@ USA. (define (thread-queue/peek-no-hang queue msec) (guarantee-thread-queue queue 'thread-queue/peek-no-hang) - (guarantee-non-negative-fixnum msec 'thread-queue/peek-no-hang) + (guarantee non-negative-fixnum? msec 'thread-queue/peek-no-hang) (thread-queue/peek-until queue (+ (real-time-clock) (internal-time/seconds->ticks (/ msec 1000))))) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 13e32e45c..bed9c0fb0 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -93,15 +93,11 @@ USA. (properties #f read-only #t)) -(define-integrable (guarantee-thread thread procedure) - (if (not (thread? thread)) - (error:wrong-type-argument thread "thread" procedure))) - (define no-exit-value-marker (list 'NO-EXIT-VALUE-MARKER)) (define (thread-dead? thread) - (guarantee-thread thread 'THREAD-DEAD?) + (guarantee thread? thread 'THREAD-DEAD?) (eq? 'DEAD (thread/execution-state thread))) (define thread-population) @@ -200,7 +196,7 @@ USA. (map-over-population thread-population (lambda (thread) thread))) (define (thread-execution-state thread) - (guarantee-thread thread 'THREAD-EXECUTION-STATE) + (guarantee thread? thread 'THREAD-EXECUTION-STATE) (thread/execution-state thread)) (define (create-thread root-continuation thunk) @@ -274,7 +270,7 @@ USA. (thread/next (current-thread))) (define (thread-continuation thread) - (guarantee-thread thread 'THREAD-CONTINUATION) + (guarantee thread? thread 'THREAD-CONTINUATION) (without-interrupts (lambda () (and (eq? 'WAITING (thread/execution-state thread)) @@ -360,7 +356,7 @@ USA. (thread-not-running thread 'STOPPED)))))))) (define (restart-thread thread discard-events? event) - (guarantee-thread thread 'RESTART-THREAD) + (guarantee thread? thread 'RESTART-THREAD) (let ((discard-events? (if (eq? discard-events? 'ASK) (prompt-for-confirmation @@ -484,7 +480,7 @@ USA. (thread-not-running thread 'DEAD))) (define (join-thread thread event-constructor) - (guarantee-thread thread 'JOIN-THREAD) + (guarantee thread? thread 'JOIN-THREAD) (let ((self (current-thread))) (if (eq? thread self) (signal-thread-deadlock self "join thread" join-thread thread) @@ -507,7 +503,7 @@ USA. (event-constructor thread value)))))))))) (define (detach-thread thread) - (guarantee-thread thread 'DETACH-THREAD) + (guarantee thread? thread 'DETACH-THREAD) (without-interrupts (lambda () (if (eq? (thread/exit-value thread) detached-thread-marker) @@ -682,7 +678,7 @@ USA. (define (register-io-thread-event descriptor mode thread event) (guarantee-select-mode mode 'REGISTER-IO-THREAD-EVENT) - (guarantee-thread thread 'REGISTER-IO-THREAD-EVENT) + (guarantee thread? thread 'REGISTER-IO-THREAD-EVENT) (without-interrupts (lambda () (let ((registration @@ -906,7 +902,7 @@ USA. unspecific))) (define (signal-thread-event thread event #!optional no-error?) - (guarantee-thread thread 'SIGNAL-THREAD-EVENT) + (guarantee thread? thread 'SIGNAL-THREAD-EVENT) (let ((self first-running-thread) (noerr? (and (not (default-object? no-error?)) no-error?))) @@ -1098,7 +1094,7 @@ USA. (define (set-thread-timer-interval! interval) (if interval - (guarantee-exact-positive-integer interval 'SET-THREAD-TIMER-INTERVAL!)) + (guarantee exact-positive-integer? interval 'SET-THREAD-TIMER-INTERVAL!)) (without-interrupts (lambda () (set! timer-interval interval) diff --git a/src/runtime/tvector.scm b/src/runtime/tvector.scm index 5c9ea1cb0..60ebdbca2 100644 --- a/src/runtime/tvector.scm +++ b/src/runtime/tvector.scm @@ -33,7 +33,7 @@ USA. ;;; calls to construct and access tagged vectors. (define (make-tagged-vector tag length) - (guarantee-dispatch-tag tag 'MAKE-TAGGED-VECTOR) + (guarantee dispatch-tag? tag 'MAKE-TAGGED-VECTOR) (guarantee-index-integer length 'MAKE-TAGGED-VECTOR) (let ((result (object-new-type (ucode-type record) @@ -43,7 +43,7 @@ USA. result)) (define (tagged-vector tag . elements) - (guarantee-dispatch-tag tag 'MAKE-TAGGED-VECTOR) + (guarantee dispatch-tag? tag 'MAKE-TAGGED-VECTOR) (object-new-type (ucode-type record) (apply vector tag elements))) (define (tagged-vector? object) @@ -56,7 +56,7 @@ USA. (define (set-tagged-vector-tag! vector tag) (guarantee-tagged-vector vector 'SET-TAGGED-VECTOR-TAG!) - (guarantee-dispatch-tag tag 'SET-TAGGED-VECTOR-TAG!) + (guarantee dispatch-tag? tag 'SET-TAGGED-VECTOR-TAG!) (%record-set! vector 0 tag)) (define (tagged-vector-length vector) diff --git a/src/runtime/udata.scm b/src/runtime/udata.scm index 502d93f57..11bdad46b 100644 --- a/src/runtime/udata.scm +++ b/src/runtime/udata.scm @@ -291,7 +291,7 @@ contains constants derived from the source program. (system-pair-car promise)) (define (force promise) - (guarantee-promise promise 'FORCE) + (guarantee promise? promise 'FORCE) (case (system-pair-car promise) ((#T) (system-pair-cdr promise)) diff --git a/src/runtime/uenvir.scm b/src/runtime/uenvir.scm index 3b71e5e35..0a090fba4 100644 --- a/src/runtime/uenvir.scm +++ b/src/runtime/uenvir.scm @@ -35,13 +35,6 @@ USA. (stack-ccenv? object) (closure-ccenv? object))) -(define (guarantee-environment object name) - (if (not (environment? object)) - (illegal-environment object name))) - -(define (illegal-environment object name) - (error:wrong-type-argument object "environment" name)) - (define (environment-has-parent? environment) (cond ((system-global-environment? environment) #f) @@ -52,7 +45,7 @@ USA. ((closure-ccenv? environment) (closure-ccenv/has-parent? environment)) (else - (illegal-environment environment 'ENVIRONMENT-HAS-PARENT?)))) + (error:not-a environment? environment 'ENVIRONMENT-HAS-PARENT?)))) (define (environment-parent environment) (cond ((system-global-environment? environment) @@ -64,7 +57,7 @@ USA. ((closure-ccenv? environment) (closure-ccenv/parent environment)) (else - (illegal-environment environment 'ENVIRONMENT-PARENT)))) + (error:not-a environment? environment 'ENVIRONMENT-PARENT)))) (define (environment-bound-names environment) (cond ((system-global-environment? environment) @@ -76,7 +69,7 @@ USA. ((closure-ccenv? environment) (closure-ccenv/bound-names environment)) (else - (illegal-environment environment 'ENVIRONMENT-BOUND-NAMES)))) + (error:not-a environment? environment 'ENVIRONMENT-BOUND-NAMES)))) (define (environment-macro-names environment) (cond ((system-global-environment? environment) @@ -87,7 +80,7 @@ USA. (closure-ccenv? environment)) '()) (else - (illegal-environment environment 'ENVIRONMENT-MACRO-NAMES)))) + (error:not-a environment? environment 'ENVIRONMENT-MACRO-NAMES)))) (define (environment-bindings environment) (let ((items (environment-bound-names environment))) @@ -112,7 +105,7 @@ USA. (closure-ccenv? environment)) 'UNKNOWN) (else - (illegal-environment environment 'ENVIRONMENT-ARGUMENTS)))) + (error:not-a environment? environment 'ENVIRONMENT-ARGUMENTS)))) (define (environment-procedure-name environment) (let ((scode-lambda (environment-lambda environment))) @@ -129,7 +122,7 @@ USA. ((closure-ccenv? environment) (closure-ccenv/lambda environment)) (else - (illegal-environment environment 'ENVIRONMENT-LAMBDA)))) + (error:not-a environment? environment 'ENVIRONMENT-LAMBDA)))) (define (environment-bound? environment name) (not (eq? 'UNBOUND (environment-reference-type environment name)))) @@ -142,7 +135,7 @@ USA. ((closure-ccenv? environment) (closure-ccenv/reference-type environment name)) (else - (illegal-environment environment 'ENVIRONMENT-REFERENCE-TYPE)))) + (error:not-a environment? environment 'ENVIRONMENT-REFERENCE-TYPE)))) (define (environment-assigned? environment name) (case (environment-reference-type environment name) @@ -179,7 +172,7 @@ USA. ((closure-ccenv? environment) (closure-ccenv/safe-lookup environment name)) (else - (illegal-environment environment 'ENVIRONMENT-SAFE-LOOKUP)))) + (error:not-a environment? environment 'ENVIRONMENT-SAFE-LOOKUP)))) (define (environment-assignable? environment name) (cond ((interpreter-environment? environment) @@ -189,7 +182,7 @@ USA. ((closure-ccenv? environment) (closure-ccenv/assignable? environment name)) (else - (illegal-environment environment 'ENVIRONMENT-ASSIGNABLE?)))) + (error:not-a environment? environment 'ENVIRONMENT-ASSIGNABLE?)))) (define (environment-assign! environment name value) (cond ((interpreter-environment? environment) @@ -199,13 +192,13 @@ USA. ((closure-ccenv? environment) (closure-ccenv/assign! environment name value)) (else - (illegal-environment environment 'ENVIRONMENT-ASSIGN!)))) + (error:not-a environment? environment 'ENVIRONMENT-ASSIGN!)))) (define (environment-definable? environment name) name (cond ((interpreter-environment? environment) #t) ((or (stack-ccenv? environment) (closure-ccenv? environment)) #f) - (else (illegal-environment environment 'ENVIRONMENT-DEFINABLE?)))) + (else (error:not-a environment? environment 'ENVIRONMENT-DEFINABLE?)))) (define (environment-define environment name value) (cond ((interpreter-environment? environment) @@ -214,7 +207,7 @@ USA. (closure-ccenv? environment)) (error:bad-range-argument environment 'ENVIRONMENT-DEFINE)) (else - (illegal-environment environment 'ENVIRONMENT-DEFINE)))) + (error:not-a environment? environment 'ENVIRONMENT-DEFINE)))) (define (environment-define-macro environment name value) (cond ((interpreter-environment? environment) @@ -223,7 +216,7 @@ USA. (closure-ccenv? environment)) (error:bad-range-argument environment 'ENVIRONMENT-DEFINE-MACRO)) (else - (illegal-environment environment 'ENVIRONMENT-DEFINE-MACRO)))) + (error:not-a environment? environment 'ENVIRONMENT-DEFINE-MACRO)))) ;;;; Global environment @@ -413,7 +406,7 @@ USA. (define (extend-top-level-environment environment #!optional names values) (if (not (interpreter-environment? environment)) - (illegal-environment environment 'EXTEND-TOP-LEVEL-ENVIRONMENT)) + (error:not-a environment? environment 'EXTEND-TOP-LEVEL-ENVIRONMENT)) (%extend-top-level-environment environment (if (default-object? names) '() names) (if (default-object? values) 'DEFAULT values) diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm index 115cea49e..1c8404b11 100644 --- a/src/runtime/unpars.scm +++ b/src/runtime/unpars.scm @@ -91,11 +91,10 @@ USA. unspecific)) (define (boolean-converter value) - (guarantee-boolean value) - value) + (guarantee boolean? value)) (define (limit-converter value) - (if value (guarantee-exact-positive-integer value)) + (if value (guarantee exact-positive-integer? value)) value) (define (radix-converter value) diff --git a/src/runtime/unsyn.scm b/src/runtime/unsyn.scm index 8b3c9b22b..e20d8a835 100644 --- a/src/runtime/unsyn.scm +++ b/src/runtime/unsyn.scm @@ -90,9 +90,9 @@ USA. (receiver environment))) (define (is-bound? name environment) - (there-exists? environment - (lambda (binding-lambda) - (lambda-bound? binding-lambda name)))) + (any (lambda (binding-lambda) + (lambda-bound? binding-lambda name)) + environment)) (define (unsyntax scode) (unsyntax-object '() @@ -466,7 +466,7 @@ USA. (pair? (cadr definition)) (eq? (caadr definition) (cadddr expression)) (list? (cdadr definition)) - (for-all? (cdadr definition) symbol?)))))) + (every symbol? (cdadr definition))))))) `(LET ,(cadddr (car expression)) ,(map (lambda (name value) `(,name diff --git a/src/runtime/unxprm.scm b/src/runtime/unxprm.scm index 657a9b705..2999dab3f 100644 --- a/src/runtime/unxprm.scm +++ b/src/runtime/unxprm.scm @@ -54,8 +54,7 @@ USA. (if (or (default-object? transformer) (not transformer)) identity-procedure (begin - (guarantee-procedure-of-arity transformer 1 - 'TEMPORARY-FILE-PATHNAME) + (guarantee unary-procedure? transformer 'TEMPORARY-FILE-PATHNAME) transformer)))) (let loop ((ext 0)) (let ((pathname @@ -411,7 +410,7 @@ USA. (set-file-modes! output-filename (file-modes input-filename)))) (define (init-file-specifier->pathname specifier) - (guarantee-init-file-specifier specifier 'INIT-FILE-SPECIFIER->PATHNAME) + (guarantee init-file-specifier? specifier 'INIT-FILE-SPECIFIER->PATHNAME) (merge-pathnames (apply string-append (cons ".mit-scheme" (append-map (lambda (string) (list "/" string)) diff --git a/src/runtime/uproc.scm b/src/runtime/uproc.scm index 862d5ac7f..60e19913f 100644 --- a/src/runtime/uproc.scm +++ b/src/runtime/uproc.scm @@ -155,19 +155,19 @@ USA. (procedure-arity-valid? object arity))) (define (guarantee-procedure-of-arity object arity caller) - (guarantee-procedure object caller) + (guarantee procedure? object caller) (if (not (procedure-arity-valid? object arity)) (error:bad-range-argument object caller))) (define (make-procedure-arity min #!optional max simple-ok?) - (guarantee-index-fixnum min 'MAKE-PROCEDURE-ARITY) + (guarantee index-fixnum? min 'MAKE-PROCEDURE-ARITY) (let ((max (if (default-object? max) min (begin (if max (begin - (guarantee-index-fixnum max 'MAKE-PROCEDURE-ARITY) + (guarantee index-fixnum? max 'MAKE-PROCEDURE-ARITY) (if (not (fix:>= max min)) (error:bad-range-argument max 'MAKE-PROCEDURE-ARITY)))) @@ -187,12 +187,12 @@ USA. (define (procedure-arity-min arity) (cond ((simple-arity? arity) arity) ((general-arity? arity) (car arity)) - (else (error:not-procedure-arity arity 'PROCEDURE-ARITY-MIN)))) + (else (error:not-a procedure-arity? arity 'PROCEDURE-ARITY-MIN)))) (define (procedure-arity-max arity) (cond ((simple-arity? arity) arity) ((general-arity? arity) (cdr arity)) - (else (error:not-procedure-arity arity 'PROCEDURE-ARITY-MAX)))) + (else (error:not-a procedure-arity? arity 'PROCEDURE-ARITY-MAX)))) (define (procedure-arity<= arity1 arity2) (and (fix:<= (procedure-arity-min arity2) @@ -251,7 +251,7 @@ USA. (define (%primitive-procedure-arg procedure caller) (let ((procedure* (skip-entities procedure))) - (guarantee-primitive-procedure procedure* caller) + (guarantee primitive-procedure? procedure* caller) procedure*)) (declare (integrate-operator %compound-procedure?)) diff --git a/src/runtime/url.scm b/src/runtime/url.scm index 5848e834e..e7ad9d4b5 100644 --- a/src/runtime/url.scm +++ b/src/runtime/url.scm @@ -43,9 +43,9 @@ USA. (define (make-uri scheme authority path query fragment) (let ((path (if (equal? path '("")) '() path))) - (if scheme (guarantee-uri-scheme scheme 'MAKE-URI)) - (if authority (guarantee-uri-authority authority 'MAKE-URI)) - (guarantee-uri-path path 'MAKE-URI) + (if scheme (guarantee uri-scheme? scheme 'MAKE-URI)) + (if authority (guarantee uri-authority? authority 'MAKE-URI)) + (guarantee uri-path? path 'MAKE-URI) (if query (guarantee string? query 'MAKE-URI)) (if fragment (guarantee string? fragment 'MAKE-URI)) (if (and authority (pair? path) (path-relative? path)) @@ -94,7 +94,7 @@ USA. (list-of-type? object string?)) (define (uri-path-absolute? path) - (guarantee-uri-path path 'URI-PATH-ABSOLUTE?) + (guarantee uri-path? path 'URI-PATH-ABSOLUTE?) (path-absolute? path)) (define (path-absolute? path) @@ -102,7 +102,7 @@ USA. (fix:= 0 (string-length (car path))))) (define (uri-path-relative? path) - (guarantee-uri-path path 'URI-PATH-RELATIVE?) + (guarantee uri-path? path 'URI-PATH-RELATIVE?) (path-relative? path)) (define-integrable (path-relative? path) @@ -123,9 +123,9 @@ USA. (write-uri-authority authority port))))))) (define (make-uri-authority userinfo host port) - (if userinfo (guarantee-uri-userinfo userinfo 'MAKE-URI-AUTHORITY)) - (guarantee-uri-host host 'MAKE-URI-AUTHORITY) - (if port (guarantee-uri-port port 'MAKE-URI-AUTHORITY)) + (if userinfo (guarantee uri-userinfo? userinfo 'MAKE-URI-AUTHORITY)) + (guarantee uri-host? host 'MAKE-URI-AUTHORITY) + (if port (guarantee uri-port? port 'MAKE-URI-AUTHORITY)) (hash-table/intern! interned-uri-authorities (call-with-output-string (lambda (output) @@ -156,8 +156,8 @@ USA. (->uri u2 'URI=?))) (define (uri-authority=? a1 a2) - (guarantee-uri-authority a1 'URI-AUTHORITY=?) - (guarantee-uri-authority a2 'URI-AUTHORITY=?) + (guarantee uri-authority? a1 'URI-AUTHORITY=?) + (guarantee uri-authority? a2 'URI-AUTHORITY=?) (eq? a1 a2)) (define (uri->alist uri) @@ -926,7 +926,7 @@ USA. (write-partial-uri puri port)))) (define (write-partial-uri puri port) - (guarantee-partial-uri puri 'WRITE-PARTIAL-URI) + (guarantee partial-uri? puri 'WRITE-PARTIAL-URI) (let ((write-component (lambda (component prefix suffix) (if component diff --git a/src/runtime/usrint.scm b/src/runtime/usrint.scm index 10ff5a143..f00a1698e 100644 --- a/src/runtime/usrint.scm +++ b/src/runtime/usrint.scm @@ -90,9 +90,7 @@ USA. (define (optional-environment environment caller) (if (default-object? environment) (nearest-repl/environment) - (begin - (guarantee-environment environment caller) - environment))) + (guarantee environment? environment caller))) (define (prompt-for-command-char prompt #!optional port) (let ((prompt (canonicalize-command-prompt prompt)) @@ -330,9 +328,7 @@ USA. (environment (if (default-object? environment) (nearest-repl/environment) - (begin - (guarantee-environment environment 'PORT/WRITE-RESULT) - environment)))) + (guarantee environment? environment 'PORT/WRITE-RESULT)))) (if operation (operation port expression value hash-number environment) (default/write-result port expression value hash-number environment)))) diff --git a/src/runtime/vector.scm b/src/runtime/vector.scm index 3e112b77d..9b20aca08 100644 --- a/src/runtime/vector.scm +++ b/src/runtime/vector.scm @@ -43,12 +43,8 @@ USA. (vector-set! 3) (vector? 1)) -(define-integrable (guarantee-vector object procedure) - (if (not (vector? object)) - (error:wrong-type-argument object "vector" procedure))) - (define-integrable (guarantee-subvector vector start end procedure) - (guarantee-vector vector procedure) + (guarantee vector? vector procedure) (if (not (index-fixnum? start)) (error:wrong-type-argument start "vector index" procedure)) (if (not (index-fixnum? end)) @@ -92,7 +88,7 @@ USA. vector) (define (vector-tail vector start) - (guarantee-vector vector 'VECTOR-TAIL) + (guarantee vector? vector 'VECTOR-TAIL) (subvector vector start (vector-length vector))) (define (vector-copy vector #!optional start end) @@ -109,7 +105,7 @@ USA. (let loop ((vectors vectors) (length 0)) (if (pair? vectors) (begin - (guarantee-vector (car vectors) 'VECTOR-APPEND) + (guarantee vector? (car vectors) 'VECTOR-APPEND) (loop (cdr vectors) (fix:+ (vector-length (car vectors)) length))) length))))) @@ -121,7 +117,7 @@ USA. result)))) (define (vector-grow vector length #!optional value) - (guarantee-vector vector 'VECTOR-GROW) + (guarantee vector? vector 'VECTOR-GROW) (if (not (index-fixnum? length)) (error:wrong-type-argument length "vector length" 'VECTOR-GROW)) (if (fix:< length (vector-length vector)) @@ -141,8 +137,8 @@ USA. vector)) (define (vector-map procedure vector . vectors) - (guarantee-vector vector 'VECTOR-MAP) - (for-each (lambda (v) (guarantee-vector v 'VECTOR-MAP)) vectors) + (guarantee vector? vector 'VECTOR-MAP) + (for-each (lambda (v) (guarantee vector? v 'VECTOR-MAP)) vectors) (let ((n (vector-length vector))) (for-each (lambda (v) (if (not (fix:= (vector-length v) n)) @@ -159,8 +155,8 @@ USA. result))) (define (vector-for-each procedure vector . vectors) - (guarantee-vector vector 'VECTOR-FOR-EACH) - (for-each (lambda (v) (guarantee-vector v 'VECTOR-FOR-EACH)) vectors) + (guarantee vector? vector 'VECTOR-FOR-EACH) + (for-each (lambda (v) (guarantee vector? v 'VECTOR-FOR-EACH)) vectors) (let ((n (vector-length vector))) (for-each (lambda (v) (if (not (fix:= (vector-length v) n)) @@ -208,15 +204,15 @@ USA. index)))) (define-integrable (vector-find-next-element vector item) - (guarantee-vector vector 'VECTOR-FIND-NEXT-ELEMENT) + (guarantee vector? vector 'VECTOR-FIND-NEXT-ELEMENT) (subvector-find-next-element vector 0 (vector-length vector) item)) (define-integrable (vector-find-previous-element vector item) - (guarantee-vector vector 'VECTOR-FIND-PREVIOUS-ELEMENT) + (guarantee vector? vector 'VECTOR-FIND-PREVIOUS-ELEMENT) (subvector-find-previous-element vector 0 (vector-length vector) item)) (define (vector-binary-search vector key s))) - (and (for-all? (specializer-classes (car s1)) - (lambda (c) - (subclass? c (car s2)))) + (every (lambda (s) (subclass? s)) s2) + (and (every (lambda (c) (subclass? c (car s2))) + (specializer-classes (car s1))) (loop (cdr s1) (cdr s2))))))) ;;;; Method Specializers @@ -270,7 +267,7 @@ USA. (define (specializers? object) (and (list? object) (not (null? object)) - (for-all? object specializer?))) + (every specializer? object))) (define (specializer? object) (or (class? object) @@ -309,8 +306,8 @@ USA. (specializer-classes s2))) (define (eq-set=? x y) - (and (for-all? x (lambda (x) (memq x y))) - (for-all? y (lambda (y) (memq y x))))) + (and (every (lambda (x) (memq x y)) x) + (every (lambda (y) (memq y x)) y))) (define (specializer-classes s) (cond ((class? s) diff --git a/src/ssp/mod-lisp.scm b/src/ssp/mod-lisp.scm index e8e5d57f3..50ad93d6b 100644 --- a/src/ssp/mod-lisp.scm +++ b/src/ssp/mod-lisp.scm @@ -640,7 +640,7 @@ USA. (hash-table/put! mime-handlers type handle-request)) ((and (pair? type) (symbol? (car type)) - (for-all? (cdr type) string?)) + (every string? (cdr type))) (hash-table/put! mime-handlers (car type) handle-request) (for-each (lambda (extension) (hash-table/put! mime-extensions extension (car type))) diff --git a/src/star-parser/shared.scm b/src/star-parser/shared.scm index b0e56a8ea..6b5ab792b 100644 --- a/src/star-parser/shared.scm +++ b/src/star-parser/shared.scm @@ -488,7 +488,7 @@ USA. (count-references identifiers body) identifiers (map cadr bindings))))) - (if (there-exists? discards (lambda (discard) discard)) + (if (any (lambda (discard) discard) discards) (values identifier (apply-discards-to-list discards bindings) (apply-discards-to-calls identifier discards body)) @@ -518,7 +518,7 @@ USA. (let ((discards (map (lambda (count) (= 0 count)) (count-references identifiers body*)))) - (if (there-exists? discards (lambda (discard) discard)) + (if (any (lambda (discard) discard) discards) (values `(LAMBDA ,(apply-discards-to-list discards identifiers) ,body*) (apply-discards-to-calls identifier discards body)) diff --git a/src/win32/graphics.scm b/src/win32/graphics.scm index c22581bc0..0b6d69b44 100644 --- a/src/win32/graphics.scm +++ b/src/win32/graphics.scm @@ -756,7 +756,7 @@ USA. (rgb (vector-ref spec 0) (vector-ref spec 1) (vector-ref spec 2))) ((and (list? spec) (= 3 (length spec)) - (for-all? spec dim?)) + (every dim? spec)) (rgb (list-ref spec 0) (list-ref spec 1) (list-ref spec 2))) ((and (string? spec) (= 7 (string-length spec)) diff --git a/src/xdoc/validate-xdoc.scm b/src/xdoc/validate-xdoc.scm index d28845e2a..5f24d2798 100644 --- a/src/xdoc/validate-xdoc.scm +++ b/src/xdoc/validate-xdoc.scm @@ -369,14 +369,14 @@ USA. (define vx:idrefs (vx:tester "ID references" (lambda (string) - (for-all? (burst-string string char-set:whitespace #t) - string-is-xml-name?)))) + (every string-is-xml-name? + (burst-string string char-set:whitespace #t))))) (define vx:nmtokens (vx:tester "XML tokens" (lambda (string) - (for-all? (burst-string string char-set:whitespace #t) - string-is-xml-nmtoken?)))) + (every string-is-xml-nmtoken? + (burst-string string char-set:whitespace #t))))) (define vx:boolean (vx:tester "true or false" diff --git a/src/xdoc/xdoc.scm b/src/xdoc/xdoc.scm index ddfe48635..7a7c21b2a 100644 --- a/src/xdoc/xdoc.scm +++ b/src/xdoc/xdoc.scm @@ -867,7 +867,7 @@ USA. (if (not (pair? sources)) (error "Multiple-input test needs at least one input.")) (receive (vals submitter) (current-inputs-status sources) - (values (if (there-exists? vals string-null?) + (values (if (any string-null? vals) "unspecified" (procedure elt vals sources)) submitter)))))) @@ -1070,14 +1070,14 @@ USA. (define (descendant-outputs-submitted? elt) (let ((outputs (descendant-outputs elt))) (and (pair? outputs) - (for-all? outputs output-submitted?)))) + (every output-submitted? outputs)))) (define (confirming-submission? elt) - (there-exists? (descendant-outputs elt) - (lambda (elt) - (receive (request submitter) (xdoc-active-element-request elt) - submitter - (eq? request 'confirm))))) + (any (lambda (elt) + (receive (request submitter) (xdoc-active-element-request elt) + submitter + (eq? request 'confirm))) + (descendant-outputs elt))) (define (descendant-outputs elt) (matching-descendants-or-self elt xdoc-output?)) @@ -1085,13 +1085,13 @@ USA. (define (xdoc-outputs-submitted? elt) (let ((outputs (descendant-outputs elt))) (and (pair? outputs) - (for-all? outputs - (lambda (elt) - (let ((id (xdoc-db-id elt))) - (receive (correctness submitter) - (db-previously-saved-output id) - correctness - submitter))))))) + (every (lambda (elt) + (let ((id (xdoc-db-id elt))) + (receive (correctness submitter) + (db-previously-saved-output id) + correctness + submitter))) + outputs)))) (define-html-generator 'case (lambda (elt) @@ -1112,11 +1112,10 @@ USA. (if (pair? choices) (let ((choice (car choices))) (if (cond ((xd:choice? choice) - (there-exists? - (attribute-value->list - (find-attribute 'values choice #t)) - (lambda (token*) - (string=? token* token)))) + (any (lambda (token*) + (string=? token* token)) + (attribute-value->list + (find-attribute 'values choice #t)))) ((xd:default? choice) (if (not (null? (cdr choices))) (error " must be last child:" @@ -1153,7 +1152,7 @@ USA. container) (nearest-container elt))))) (let ((inputs (descendant-inputs container))) - (if (for-all? inputs input-submitted?) + (if (every input-submitted? inputs) #f (html:input (xdoc-attributes diff --git a/src/xml/xhtml.scm b/src/xml/xhtml.scm index 881140c52..a35576885 100644 --- a/src/xml/xhtml.scm +++ b/src/xml/xhtml.scm @@ -279,7 +279,7 @@ USA. 'content value)) (define (html:style-attr . keyword-list) - (guarantee-keyword-list keyword-list 'HTML:STYLE-ATTR) + (guarantee keyword-list? keyword-list 'HTML:STYLE-ATTR) (if (pair? keyword-list) (let loop ((bindings keyword-list)) (string-append (symbol->string (car bindings)) diff --git a/src/xml/xml-names.scm b/src/xml/xml-names.scm index fcf845caf..fdea73527 100644 --- a/src/xml/xml-names.scm +++ b/src/xml/xml-names.scm @@ -144,7 +144,7 @@ USA. (error:bad-range-argument object constructor)) (string->symbol object)) (begin - (guarantee-symbol object constructor) + (guarantee symbol? object constructor) (if (not (string-predicate (symbol->string object))) (error:bad-range-argument object constructor)) object)))) diff --git a/src/xml/xml-parser.scm b/src/xml/xml-parser.scm index 04ecfc5ec..e99111a09 100644 --- a/src/xml/xml-parser.scm +++ b/src/xml/xml-parser.scm @@ -379,9 +379,9 @@ USA. (do ((attrs attrs (cdr attrs))) ((not (pair? attrs)) unspecific) (let ((name (xml-attribute-name (car attrs)))) - (if (there-exists? (cdr attrs) - (lambda (attr) - (xml-name=? (xml-attribute-name attr) name))) + (if (any (lambda (attr) + (xml-name=? (xml-attribute-name attr) name)) + (cdr attrs)) (perror p "Attributes with same name" (xml-name->symbol name))))))) (define (parse-element-content b p name) @@ -475,9 +475,9 @@ USA. description (lambda (buffer) (let loop () - (cond ((there-exists? ends - (lambda (end) - (match-parser-buffer-string-no-advance buffer end))) + (cond ((any (lambda (end) + (match-parser-buffer-string-no-advance buffer end)) + ends) #t) ((match-parser-buffer-char-in-set buffer char-set) (loop)) @@ -739,10 +739,10 @@ USA. (do ((attrs attrs (cdr attrs))) ((not (pair? attrs))) (let ((name (->name (xml-attribute-name (car attrs))))) - (if (there-exists? (cdr attrs) - (lambda (attr) - (xml-name=? (->name (xml-attribute-name attr)) - name))) + (if (any (lambda (attr) + (xml-name=? (->name (xml-attribute-name attr)) + name)) + (cdr attrs)) (perror p "Attributes with same name" name)))) attrs)) (seq (* parse-attribute) diff --git a/src/xml/xml-struct.scm b/src/xml/xml-struct.scm index 043bcb043..905307c94 100644 --- a/src/xml/xml-struct.scm +++ b/src/xml/xml-struct.scm @@ -191,10 +191,10 @@ USA. (and (list-of-type? object xml-attribute?) (let loop ((attrs object)) (if (pair? attrs) - (and (not (there-exists? (cdr attrs) - (let ((name (xml-attribute-name (car attrs)))) - (lambda (attr) - (xml-name=? (xml-attribute-name attr) name))))) + (and (not (any (let ((name (xml-attribute-name (car attrs)))) + (lambda (attr) + (xml-name=? (xml-attribute-name attr) name))) + (cdr attrs))) (loop (cdr attrs))) #t)))) diff --git a/tests/runtime/test-dynamic-env.scm b/tests/runtime/test-dynamic-env.scm index 41aed29d2..301630e88 100644 --- a/tests/runtime/test-dynamic-env.scm +++ b/tests/runtime/test-dynamic-env.scm @@ -34,8 +34,7 @@ USA. (let ((p (make-parameter 1)) (q (make-parameter 2 (lambda (v) - (guarantee-exact-nonnegative-integer v) - v)))) + (guarantee exact-nonnegative-integer? v))))) (assert-eqv (p) 1) (assert-equal (parameterize ((p "7") (q 9)) (cons (p) (q))) diff --git a/tests/runtime/test-srfi-1.scm b/tests/runtime/test-srfi-1.scm index 2c656017a..e56e24d13 100644 --- a/tests/runtime/test-srfi-1.scm +++ b/tests/runtime/test-srfi-1.scm @@ -58,7 +58,7 @@ USA. (eq? foo baz))) ;Value 9: (#t #f) -;;; iota, +;;; iota, (iota 5) ;Value 10: (0 1 2 3 4) @@ -594,7 +594,7 @@ USA. ;Value: #t -(lset-adjoin eq? '(a b c d c e) 'a 'e 'i 'o 'u) +(lset-adjoin eq? '(a b c d c e) 'a 'e 'i 'o 'u) ;Value 67: (u o i a b c d c e) -- 2.25.1