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
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.
@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
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}.
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
(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)
(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?)
(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))
\f
(define-syntax define-standard-binary
(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))))
(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
;;; 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))
\f
(define-command load-problem-set
"Load a 6.001 problem set."
(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)
(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?
(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))
(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)))
(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)))
\f
;;;; Map Coercion
(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)
(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))))
(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))
(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
(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)
(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)
(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))
(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))
(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*))
(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
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)
(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)
(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*))))))
\f
(define (compute-block-popping-limits block)
(let ((external (stack-block/external-ancestor block)))
(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*)
(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
(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.
(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))
(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
;; `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)
(order-parallel!
node
(let ((subproblems (parallel-subproblems node)))
- (if (for-all? subproblems subproblem-simple?)
+ (if (every subproblem-simple? subproblems)
false
(complex-parallel-constraints
subproblems
(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)
(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,
(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
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))
(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))
(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)
(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)
(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)
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)
(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
(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)
(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
(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)
(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
;; 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
;; 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)
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)))
(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)))
(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*)))))
(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
#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)))
#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)
(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)))
(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
(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)
(- (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
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))
(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)))
;; 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
(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
(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)
;; 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
(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))
(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
((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
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
;; 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
(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)
(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)))))
(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))
\f
(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))
(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)
(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)
(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))
(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)))
((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
(define (check-list items predicate)
(and (list? items)
- (for-all? items predicate)))
+ (every predicate items)))
\f
;;;; Packages
(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)
(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
(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.")))
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."
(set-buffer-windows! buffer (delq! window (buffer-windows buffer))))
\f
(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)))
(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.
(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)
(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)
(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
(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))))
\f
;;;; Filename I/O
"$TMP\\edwin.bak")
\f
(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)
(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")
(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)
(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
(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
(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.
(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)
(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)
(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)
(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))))
\f
(define (enqueue-output-string! port string)
(let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
;;; 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)))
(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))
'()))))
(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."
;; 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
'()))
'()))
(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))
(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))))
'()
(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.
(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)
(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)))))
'()
(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))))
\f
(define (get-mail-from-pop-server server insert buffer)
(let ((procedure (ref-variable rmail-pop-procedure buffer)))
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)
(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)))
\f
(define (call-with-smtp-socket host-name service trace-buffer receiver)
(let ((port #f))
(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)))
(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
(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))
(>= (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)
(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
(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
(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
(* (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
(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))))
(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)
(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)
(if (default-object? char)
#\space
(begin
- (guarantee-char char 'STRING-PAD-RIGHT)
+ (guarantee char? char 'STRING-PAD-RIGHT)
char)))))
result))))
(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))))
(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)
(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)
(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)
(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)
(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"
(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))))
\f
(define (os/init-file-name) "~/.edwin")
(define (os/abbrev-file-name) "~/.abbrev_defs")
;; 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))
\f
(define-syntax chars-to-words-shift
(define (list-of-type? object predicate)
(and (list? object)
- (for-all? object predicate)))
+ (every predicate object)))
(define (dotimes n procedure)
(define (loop i)
(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)
#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)
;;;; 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))))
(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
(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))))
(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))
(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.
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")
" "
(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))
(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)
(or (eq? object #f)
(eq? object #t)))
-(define-guarantee boolean "boolean")
-
(define (boolean=? x y)
(if x y (not y)))
(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
(if (default-object? timeout)
0
(begin
- (guarantee-real timeout)
+ (guarantee real? timeout)
(register-timer-event (- timeout (real-time-clock)) #f)))))
(begin0
(let loop ()
(%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?)
'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)
(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)
(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)
\f
(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)
(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)
(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))
((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")))
(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
parameter))
(define (parameterize* new-bindings thunk)
- (guarantee-alist new-bindings 'parameterize*)
+ (guarantee alist? new-bindings 'parameterize*)
(let ((temp
(map* bindings
(lambda (p)
(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 ()
(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
(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
(letrec
((constructor
(lambda (continuation restarts . field-values)
- (guarantee-continuation continuation constructor)
+ (guarantee continuation? continuation constructor)
(let ((condition
(%make-condition type
continuation
(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
(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))
(loop (cdr restarts))))))
\f
(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)
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)
(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")
\f
-(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)))
((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
(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))
(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)
((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)))
\f
;;;; Floating-point environment utilities
(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)
(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)
(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))))
(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)))
(%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)
(with-output-to-truncated-string max (lambda () (write object)))))
\f
(define (pa procedure)
- (guarantee-procedure procedure 'PA)
+ (guarantee procedure? procedure 'PA)
(cond ((procedure-lambda procedure)
=> (lambda (scode)
(pp (unsyntax-lambda-list scode))))
(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)
(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)
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)))
(%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))
(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)
(if-found datum))))
\f
(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)
(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)
(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))
'()))
((table-type-method:fold (table-type table)) table procedure initial-value))
\f
(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
(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
(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)
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))
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)))
(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))
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)
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
(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)
((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)
(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)
(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)))
(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)))
(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)))
(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)
(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)
;;;; 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)))
(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)))
(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*)
((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))
((identifier? bvl*)
(procedure bvl*))
(else
- (error:not-r4rs-lambda-list bvl)))))
+ (error:not-a r4rs-lambda-list? bvl)))))
\f
(define (mit-lambda-list? object)
(letrec
(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))
(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)))
;;; 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)
'()
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)
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 '())))
'()))
(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
(cons a d))
\f
(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))))))
(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)
(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
(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)
(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))))
\f
(define (list= predicate . lists)
(define (lose)
(for-each (lambda (list)
- (guarantee-list list 'LIST=))
+ (guarantee list? list 'LIST=))
lists))
(if (and (pair? lists)
(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
(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*)
'()
(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))
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)
(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
(loop (weak-cdr l1) (weak-cdr l2))
(null? l1))))
(null? l1))))
-
-(define-guarantee weak-list "weak list")
\f
(define (weak-memq object items)
(let ((object (or object weak-pair/false)))
(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)
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)
(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)))
\f
;;;; General CAR CDR
;;; 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)))
(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)))
((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))
'())))
head)
(else
(if (not (null? head))
- (error:not-list (car lists) 'APPEND!))
+ (error:not-a list? (car lists) 'APPEND!))
(loop (car tail) (cdr tail)))))
'()))
(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)
(loop next current))
(begin
(if (not (null? current))
- (error:not-list l 'REVERSE*!))
+ (error:not-a list? l 'REVERSE*!))
new-cdr))))
\f
;;;; Mapping Procedures
(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))
\f
(define for-each)
(cdr remaining))
(begin
(if (not (null? remaining))
- (error:not-list list caller))
+ (error:not-a list? list caller))
state))))
;; N-ary version
(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)
(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)
(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)))))
\f
;;;; Generalized list operations
(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)
(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)
(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))))
\f
(define (count-matching-items items predicate)
(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)
(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))
(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))
(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)
(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)
(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)
(%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))
(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)))
\f
;;;; Association lists
(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) '())))
(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)
(%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)
(%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)))
(lose)))))
(lose
(lambda ()
- (error:not-alist items caller))))
+ (error:not-a alist? items caller))))
(trim-initial-segment items)))
\f
;;;; Keyword lists
(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)
(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")
\f
(define (get-keyword-value klist key #!optional default-value)
(let ((lose (lambda () (error:not-a keyword-list? klist 'get-keyword-value))))
(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) '())))
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))
,(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
(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)
(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)
value)
(define (parser-table-converter value)
- (guarantee-parser-table value)
+ (guarantee parser-table? value)
value)
(define (radix-converter value)
(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)
(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)))
(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))
(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
#!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
(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
;; 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
(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)
(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)
(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
(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
(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")
\f
(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))
((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))
\f
(define (repl-read #!optional environment repl)
(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)))
\f
(define (repl/start repl #!optional message)
(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)
(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)))
(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)
(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))
(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)
(define-package (runtime boolean)
(files "boole")
(parent (runtime))
- (export () deprecated:boolean
- guarantee-boolean)
(export ()
(false? not)
boolean/and
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
(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
flo:y1
flo:yn
flo:zero?
+ guarantee-limited-index-fixnum
index-fixnum?
int:*
int:+
(define-package (runtime miscellaneous-global)
(files "global")
(parent (runtime))
- (export () deprecated:miscellaneous-global
- error:not-hook-list
- guarantee-hook-list)
(export ()
%exit
%quit
(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 ()
<mime-type>
allocate-temporary-file
(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
(define-package (runtime microcode-data)
(files "udata")
(parent (runtime))
- (export () deprecated:microcode-data
- guarantee-promise)
(export ()
compiled-code-address->block
compiled-code-address->offset
(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
(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?
(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
(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?
(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)
(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
(define-package (runtime environment)
(files "uenvir")
(parent (runtime))
- (export () deprecated:environment
- guarantee-environment)
(export ()
compiled-procedure/environment
environment-arguments
(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)
(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!
(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)
(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
(define-package (runtime srfi-1)
(files "srfi-1")
(parent (runtime))
+ (export () deprecated:srfi-1
+ for-all?
+ there-exists?)
(export ()
any
append-reverse
(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+)
(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
(define-package (runtime pathname)
(files "pathnm")
(parent (runtime))
- (export () deprecated:pathname
- error:not-pathname
- guarantee-pathname)
(export ()
*default-pathname-defaults*
->namestring
(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
(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
(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
(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?
(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 ()
<syntactic-closure>
capture-syntactic-environment
(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)
(define-package (runtime thread)
(files "thread-low" "thread")
(parent (runtime))
- (export () deprecated:thread
- guarantee-thread)
(export ()
assert-thread-mutex-owned
block-thread-events
(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?
(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?
(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)
(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
(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 ()
<http-header>
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
(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
(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
;;;; 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)
;;;; 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)
(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)
;;;; 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)
;;;; 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)))
(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)
(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)
(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)
(*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
;;;; 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)
'())))
(define (drop lis k)
- (guarantee-index-fixnum k 'DROP)
+ (guarantee index-fixnum? k 'DROP)
(%drop lis k))
(define (%drop lis k)
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)) '())
;;; 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)))
;;; 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
'())))
(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))
(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)))
(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)))))
+\f
+;;;; Backwards compatibility
+
+(define (there-exists? items predicate)
+ (any predicate items))
+
+(define (for-all? items predicate)
+ (every predicate items))
\ No newline at end of file
(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 '())
(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
'())))
(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
(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)
(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)
(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)))))
\f
(define (structure-parser-values? object)
(let loop ((object object))
(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*)
(+ (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))
(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*)
((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)))
;;; 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
;;; 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)
;;; 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))))
;;; 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
(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 ()
(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))
(lookup-identifier (syntactic-closure/form identifier)
(syntactic-closure/environment identifier)))
(else
- (error:not-identifier identifier 'LOOKUP-IDENTIFIER)))))
+ (error:not-a identifier? identifier 'LOOKUP-IDENTIFIER)))))
\f
;;;; Utilities
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
(%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
(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)))))
(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)))))
(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)))
\f
(define thread-population)
(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)
(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))
(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
(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)
(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)
(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
unspecific)))
\f
(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?)))
(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)
;;; 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)
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)
(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)
(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))
(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)
((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)
((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)
((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)
(closure-ccenv? environment))
'())
(else
- (illegal-environment environment 'ENVIRONMENT-MACRO-NAMES))))
+ (error:not-a environment? environment 'ENVIRONMENT-MACRO-NAMES))))
\f
(define (environment-bindings environment)
(let ((items (environment-bound-names environment)))
(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)))
((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))))
((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)
((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)
((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)
((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)
(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)
(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))))
\f
;;;; Global environment
\f
(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)
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)
(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 '()
(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
(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
(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))
(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)))
\f
(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))))
(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)
(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?))
(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))
(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)
(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)
(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)
(->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)
(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
(define (optional-environment environment caller)
(if (default-object? environment)
(nearest-repl/environment)
- (begin
- (guarantee-environment environment caller)
- environment)))
+ (guarantee environment? environment caller)))
\f
(define (prompt-for-command-char prompt #!optional port)
(let ((prompt (canonicalize-command-prompt prompt))
(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))))
(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))
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)
(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)))))
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))
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))
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))
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<? unwrap-key key)
- (guarantee-vector vector 'VECTOR-BINARY-SEARCH)
+ (guarantee vector? vector 'VECTOR-BINARY-SEARCH)
(let loop ((start 0) (end (vector-length vector)))
(and (fix:< start end)
(let ((midpoint (fix:quotient (fix:+ start end) 2)))
(sc-macro-transformer
(lambda (form environment)
`(DEFINE-INTEGRABLE (,(cadr form) VECTOR)
- (GUARANTEE-VECTOR VECTOR ',(cadr form))
+ (GUARANTEE VECTOR? VECTOR ',(cadr form))
(VECTOR-REF VECTOR ,(caddr form)))))))
(iref vector-first 0)
(iref vector-second 1)
(loop (fix:+ index 1))))))
(define (vector-filled? vector element)
- (guarantee-vector vector 'VECTOR-FILLED?)
+ (guarantee vector? vector 'VECTOR-FILLED?)
(subvector-filled? vector 0 (vector-length vector) element))
(define (subvector-uniform? vector start end)
#t))
(define (vector-uniform? vector)
- (guarantee-vector vector 'VECTOR-UNIFORM?)
+ (guarantee vector? vector 'VECTOR-UNIFORM?)
(subvector-uniform? vector 0 (vector-length vector)))
(define (vector-of-type? object predicate)
(cond ((expression/call-to-not? expression)
(expression/never-false? (first (combination/operands expression))))
((procedure? (combination/operator expression))
- (expression/always-false? (procedure/body (combination/operator expression))))
+ (expression/always-false?
+ (procedure/body (combination/operator expression))))
(else #f))))
(define-method/always-false? 'CONDITIONAL
(define-method/effect-free? 'COMBINATION
(lambda (expression)
- (and (for-all? (combination/operands expression) expression/effect-free?)
+ (and (every expression/effect-free? (combination/operands expression))
(or (expression/call-to-effect-free-primitive? expression)
(and (procedure? (combination/operator expression))
- (expression/effect-free? (procedure/body (combination/operator expression))))))))
+ (expression/effect-free?
+ (procedure/body (combination/operator expression))))))))
(define-method/effect-free? 'CONDITIONAL
(lambda (expression)
(define-method/effect-free? 'SEQUENCE
(lambda (expression)
- (for-all? (sequence/actions expression) expression/effect-free?)))
+ (every expression/effect-free? (sequence/actions expression))))
(define-method/effect-free? 'THE-ENVIRONMENT true-procedure)
\f
(define-method/free-variables 'COMBINATION
(lambda (expression)
- (lset-union eq?
- (expression/free-variables (combination/operator expression))
- (expressions/free-variables (combination/operands expression)))))
+ (lset-union
+ eq?
+ (expression/free-variables (combination/operator expression))
+ (expressions/free-variables (combination/operands expression)))))
(define-method/free-variables 'CONDITIONAL
(lambda (expression)
- (lset-union eq?
- (expression/free-variables (conditional/predicate expression))
- (if (expression/always-false? (conditional/predicate expression))
- (no-free-variables)
- (expression/free-variables (conditional/consequent expression)))
- (if (expression/never-false? (conditional/predicate expression))
- (no-free-variables)
- (expression/free-variables (conditional/alternative expression))))))
+ (lset-union
+ eq?
+ (expression/free-variables (conditional/predicate expression))
+ (if (expression/always-false? (conditional/predicate expression))
+ (no-free-variables)
+ (expression/free-variables (conditional/consequent expression)))
+ (if (expression/never-false? (conditional/predicate expression))
+ (no-free-variables)
+ (expression/free-variables (conditional/alternative expression))))))
(define-method/free-variables 'CONSTANT
(lambda (expression)
(define-method/free-variables 'DISJUNCTION
(lambda (expression)
- (lset-union eq?
- (expression/free-variables (disjunction/predicate expression))
- (if (expression/never-false? (disjunction/predicate expression))
- (no-free-variables)
- (expression/free-variables (disjunction/alternative expression))))))
+ (lset-union
+ eq?
+ (expression/free-variables (disjunction/predicate expression))
+ (if (expression/never-false? (disjunction/predicate expression))
+ (no-free-variables)
+ (expression/free-variables (disjunction/alternative expression))))))
(define-method/free-variables 'OPEN-BLOCK
(lambda (expression)
(fold-left (lambda (variables action)
(if (eq? action open-block/value-marker)
variables
- (lset-union eq? variables (lset-difference eq? (expression/free-variables action) omit))))
- (lset-difference eq? (expressions/free-variables (open-block/values expression)) omit)
+ (lset-union eq?
+ variables
+ (lset-difference
+ eq?
+ (expression/free-variables action)
+ omit))))
+ (lset-difference eq?
+ (expressions/free-variables
+ (open-block/values expression))
+ omit)
(open-block/actions expression)))))
(define-method/free-variables 'PROCEDURE
(define-method/free-variable? 'COMBINATION
(lambda (expression variable)
(or (expression/free-variable? (combination/operator expression) variable)
- (expressions/free-variable? (combination/operands expression) variable))))
+ (expressions/free-variable?
+ (combination/operands expression) variable))))
(define-method/free-variable? 'CONDITIONAL
(lambda (expression variable)
(or (expression/free-variable? (conditional/predicate expression) variable)
(cond ((expression/always-false? (conditional/predicate expression))
- (expression/free-variable? (conditional/alternative expression) variable))
+ (expression/free-variable? (conditional/alternative expression)
+ variable))
((expression/never-false? (conditional/predicate expression))
- (expression/free-variable? (conditional/consequent expression) variable))
- ((expression/free-variable? (conditional/consequent expression) variable))
- (else (expression/free-variable? (conditional/alternative expression) variable))))))
+ (expression/free-variable? (conditional/consequent expression)
+ variable))
+ ((expression/free-variable? (conditional/consequent expression)
+ variable))
+ (else
+ (expression/free-variable? (conditional/alternative expression)
+ variable))))))
(define-method/free-variable? 'CONSTANT false-procedure)
(or (expression/free-variable? (disjunction/predicate expression) variable)
(if (expression/never-false? (disjunction/predicate expression))
#f
- (expression/free-variable? (disjunction/alternative expression) variable)))))
+ (expression/free-variable? (disjunction/alternative expression)
+ variable)))))
(define-method/free-variable? 'OPEN-BLOCK
(lambda (expression variable)
(expression/free-variable-info-dispatch expression variable (cons 0 0)))
(define (expression/free-variable-info-dispatch expression variable info)
- ((expression/method free-info-dispatch-vector expression) expression variable info))
+ ((expression/method free-info-dispatch-vector expression)
+ expression variable info))
(define (expressions/free-variable-info expressions variable info)
(fold-left (lambda (answer expression)
- (expression/free-variable-info-dispatch expression variable answer))
+ (expression/free-variable-info-dispatch expression variable
+ answer))
info
expressions))
(define-method/free-variable-info 'ACCESS
(lambda (expression variable info)
- (expression/free-variable-info-dispatch (access/environment expression) variable info)))
+ (expression/free-variable-info-dispatch (access/environment expression)
+ variable info)))
(define-method/free-variable-info 'ASSIGNMENT
(lambda (expression variable info)
(or (eq? variable (assignment/variable expression))
- (expression/free-variable-info-dispatch (assignment/value expression) variable info))))
+ (expression/free-variable-info-dispatch (assignment/value expression)
+ variable info))))
(define-method/free-variable-info 'COMBINATION
(lambda (expression variable info)
(let ((operator (combination/operator expression))
- (inner-info (expressions/free-variable-info (combination/operands expression) variable info)))
+ (inner-info
+ (expressions/free-variable-info (combination/operands expression)
+ variable info)))
(if (and (reference? operator)
(eq? (reference/variable operator) variable))
(cons (fix:1+ (car inner-info)) (cdr inner-info))
- (expression/free-variable-info-dispatch operator variable inner-info)))))
+ (expression/free-variable-info-dispatch operator variable
+ inner-info)))))
(define-method/free-variable-info 'CONDITIONAL
(lambda (expression variable info)
(conditional/predicate expression) variable
(expression/free-variable-info-dispatch
(conditional/consequent expression) variable
- (expression/free-variable-info-dispatch (conditional/alternative expression) variable info)))))
+ (expression/free-variable-info-dispatch
+ (conditional/alternative expression)
+ variable info)))))
(define-method/free-variable-info 'CONSTANT
- (lambda (expression variable info) (declare (ignore expression variable)) info))
+ (lambda (expression variable info)
+ (declare (ignore expression variable))
+ info))
(define-method/free-variable-info 'DECLARATION
(lambda (expression variable info)
- (expression/free-variable-info-dispatch (declaration/expression expression) variable info)))
+ (expression/free-variable-info-dispatch (declaration/expression expression)
+ variable info)))
\f
(define-method/free-variable-info 'DELAY
(lambda (expression variable info)
- (expression/free-variable-info-dispatch (delay/expression expression) variable info)))
+ (expression/free-variable-info-dispatch (delay/expression expression)
+ variable info)))
(define-method/free-variable-info 'DISJUNCTION
(lambda (expression variable info)
(fold-left (lambda (info action)
(if (eq? action open-block/value-marker)
info
- (expression/free-variable-info-dispatch action variable info)))
+ (expression/free-variable-info-dispatch action variable
+ info)))
info
(open-block/actions expression))))
(define-method/free-variable-info 'PROCEDURE
(lambda (expression variable info)
- (expression/free-variable-info-dispatch (procedure/body expression) variable info)))
+ (expression/free-variable-info-dispatch (procedure/body expression)
+ variable info)))
(define-method/free-variable-info 'QUOTATION
(lambda (expression variable info)
(define-method/free-variable-info 'SEQUENCE
(lambda (expression variable info)
- (expressions/free-variable-info (sequence/actions expression) variable info)))
+ (expressions/free-variable-info (sequence/actions expression)
+ variable info)))
(define-method/free-variable-info 'THE-ENVIRONMENT
(lambda (expression variable info)
(cond ((expression/call-to-not? expression)
(expression/always-false? (first (combination/operands expression))))
((procedure? (combination/operator expression))
- (expression/never-false? (procedure/body (combination/operator expression))))
+ (expression/never-false?
+ (procedure/body (combination/operator expression))))
(else #f))))
(define-method/never-false? 'CONDITIONAL
(cond ((expression/call-to-not? expression)
(expression/pure-true? (first (combination/operands expression))))
((procedure? (combination/operator expression))
- (and (for-all? (combination/operands expression) expression/effect-free?)
- (expression/pure-false? (procedure/body (combination/operator expression)))))
+ (and (every expression/effect-free?
+ (combination/operands expression))
+ (expression/pure-false?
+ (procedure/body (combination/operator expression)))))
(else #f))))
(define-method/pure-false? 'CONDITIONAL
(define-method/pure-false? 'SEQUENCE
(lambda (expression)
- (and (for-all? (except-last-pair (sequence/actions expression))
- expression/effect-free?) ;; unlikely
+ (and (every expression/effect-free? ; unlikely
+ (except-last-pair (sequence/actions expression)))
(expression/pure-false? (last (sequence/actions expression))))))
(define-method/pure-false? 'THE-ENVIRONMENT false-procedure)
(cond ((expression/call-to-not? expression)
(expression/pure-false? (first (combination/operands expression))))
((procedure? (combination/operator expression))
- (and (for-all? (combination/operands expression) expression/effect-free?)
- (expression/pure-true? (procedure/body (combination/operator expression)))))
+ (and (every expression/effect-free?
+ (combination/operands expression))
+ (expression/pure-true?
+ (procedure/body (combination/operator expression)))))
(else #f))))
(define-method/pure-true? 'CONDITIONAL
(define-method/pure-true? 'SEQUENCE
(lambda (expression)
- (and (for-all? (except-last-pair (sequence/actions expression))
- expression/effect-free?)
+ (and (every expression/effect-free?
+ (except-last-pair (sequence/actions expression)))
(expression/pure-true? (last (sequence/actions expression))))))
(define-method/pure-true? 'THE-ENVIRONMENT false-procedure)
(integrate-external "object"))
\f
(define (variable/make&bind! block name)
- (guarantee-symbol name 'variable/make&bind!)
+ (guarantee symbol? name 'variable/make&bind!)
(or (%block/lookup-name block name)
(%variable/make&bind! block name)))
variable))
(define (block/lookup-name block name intern?)
- (guarantee-symbol name 'block/lookup-name)
+ (guarantee symbol? name 'block/lookup-name)
(let search ((block block))
(or (%block/lookup-name block name)
(if (block/parent block)
(eq? (variable/name variable) name))))
(define (block/limited-lookup block name limit)
- (guarantee-symbol name 'block/limited-lookup)
+ (guarantee symbol? name 'block/limited-lookup)
(let search ((block block))
(and (not (eq? block limit))
(or (%block/lookup-name block name)
(procedure-arity-valid? operator-value (length operands))
(memq operator-value combination/constant-folding-operators)))
;; Check that the arguments are constant.
- (for-all? operands constant?)))
+ (every constant? operands)))
;; An operator is reducible if we can safely rewrite its argument list.
(define (reducible-operator? operator)
(block/safe? (procedure/block operator))
;; if there are declarations we don't understand, we
;; should leave things alone.
- (for-all? (declarations/original
- (block/declarations (procedure/block operator)))
- declarations/known?)
+ (every declarations/known?
+ (declarations/original
+ (block/declarations (procedure/block operator))))
;; Unintegrated optionals are tricky and rare. Punt.
- (for-all? (procedure/optional operator) variable/integrated)
+ (every variable/integrated (procedure/optional operator))
;; Unintegrated rest arguments are tricky and rare. Punt.
(let ((rest-arg (procedure/rest operator)))
(or (not rest-arg) (variable/integrated rest-arg)))))
(define (check-declaration-syntax kind declarations)
(if (not (and (list? declarations)
- (for-all? declarations
- (lambda (declaration)
- (and (pair? declaration)
- (symbol? (car declaration))
- (list? (cdr declaration)))))))
+ (every (lambda (declaration)
+ (and (pair? declaration)
+ (symbol? (car declaration))
+ (list? (cdr declaration))))
+ declarations)))
(error "Bad declaration:" kind declarations)))
(define-declaration 'REPLACE-OPERATOR
(lambda (block replacements)
(if (not (and (list? replacements)
- (for-all? replacements
- (lambda (replacement)
- (and (pair? replacement)
- (or (symbol? (car replacement))
- (and (pair? (car replacement))
- (eq? 'PRIMITIVE (caar replacement))
- (pair? (cdar replacement))
- (symbol? (cadar replacement))
- (or (null? (cddar replacement))
- (and (pair? (cddar replacement))
- (null? (cdddar replacement))))))
- (list? (cdr replacement)))))))
+ (every (lambda (replacement)
+ (and (pair? replacement)
+ (or (symbol? (car replacement))
+ (and (pair? (car replacement))
+ (eq? 'PRIMITIVE (caar replacement))
+ (pair? (cdar replacement))
+ (symbol? (cadar replacement))
+ (or (null? (cddar replacement))
+ (and (pair? (cddar replacement))
+ (null?
+ (cdddar replacement))))))
+ (list? (cdr replacement))))
+ replacements)))
(error "Bad declaration:" 'REPLACE-OPERATOR replacements))
(map (lambda (replacement)
(make-declaration
(encloser
(declaration-with-expression operator expression)))))
(else #f)))
- (and (for-all? operands expression/effect-free?)
+ (and (every expression/effect-free? operands)
(scan-operator operator (lambda (body) body))))
\f
(define (combination-with-operator combination operator)
;; When processing a global reference, we only have a name.
(define (operations/lookup-global operations name if-found if-not)
- (guarantee-symbol name 'operations/lookup-global)
+ (guarantee symbol? name 'operations/lookup-global)
(let ((probe (find (lambda (entry)
(eq? (variable/name (car entry)) name))
(vector-ref operations 2))))
;;;; File Syntaxer
(define (syntax-file input-string bin-string spec-string)
- (guarantee-environment sf/default-syntax-table 'syntax-file)
+ (guarantee environment? sf/default-syntax-table 'syntax-file)
(guarantee-list-of-type sf/top-level-definitions symbol? 'syntax-file)
(for-each (lambda (input-string)
(receive (input-pathname bin-pathname spec-pathname)
(values (vector-ref object 2) (vector-ref object 3))
(wrong-version (vector-ref object 1))))
((and (list? object)
- (for-all? object
- (lambda (element)
- (and (vector? element)
- (= 4 (vector-length element))))))
+ (every (lambda (element)
+ (and (vector? element)
+ (= 4 (vector-length element))))
+ object))
(wrong-version 1))
(else
(error "Not an externs file:" namestring))))
(define (subclass? c s)
(let ((pl (class-precedence-list c)))
- (and (there-exists? (specializer-classes s)
- (lambda (s)
- (memq s pl)))
+ (and (any (lambda (s)
+ (memq s pl))
+ (specializer-classes s))
#t)))
(define (guarantee-class class name)
(eq? 'NO-INITIALIZE-INSTANCE init-arg-names))
#f)
((and (list? init-arg-names)
- (for-all? init-arg-names symbol?))
+ (every symbol? init-arg-names))
(length init-arg-names))
((exact-nonnegative-integer? init-arg-names)
init-arg-names)
(if (not (or (eq? 'STANDARD (cadr plist))
(keyword? (cadr plist))
(and (list? (cadr plist))
- (for-all? (cadr plist) keyword?))))
+ (every keyword? (cadr plist)))))
(lose "DEFINE property" arg)))
(set-cdr! prev (cddr plist))
(set! definitions
(let ((result (apply (method-procedure (car generators)) classes)))
(cond ((not result)
(loop (cdr generators)))
- ((or (there-exists? (cdr generators)
- (lambda (generator)
- (and (specializers=?
- (method-specializers generator)
- (method-specializers (car generators)))
- (apply (method-procedure generator) classes))))
- (there-exists? methods
- (lambda (method)
- (specializers=? (method-specializers method)
- classes))))
+ ((or (any (lambda (generator)
+ (and (specializers=?
+ (method-specializers generator)
+ (method-specializers (car generators)))
+ (apply (method-procedure generator) classes)))
+ (cdr generators))
+ (any (lambda (method)
+ (specializers=? (method-specializers method)
+ classes))
+ methods))
(lambda args
(error:extra-applicable-methods generic args)))
(else result))))))
(let loop ((s1 s1) (s2 s2))
(or (null? s2)
(if (null? s1)
- (for-all? s2
- (lambda (s)
- (subclass? <object> s)))
- (and (for-all? (specializer-classes (car s1))
- (lambda (c)
- (subclass? c (car s2))))
+ (every (lambda (s) (subclass? <object> s)) s2)
+ (and (every (lambda (c) (subclass? c (car s2)))
+ (specializer-classes (car s1)))
(loop (cdr s1) (cdr s2)))))))
\f
;;;; Method Specializers
(define (specializers? object)
(and (list? object)
(not (null? object))
- (for-all? object specializer?)))
+ (every specializer? object)))
(define (specializer? object)
(or (class? object)
(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)
(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)))
(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))
(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))
(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))
(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"
(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))))))
(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?))
(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))))
\f
(define-html-generator 'case
(lambda (elt)
(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 "<xd:default> must be last child:"
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
'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))
(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))))
(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)
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))
(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)
(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))))
(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)))
(eq? foo baz)))
;Value 9: (#t #f)
-;;; iota,
+;;; iota,
(iota 5)
;Value 10: (0 1 2 3 4)
;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)
projects / mit-scheme.git / commitdiff