(lambda (form environment)
(if (syntax-match? '(identifier) (cdr form))
(let ((identifier (close-syntax (cadr form) environment)))
- `(LOCAL-DECLARE ((INTEGRATE ,identifier)) ,identifier))
+ `(local-declare ((integrate ,identifier)) ,identifier))
(ill-formed-syntax form)))))
;;;; Primitives
(initialize-microcode-dependencies!)
(add-event-receiver! event:after-restore initialize-microcode-dependencies!)
(initialize-*maximum-fixnum-radix-powers*!)
- (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-ZERO? complex:zero?)
- (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-POSITIVE? complex:positive?)
- (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-NEGATIVE? complex:negative?)
- (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-ADD-1 complex:1+)
- (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-SUBTRACT-1 complex:-1+)
- (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-EQUAL? complex:=)
- (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-LESS? complex:<)
- (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-GREATER? complex:>)
- (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-ADD complex:+)
- (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-SUBTRACT complex:-)
- (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-MULTIPLY complex:*)
- (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-DIVIDE complex:/)
- (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-QUOTIENT complex:quotient)
- (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-REMAINDER complex:remainder)
- (set-fixed-objects-item! 'GENERIC-TRAMPOLINE-MODULO complex:modulo)
+ (set-fixed-objects-item! 'generic-trampoline-zero? complex:zero?)
+ (set-fixed-objects-item! 'generic-trampoline-positive? complex:positive?)
+ (set-fixed-objects-item! 'generic-trampoline-negative? complex:negative?)
+ (set-fixed-objects-item! 'generic-trampoline-add-1 complex:1+)
+ (set-fixed-objects-item! 'generic-trampoline-subtract-1 complex:-1+)
+ (set-fixed-objects-item! 'generic-trampoline-equal? complex:=)
+ (set-fixed-objects-item! 'generic-trampoline-less? complex:<)
+ (set-fixed-objects-item! 'generic-trampoline-greater? complex:>)
+ (set-fixed-objects-item! 'generic-trampoline-add complex:+)
+ (set-fixed-objects-item! 'generic-trampoline-subtract complex:-)
+ (set-fixed-objects-item! 'generic-trampoline-multiply complex:*)
+ (set-fixed-objects-item! 'generic-trampoline-divide complex:/)
+ (set-fixed-objects-item! 'generic-trampoline-quotient complex:quotient)
+ (set-fixed-objects-item! 'generic-trampoline-remainder complex:remainder)
+ (set-fixed-objects-item! 'generic-trampoline-modulo complex:modulo)
\f
;; The binary cases for the following operators rely on the fact that the
;; &<mumble> operators, either interpreted or open-coded by the
(lambda (form environment)
(let ((name (list-ref form 1))
(identity (close-syntax (list-ref form 3) environment)))
- `(SET! ,(close-syntax name environment)
- (MAKE-ENTITY
- (NAMED-LAMBDA (,name SELF . ZS)
- SELF ; ignored
- (REDUCE ,(close-syntax (list-ref form 2) environment)
+ `(set! ,(close-syntax name environment)
+ (make-entity
+ (named-lambda (,name self . zs)
+ self ; ignored
+ (reduce ,(close-syntax (list-ref form 2) environment)
,identity
- ZS))
- (VECTOR
- (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag)
- (NAMED-LAMBDA (,(symbol 'NULLARY- name))
+ zs))
+ (vector
+ (fixed-objects-item 'arity-dispatcher-tag)
+ (named-lambda (,(symbol 'nullary- name))
,identity)
- (NAMED-LAMBDA (,(symbol 'UNARY- name) Z)
- (IF (NOT (COMPLEX:COMPLEX? Z))
- (ERROR:WRONG-TYPE-ARGUMENT Z "number" ',name))
- Z)
- (NAMED-LAMBDA (,(symbol 'BINARY- name) Z1 Z2)
- ((UCODE-PRIMITIVE ,(list-ref form 4)) Z1 Z2))))))))))
+ (named-lambda (,(symbol 'unary- name) z)
+ (if (not (complex:complex? z))
+ (error:wrong-type-argument z "number" ',name))
+ z)
+ (named-lambda (,(symbol 'binary- name) z1 z2)
+ ((ucode-primitive ,(list-ref form 4)) z1 z2))))))))))
(commutative + complex:+ 0 &+)
(commutative * complex:* 1 &*))
(int:* answer b)
(loop b e answer))))))))
((int:zero? e) 1)
- (else (error:bad-range-argument e 'EXPT))))
+ (else (error:bad-range-argument e 'expt))))
;; A vector indexed by radix of pairs of the form (N . (expt RADIX N))
;; where N is the maximum value for which the cdr is a fixnum. Used
(make-power-stack value split-factor '() split-digits)))))
(cond ((not (int:integer? number))
- (error:wrong-type-argument number #f 'NUMBER->STRING))
+ (error:wrong-type-argument number #f 'number->string))
((int:negative? number)
(list->string (cons #\- (n>0 (int:negate number)))))
(else
(lambda (form environment)
(let ((name (list-ref form 1))
(int:op (close-syntax (list-ref form 2) environment)))
- `(DEFINE (,name U/U* V/V*)
- (RAT:BINARY-OPERATOR U/U* V/V*
+ `(define (,name u/u* v/v*)
+ (rat:binary-operator u/u* v/v*
,int:op
- (LAMBDA (U V V*)
- (MAKE-RATIONAL (,int:op (INT:* U V*) V) V*))
- (LAMBDA (U U* V)
- (MAKE-RATIONAL (,int:op U (INT:* V U*)) U*))
- (LAMBDA (U U* V V*)
- (LET ((D1 (INT:GCD U* V*)))
- (IF (INT:= D1 1)
- (MAKE-RATIONAL (,int:op (INT:* U V*) (INT:* V U*))
- (INT:* U* V*))
- (LET* ((U*/D1 (INT:QUOTIENT U* D1))
- (T
- (,int:op (INT:* U (INT:QUOTIENT V* D1))
- (INT:* V U*/D1))))
- (IF (INT:ZERO? T)
- 0 ;(MAKE-RATIONAL 0 1)
- (LET ((D2 (INT:GCD T D1)))
- (MAKE-RATIONAL
- (INT:QUOTIENT T D2)
- (INT:* U*/D1
- (INT:QUOTIENT V* D2)))))))))))))))
+ (lambda (u v v*)
+ (make-rational (,int:op (int:* u v*) v) v*))
+ (lambda (u u* v)
+ (make-rational (,int:op u (int:* v u*)) u*))
+ (lambda (u u* v v*)
+ (let ((d1 (int:gcd u* v*)))
+ (if (int:= d1 1)
+ (make-rational (,int:op (int:* u v*) (int:* v u*))
+ (int:* u* v*))
+ (let* ((u*/d1 (int:quotient u* d1))
+ (t
+ (,int:op (int:* u (int:quotient v* d1))
+ (int:* v u*/d1))))
+ (if (int:zero? t)
+ 0 ;(make-rational 0 1)
+ (let ((d2 (int:gcd t d1)))
+ (make-rational
+ (int:quotient t d2)
+ (int:* u*/d1
+ (int:quotient v* d2)))))))))))))))
(define-addition-operator rat:+ int:+)
(define-addition-operator rat:- int:-)
(define (rat:numerator q)
(cond ((ratnum? q) (ratnum-numerator q))
((int:integer? q) q)
- (else (error:wrong-type-argument q #f 'NUMERATOR))))
+ (else (error:wrong-type-argument q #f 'numerator))))
(define (rat:denominator q)
(cond ((ratnum? q) (ratnum-denominator q))
((int:integer? q) 1)
- (else (error:wrong-type-argument q #f 'DENOMINATOR))))
+ (else (error:wrong-type-argument q #f 'denominator))))
(define-syntax define-integer-coercion
(sc-macro-transformer
(lambda (form environment)
- `(DEFINE (,(list-ref form 1) Q)
- (COND ((RATNUM? Q)
+ `(define (,(list-ref form 1) q)
+ (cond ((ratnum? q)
(,(close-syntax (list-ref form 3) environment)
- (RATNUM-NUMERATOR Q)
- (RATNUM-DENOMINATOR Q)))
- ((INT:INTEGER? Q) Q)
- (ELSE
- (ERROR:WRONG-TYPE-ARGUMENT Q
+ (ratnum-numerator q)
+ (ratnum-denominator q)))
+ ((int:integer? q) q)
+ (else
+ (error:wrong-type-argument q
"real number"
',(list-ref form 2))))))))
((int:positive? e)
(exact-method e))
(else 1))))
- (error:bad-range-argument e 'EXPT)))
+ (error:bad-range-argument e 'expt)))
(define (rat:->string q radix)
(if (ratnum? q)
(define (real:exact? x)
(and (not (flonum? x))
(or (rat:rational? x)
- (error:wrong-type-argument x #f 'EXACT?))))
+ (error:wrong-type-argument x #f 'exact?))))
(define (real:zero? x)
(if (flonum? x) (flo:zero? x) ((copy rat:zero?) x)))
(define-syntax define-standard-unary
(sc-macro-transformer
(lambda (form environment)
- `(DEFINE (,(list-ref form 1) X)
- (IF (FLONUM? X)
- (,(close-syntax (list-ref form 2) environment) X)
- (,(close-syntax (list-ref form 3) environment) X))))))
+ `(define (,(list-ref form 1) x)
+ (if (flonum? x)
+ (,(close-syntax (list-ref form 2) environment) x)
+ (,(close-syntax (list-ref form 3) environment) x))))))
(define-standard-unary real:1+ (lambda (x) (flo:+ x flo:1)) (copy rat:1+))
(define-standard-unary real:-1+ (lambda (x) (flo:- x flo:1)) (copy rat:-1+))
(lambda (q)
(if (rat:rational? q)
q
- (error:wrong-type-argument q #f 'INEXACT->EXACT))))
+ (error:wrong-type-argument q #f 'inexact->exact))))
\f
(define-syntax define-standard-binary
(sc-macro-transformer
(lambda (form environment)
(let ((flo:op (close-syntax (list-ref form 2) environment))
(rat:op (close-syntax (list-ref form 3) environment)))
- `(DEFINE (,(list-ref form 1) X Y)
- (IF (FLONUM? X)
- (IF (FLONUM? Y)
- (,flo:op X Y)
- (,flo:op X (RAT:->INEXACT Y)))
- (IF (FLONUM? Y)
- (,flo:op (RAT:->INEXACT X) Y)
- (,rat:op X Y))))))))
+ `(define (,(list-ref form 1) x y)
+ (if (flonum? x)
+ (if (flonum? y)
+ (,flo:op x y)
+ (,flo:op x (rat:->inexact y)))
+ (if (flonum? y)
+ (,flo:op (rat:->inexact x) y)
+ (,rat:op x y))))))))
(define-standard-binary real:+ flo:+ (copy rat:+))
(define-standard-binary real:- flo:- (copy rat:-))
(if (flonum? n)
(if (flo:integer? n)
(flo:->integer n)
- (error:wrong-type-argument n #f 'EVEN?))
+ (error:wrong-type-argument n #f 'even?))
n)))
(define-syntax define-integer-binary
(let ((operator (close-syntax (list-ref form 3) environment))
(flo->int
(lambda (n)
- `(IF (FLO:INTEGER? ,n)
- (FLO:->INTEGER ,n)
- (ERROR:WRONG-TYPE-ARGUMENT ,n "integer"
+ `(if (flo:integer? ,n)
+ (flo:->integer ,n)
+ (error:wrong-type-argument ,n "integer"
',(list-ref form 2))))))
- `(DEFINE (,(list-ref form 1) N M)
- (IF (FLONUM? N)
- (INT:->INEXACT
- (,operator ,(flo->int 'N)
- (IF (FLONUM? M)
- ,(flo->int 'M)
- M)))
- (IF (FLONUM? M)
- (INT:->INEXACT (,operator N ,(flo->int 'M)))
- (,operator N M))))))))
+ `(define (,(list-ref form 1) n m)
+ (if (flonum? n)
+ (int:->inexact
+ (,operator ,(flo->int 'n)
+ (if (flonum? m)
+ ,(flo->int 'm)
+ m)))
+ (if (flonum? m)
+ (int:->inexact (,operator n ,(flo->int 'm)))
+ (,operator n m))))))))
(define-integer-binary real:quotient quotient int:quotient)
(define-integer-binary real:remainder remainder int:remainder)
(sc-macro-transformer
(lambda (form environment)
(let ((operator (close-syntax (list-ref form 2) environment)))
- `(DEFINE (,(list-ref form 1) Q)
- (IF (FLONUM? Q)
- (RAT:->INEXACT (,operator (FLO:->RATIONAL Q)))
- (,operator Q)))))))
+ `(define (,(list-ref form 1) q)
+ (if (flonum? q)
+ (rat:->inexact (,operator (flo:->rational q)))
+ (,operator q)))))))
(define-rational-unary real:numerator rat:numerator)
(define-rational-unary real:denominator rat:denominator)
(sc-macro-transformer
(lambda (form environment)
(let ((operator (close-syntax (list-ref form 2) environment)))
- `(DEFINE (,(list-ref form 1) Q)
- (IF (FLONUM? Q)
- (,operator (FLO:->RATIONAL Q))
- (,operator Q)))))))
+ `(define (,(list-ref form 1) q)
+ (if (flonum? q)
+ (,operator (flo:->rational q))
+ (,operator q)))))))
(define-rational-exact-unary real:numerator->exact rat:numerator)
(define-rational-exact-unary real:denominator->exact rat:denominator)
(define-syntax define-transcendental-unary
(sc-macro-transformer
(lambda (form environment)
- `(DEFINE (,(list-ref form 1) X)
- (IF (,(close-syntax (list-ref form 2) environment) X)
+ `(define (,(list-ref form 1) x)
+ (if (,(close-syntax (list-ref form 2) environment) x)
,(close-syntax (list-ref form 3) environment)
(,(close-syntax (list-ref form 4) environment)
- (REAL:->INEXACT X)))))))
+ (real:->inexact x)))))))
(define-transcendental-unary real:exp real:exact0= 1 flo:exp)
(define-transcendental-unary real:log real:exact1= 0 flo:log)
((flo:zero? x)
(if (flo:positive? y)
x
- (error:divide-by-zero 'EXPT (list x y))))
+ (error:divide-by-zero 'expt (list x y))))
((and (flo:negative? x)
(not (flo:integer? y)))
- (error:bad-range-argument x 'EXPT))
+ (error:bad-range-argument x 'expt))
(else
(flo:expt x y))))))
(if (flonum? x)
(define (complex:positive? x)
(if (recnum? x)
- (real:positive? (rec:real-arg 'POSITIVE? x))
+ (real:positive? (rec:real-arg 'positive? x))
((copy real:positive?) x)))
(define (complex:negative? x)
(if (recnum? x)
- (real:negative? (rec:real-arg 'NEGATIVE? x))
+ (real:negative? (rec:real-arg 'negative? x))
((copy real:negative?) x)))
(define (complex:even? x)
- (if (recnum? x) (real:even? (rec:real-arg 'EVEN? x)) ((copy real:even?) x)))
+ (if (recnum? x) (real:even? (rec:real-arg 'even? x)) ((copy real:even?) x)))
\f
(define (complex:max x y)
(if (recnum? x)
(if (recnum? y)
- (real:max (rec:real-arg 'MAX x) (rec:real-arg 'MAX y))
- (real:max (rec:real-arg 'MAX x) y))
+ (real:max (rec:real-arg 'max x) (rec:real-arg 'max y))
+ (real:max (rec:real-arg 'max x) y))
(if (recnum? y)
- (real:max x (rec:real-arg 'MAX y))
+ (real:max x (rec:real-arg 'max y))
((copy real:max) x y))))
(define (complex:min x y)
(if (recnum? x)
(if (recnum? y)
- (real:min (rec:real-arg 'MIN x) (rec:real-arg 'MIN y))
- (real:min (rec:real-arg 'MIN x) y))
+ (real:min (rec:real-arg 'min x) (rec:real-arg 'min y))
+ (real:min (rec:real-arg 'min x) y))
(if (recnum? y)
- (real:min x (rec:real-arg 'MIN y))
+ (real:min x (rec:real-arg 'min y))
((copy real:min) x y))))
(define (complex:+ z1 z2)
((real:real? z)
z)
(else
- (error:wrong-type-argument z #f 'CONJUGATE))))
+ (error:wrong-type-argument z #f 'conjugate))))
(define (complex:/ z1 z2)
(if (recnum? z1)
((copy real:invert) z)))
(define (complex:abs x)
- (if (recnum? x) (real:abs (rec:real-arg 'ABS x)) ((copy real:abs) x)))
+ (if (recnum? x) (real:abs (rec:real-arg 'abs x)) ((copy real:abs) x)))
\f
(define (complex:quotient n d)
- (real:quotient (complex:real-arg 'QUOTIENT n)
- (complex:real-arg 'QUOTIENT d)))
+ (real:quotient (complex:real-arg 'quotient n)
+ (complex:real-arg 'quotient d)))
(define (complex:remainder n d)
- (real:remainder (complex:real-arg 'REMAINDER n)
- (complex:real-arg 'REMAINDER d)))
+ (real:remainder (complex:real-arg 'remainder n)
+ (complex:real-arg 'remainder d)))
(define (complex:modulo n d)
- (real:modulo (complex:real-arg 'MODULO n)
- (complex:real-arg 'MODULO d)))
+ (real:modulo (complex:real-arg 'modulo n)
+ (complex:real-arg 'modulo d)))
(define (complex:integer-floor n d)
- (real:integer-floor (complex:real-arg 'INTEGER-FLOOR n)
- (complex:real-arg 'INTEGER-FLOOR d)))
+ (real:integer-floor (complex:real-arg 'integer-floor n)
+ (complex:real-arg 'integer-floor d)))
(define (complex:integer-ceiling n d)
- (real:integer-ceiling (complex:real-arg 'INTEGER-CEILING n)
- (complex:real-arg 'INTEGER-CEILING d)))
+ (real:integer-ceiling (complex:real-arg 'integer-ceiling n)
+ (complex:real-arg 'integer-ceiling d)))
(define (complex:integer-round n d)
- (real:integer-round (complex:real-arg 'INTEGER-ROUND n)
- (complex:real-arg 'INTEGER-ROUND d)))
+ (real:integer-round (complex:real-arg 'integer-round n)
+ (complex:real-arg 'integer-round d)))
(define (complex:divide n d)
- (real:divide (complex:real-arg 'DIVIDE n)
- (complex:real-arg 'DIVIDE d)))
+ (real:divide (complex:real-arg 'divide n)
+ (complex:real-arg 'divide d)))
(define (complex:gcd n m)
- (real:gcd (complex:real-arg 'GCD n)
- (complex:real-arg 'GCD m)))
+ (real:gcd (complex:real-arg 'gcd n)
+ (complex:real-arg 'gcd m)))
(define (complex:lcm n m)
- (real:lcm (complex:real-arg 'LCM n)
- (complex:real-arg 'LCM m)))
+ (real:lcm (complex:real-arg 'lcm n)
+ (complex:real-arg 'lcm m)))
(define (complex:numerator q)
- (real:numerator (complex:real-arg 'NUMERATOR q)))
+ (real:numerator (complex:real-arg 'numerator q)))
(define (complex:denominator q)
- (real:denominator (complex:real-arg 'DENOMINATOR q)))
+ (real:denominator (complex:real-arg 'denominator q)))
(define (complex:numerator->exact q)
- (real:numerator->exact (complex:real-arg 'NUMERATOR->EXACT q)))
+ (real:numerator->exact (complex:real-arg 'numerator->exact q)))
(define (complex:denominator->exact q)
- (real:denominator->exact (complex:real-arg 'DENOMINATOR->EXACT q)))
+ (real:denominator->exact (complex:real-arg 'denominator->exact q)))
\f
(define (complex:floor x)
(if (recnum? x)
- (real:floor (rec:real-arg 'FLOOR x))
+ (real:floor (rec:real-arg 'floor x))
((copy real:floor) x)))
(define (complex:ceiling x)
(if (recnum? x)
- (real:ceiling (rec:real-arg 'CEILING x))
+ (real:ceiling (rec:real-arg 'ceiling x))
((copy real:ceiling) x)))
(define (complex:truncate x)
(if (recnum? x)
- (real:truncate (rec:real-arg 'TRUNCATE x))
+ (real:truncate (rec:real-arg 'truncate x))
((copy real:truncate) x)))
(define (complex:round x)
(if (recnum? x)
- (real:round (rec:real-arg 'ROUND x))
+ (real:round (rec:real-arg 'round x))
((copy real:round) x)))
(define (complex:floor->exact x)
(if (recnum? x)
- (real:floor->exact (rec:real-arg 'FLOOR->EXACT x))
+ (real:floor->exact (rec:real-arg 'floor->exact x))
((copy real:floor->exact) x)))
(define (complex:ceiling->exact x)
(if (recnum? x)
- (real:ceiling->exact (rec:real-arg 'CEILING->EXACT x))
+ (real:ceiling->exact (rec:real-arg 'ceiling->exact x))
((copy real:ceiling->exact) x)))
(define (complex:truncate->exact x)
(if (recnum? x)
- (real:truncate->exact (rec:real-arg 'TRUNCATE->EXACT x))
+ (real:truncate->exact (rec:real-arg 'truncate->exact x))
((copy real:truncate->exact) x)))
(define (complex:round->exact x)
(if (recnum? x)
- (real:round->exact (rec:real-arg 'ROUND->EXACT x))
+ (real:round->exact (rec:real-arg 'round->exact x))
((copy real:round->exact) x)))
(define (complex:rationalize x e)
- (real:rationalize (complex:real-arg 'RATIONALIZE x)
- (complex:real-arg 'RATIONALIZE e)))
+ (real:rationalize (complex:real-arg 'rationalize x)
+ (complex:real-arg 'rationalize e)))
(define (complex:rationalize->exact x e)
- (real:rationalize->exact (complex:real-arg 'RATIONALIZE x)
- (complex:real-arg 'RATIONALIZE e)))
+ (real:rationalize->exact (complex:real-arg 'rationalize x)
+ (complex:real-arg 'rationalize e)))
(define (complex:simplest-rational x y)
- (real:simplest-rational (complex:real-arg 'SIMPLEST-RATIONAL x)
- (complex:real-arg 'SIMPLEST-RATIONAL y)))
+ (real:simplest-rational (complex:real-arg 'simplest-rational x)
+ (complex:real-arg 'simplest-rational y)))
(define (complex:simplest-exact-rational x y)
- (real:simplest-exact-rational (complex:real-arg 'SIMPLEST-RATIONAL x)
- (complex:real-arg 'SIMPLEST-RATIONAL y)))
+ (real:simplest-exact-rational (complex:real-arg 'simplest-rational x)
+ (complex:real-arg 'simplest-rational y)))
\f
(define (complex:exp z)
(if (recnum? z)
(rec:atan (make-recnum (real:exact->inexact x)
(real:exact->inexact y))))))
(cond ((recnum? y)
- (rec-case (rec:real-arg 'ATAN y) (complex:real-arg 'ATAN x)))
+ (rec-case (rec:real-arg 'atan y) (complex:real-arg 'atan x)))
((recnum? x)
- (rec-case y (rec:real-arg 'ATAN x)))
+ (rec-case y (rec:real-arg 'atan x)))
(else
((copy real:atan2) y x)))))
((real:positive? (complex:real-part z2))
(real:0 (complex:exact? z1)))
((real:zero? (complex:real-part z2))
- (error:bad-range-argument z2 'EXPT))
+ (error:bad-range-argument z2 'expt))
(else
- (error:divide-by-zero 'EXPT (list z1 z2)))))
+ (error:divide-by-zero 'expt (list z1 z2)))))
((and (recnum? z1)
(int:integer? z2))
(let ((exact-method
(let ((check-arg
(lambda (x)
(if (recnum? x)
- (rec:real-arg 'MAKE-RECTANGULAR x)
+ (rec:real-arg 'make-rectangular x)
(begin
(if (not (real:real? x))
- (error:wrong-type-argument x #f 'MAKE-RECTANGULAR))
+ (error:wrong-type-argument x #f 'make-rectangular))
x)))))
((copy complex:%make-rectangular) (check-arg real) (check-arg imag))))
(define (complex:make-polar real imag)
- ((copy complex:%make-polar) (complex:real-arg 'MAKE-POLAR real)
- (complex:real-arg 'MAKE-POLAR imag)))
+ ((copy complex:%make-polar) (complex:real-arg 'make-polar real)
+ (complex:real-arg 'make-polar imag)))
(define (complex:%make-rectangular real imag)
(if (real:exact0= imag)
(define (complex:real-part z)
(cond ((recnum? z) (rec:real-part z))
((real:real? z) z)
- (else (error:wrong-type-argument z #f 'REAL-PART))))
+ (else (error:wrong-type-argument z #f 'real-part))))
(define (complex:imag-part z)
(cond ((recnum? z) (rec:imag-part z))
((real:real? z) 0)
- (else (error:wrong-type-argument z #f 'IMAG-PART))))
+ (else (error:wrong-type-argument z #f 'imag-part))))
(define (complex:exact->inexact z)
(if (recnum? z)
(<= 2 radix 36))
radix)
((and (pair? radix)
- (eq? (car radix) 'HEUR)
+ (eq? (car radix) 'heur)
(list? radix))
(parse-format-tail (cdr radix)))
(else
- (error:bad-range-argument radix 'NUMBER->STRING)))))
+ (error:bad-range-argument radix 'number->string)))))
(define (parse-format-tail tail)
(let loop
(cadr modifier)))
(cadr modifier))))
(cond ((and (pair? modifier)
- (eq? (car modifier) 'EXACTNESS)
+ (eq? (car modifier) 'exactness)
(pair? (cdr modifier))
- (memq (cadr modifier) '(E S))
+ (memq (cadr modifier) '(e s))
(null? (cddr modifier)))
- (if (eq? (cadr modifier) 'E)
+ (if (eq? (cadr modifier) 'e)
(warn "NUMBER->STRING: ignoring exactness modifier"
modifier))
(loop tail
radix
radix-expressed))
((and (pair? modifier)
- (eq? (car modifier) 'RADIX)
+ (eq? (car modifier) 'radix)
(pair? (cdr modifier))
- (memq (cadr modifier) '(B O D X))
+ (memq (cadr modifier) '(b o d x))
(or (null? (cddr modifier))
(and (pair? (cddr modifier))
- (memq (caddr modifier) '(E S))
+ (memq (caddr modifier) '(e s))
(null? (cdddr modifier)))))
(if (and (pair? (cddr modifier))
- (eq? (caddr modifier) 'E))
+ (eq? (caddr modifier) 'e))
(warn
"NUMBER->STRING: ignoring radix expression modifier"
modifier))
(loop tail
exactness-expressed
(specify-modifier radix)
- (if (pair? (cddr modifier)) (caddr modifier) 'E)))
+ (if (pair? (cddr modifier)) (caddr modifier) 'e)))
(else
(error "Illegal format modifier" modifier)))))
(case radix
- ((B) 2)
- ((O) 8)
- ((D #f) 10)
- ((X) 16)))))
\ No newline at end of file
+ ((b) 2)
+ ((o) 8)
+ ((d #f) 10)
+ ((x) 16)))))
\ No newline at end of file
(db4:sizeof-db-lock 0)
(db4:sizeof-dbt 0))
-(define-integrable DB_CXX_NO_EXCEPTIONS #x00000002)
-(define-integrable DB_FORCE #x00000004)
-(define-integrable DB_NOMMAP #x00000008)
-(define-integrable DB_RDONLY #x00000010)
-(define-integrable DB_RECOVER #x00000020)
-(define-integrable DB_THREAD #x00000040)
-(define-integrable DB_TRUNCATE #x00000080)
-(define-integrable DB_TXN_NOSYNC #x00000100)
-(define-integrable DB_TXN_NOT_DURABLE #x00000200)
-(define-integrable DB_USE_ENVIRON #x00000400)
-(define-integrable DB_USE_ENVIRON_ROOT #x00000800)
-(define-integrable DB_AUTO_COMMIT #x01000000)
-(define-integrable DB_DIRTY_READ #x02000000)
-(define-integrable DB_NO_AUTO_COMMIT #x04000000)
+(define-integrable db_cxx_no_exceptions #x00000002)
+(define-integrable db_force #x00000004)
+(define-integrable db_nommap #x00000008)
+(define-integrable db_rdonly #x00000010)
+(define-integrable db_recover #x00000020)
+(define-integrable db_thread #x00000040)
+(define-integrable db_truncate #x00000080)
+(define-integrable db_txn_nosync #x00000100)
+(define-integrable db_txn_not_durable #x00000200)
+(define-integrable db_use_environ #x00000400)
+(define-integrable db_use_environ_root #x00000800)
+(define-integrable db_auto_commit #x01000000)
+(define-integrable db_dirty_read #x02000000)
+(define-integrable db_no_auto_commit #x04000000)
;; Flags for DB4:DB-ENV-CREATE
-(define-integrable DB_RPCCLIENT #x00000001)
+(define-integrable db_rpcclient #x00000001)
;; Flags for DB4:DB-CREATE
-(define-integrable DB_REP_CREATE #x00000001)
-(define-integrable DB_XA_CREATE #x00000002)
+(define-integrable db_rep_create #x00000001)
+(define-integrable db_xa_create #x00000002)
\f
;; Flags for DB4:DB-ENV-OPEN
-(define-integrable DB_INIT_CDB #x00001000)
-(define-integrable DB_INIT_LOCK #x00002000)
-(define-integrable DB_INIT_LOG #x00004000)
-(define-integrable DB_INIT_MPOOL #x00008000)
-(define-integrable DB_INIT_REP #x00010000)
-(define-integrable DB_INIT_TXN #x00020000)
-(define-integrable DB_JOINENV #x00040000)
-(define-integrable DB_LOCKDOWN #x00080000)
-(define-integrable DB_PRIVATE #x00100000)
-(define-integrable DB_RECOVER_FATAL #x00200000)
-(define-integrable DB_SYSTEM_MEM #x00400000)
+(define-integrable db_init_cdb #x00001000)
+(define-integrable db_init_lock #x00002000)
+(define-integrable db_init_log #x00004000)
+(define-integrable db_init_mpool #x00008000)
+(define-integrable db_init_rep #x00010000)
+(define-integrable db_init_txn #x00020000)
+(define-integrable db_joinenv #x00040000)
+(define-integrable db_lockdown #x00080000)
+(define-integrable db_private #x00100000)
+(define-integrable db_recover_fatal #x00200000)
+(define-integrable db_system_mem #x00400000)
;; Flags for DB4:DB-OPEN
-(define-integrable DB_EXCL #x00001000)
-(define-integrable DB_FCNTL_LOCKING #x00002000)
-(define-integrable DB_RDWRMASTER #x00004000)
-(define-integrable DB_WRITEOPEN #x00008000)
+(define-integrable db_excl #x00001000)
+(define-integrable db_fcntl_locking #x00002000)
+(define-integrable db_rdwrmaster #x00004000)
+(define-integrable db_writeopen #x00008000)
;; Flags for DB4:DB-ENV-TXN-BEGIN
-(define-integrable DB_TXN_NOWAIT #x00001000)
-(define-integrable DB_TXN_SYNC #x00002000)
+(define-integrable db_txn_nowait #x00001000)
+(define-integrable db_txn_sync #x00002000)
;; Flags for DB4:DB-GET, DB4:DB-PUT, DB4:DB-DEL
-#;(define-integrable DB_DIRTY_READ #x02000000)
-(define-integrable DB_MULTIPLE #x04000000)
-(define-integrable DB_MULTIPLE_KEY #x08000000)
-(define-integrable DB_RMW #x10000000)
+#;(define-integrable db_dirty_read #x02000000)
+(define-integrable db_multiple #x04000000)
+(define-integrable db_multiple_key #x08000000)
+(define-integrable db_rmw #x10000000)
;; db_locktype_t enumeration:
-(define-integrable DB_LOCK_NG 0)
-(define-integrable DB_LOCK_READ 1)
-(define-integrable DB_LOCK_WRITE 2)
-(define-integrable DB_LOCK_WAIT 3)
-(define-integrable DB_LOCK_IWRITE 4)
-(define-integrable DB_LOCK_IREAD 5)
-(define-integrable DB_LOCK_IWR 6)
-(define-integrable DB_LOCK_DIRTY 7)
-(define-integrable DB_LOCK_WWRITE 8)
+(define-integrable db_lock_ng 0)
+(define-integrable db_lock_read 1)
+(define-integrable db_lock_write 2)
+(define-integrable db_lock_wait 3)
+(define-integrable db_lock_iwrite 4)
+(define-integrable db_lock_iread 5)
+(define-integrable db_lock_iwr 6)
+(define-integrable db_lock_dirty 7)
+(define-integrable db_lock_wwrite 8)
(define-syntax pcall
(sc-macro-transformer
(lambda (form environment)
(if (syntax-match? '(identifier * expression) (cdr form))
- `(LET ((RC
+ `(let ((rc
(,(close-syntax (cadr form) environment)
,@(map (lambda (expr)
(close-syntax expr environment))
(cddr form)))))
- (IF (NOT (= RC 0))
- (BDB-ERROR RC ',(cadr form))))))))
+ (if (not (= rc 0))
+ (bdb-error rc ',(cadr form))))))))
(define condition-type:bdb-error
- (make-condition-type 'BDB-ERROR condition-type:error '(RC PRIMITIVE)
+ (make-condition-type 'bdb-error condition-type:error '(rc primitive)
(lambda (condition port)
- (let ((rc (access-condition condition 'RC)))
+ (let ((rc (access-condition condition 'rc)))
(write-string "Berkeley DB error in primitive " port)
- (write (access-condition condition 'PRIMITIVE) port)
+ (write (access-condition condition 'primitive) port)
(write-string ": " port)
(write-string (db4:db-strerror rc) port)
(write-string " (" port)
(define bdb-error
(condition-signaller condition-type:bdb-error
- '(RC PRIMITIVE)
+ '(rc primitive)
standard-error-handler))
\f
(define-record-type <bdb>
(d9 (char->integer #\9))
(la (char->integer #\a))
(lf (char->integer #\f))
- (UA (char->integer #\A))
- (UF (char->integer #\F)))
+ (ua (char->integer #\A))
+ (uf (char->integer #\F)))
(cond ((and (fix:<= d0 i) (fix:<= i d9)) (fix:- i d0))
((and (fix:<= la i) (fix:<= i lf)) (fix:+ #xa (fix:- i la)))
- ((and (fix:<= UA i) (fix:<= i UF)) (fix:+ #xA (fix:- i UA)))
+ ((and (fix:<= ua i) (fix:<= i uf)) (fix:+ #xA (fix:- i ua)))
(else (lose)))))
(if (not (fix:= (fix:and end 1) 0))
(lose))
(define (ascii-range->char-set start end)
(if (not (index-fixnum? start))
- (error:wrong-type-argument start "index fixnum" 'ASCII-RANGE->CHAR-SET))
+ (error:wrong-type-argument start "index fixnum" 'ascii-range->char-set))
(if (not (index-fixnum? end))
- (error:wrong-type-argument end "index fixnum" 'ASCII-RANGE->CHAR-SET))
+ (error:wrong-type-argument end "index fixnum" 'ascii-range->char-set))
(if (not (fix:<= start end))
- (error:bad-range-argument start 'ASCII-RANGE->CHAR-SET))
+ (error:bad-range-argument start 'ascii-range->char-set))
(if (not (fix:<= end #x100))
- (error:bad-range-argument end 'ASCII-RANGE->CHAR-SET))
+ (error:bad-range-argument end 'ascii-range->char-set))
(char-set (cons start end)))
(define (%char-set-table char-set)
(define-guarantee char "character")
(define (make-char code bits)
- (guarantee-limited-index-fixnum code char-code-limit 'MAKE-CHAR)
- (guarantee-limited-index-fixnum bits char-bits-limit 'MAKE-CHAR)
+ (guarantee-limited-index-fixnum code char-code-limit 'make-char)
+ (guarantee-limited-index-fixnum bits char-bits-limit 'make-char)
(%make-char code bits))
(define-integrable (%make-char code bits)
(fix:< (char->integer object) char-code-limit)))
(define (char-bits-set? bits char)
- (guarantee-limited-index-fixnum bits char-bits-limit 'CHAR-BITS-SET?)
+ (guarantee-limited-index-fixnum bits char-bits-limit 'char-bits-set?)
(fix:= bits (fix:and (char-bits char) bits)))
(define (char-bits-clear? bits char)
- (guarantee-limited-index-fixnum bits char-bits-limit 'CHAR-BITS-CLEAR?)
+ (guarantee-limited-index-fixnum bits char-bits-limit 'char-bits-clear?)
(fix:= 0 (fix:and (char-bits char) bits)))
(define (set-char-bits bits char)
- (guarantee-limited-index-fixnum bits char-bits-limit 'SET-CHAR-BITS)
+ (guarantee-limited-index-fixnum bits char-bits-limit 'set-char-bits)
(%make-char (char-code char)
(fix:or (char-bits char) bits)))
(define (clear-char-bits bits char)
- (guarantee-limited-index-fixnum bits char-bits-limit 'CLEAR-CHAR-BITS)
+ (guarantee-limited-index-fixnum bits char-bits-limit 'clear-char-bits)
(%make-char (char-code char)
(fix:andc (char-bits char) bits)))
(if (default-object? radix)
10
(begin
- (guarantee radix? radix 'CHAR->DIGIT)
+ (guarantee radix? radix 'char->digit)
radix)))
(digit (digit-value char)))
(if digit
;; U+000080..U+0007FF C2..DF 80..BF
(define-integrable (valid-utf8-sequence-2? b0 b1)
(and (utf8-initial-byte-2? b0)
- (u8:80..BF? b1)))
+ (u8:80..bf? b1)))
;; code-point range b0 b1 b2
;; ------------------ ------ ------ ------
;; U+00E000..U+00FFFF EE..EF 80..BF 80..BF
(define-integrable (valid-utf8-sequence-3? b0 b1 b2)
(and (utf8-initial-byte-3? b0)
- (cond ((fix:= b0 #xE0) (u8:A0..BF? b1))
- ((fix:< b0 #xED) (u8:80..BF? b1))
- ((fix:= b0 #xED) (u8:80..9F? b1))
- (else (u8:80..BF? b1)))
- (u8:80..BF? b2)))
+ (cond ((fix:= b0 #xE0) (u8:a0..bf? b1))
+ ((fix:< b0 #xED) (u8:80..bf? b1))
+ ((fix:= b0 #xED) (u8:80..9f? b1))
+ (else (u8:80..bf? b1)))
+ (u8:80..bf? b2)))
;; code-point range b0 b1 b2 b3
;; ------------------ ------ ------ ------ ------
;; U+100000..U+10FFFF F4 80..8F 80..BF 80..BF
(define-integrable (valid-utf8-sequence-4? b0 b1 b2 b3)
(and (utf8-initial-byte-4? b0)
- (cond ((fix:= b0 #xF0) (u8:90..BF? b1))
- ((fix:< b0 #xF4) (u8:80..BF? b1))
- (else (u8:80..8F? b1)))
- (u8:80..BF? b2)
- (u8:80..BF? b3)))
+ (cond ((fix:= b0 #xF0) (u8:90..bf? b1))
+ ((fix:< b0 #xF4) (u8:80..bf? b1))
+ (else (u8:80..8f? b1)))
+ (u8:80..bf? b2)
+ (u8:80..bf? b3)))
;; Trailing bytes:
-(define-integrable (u8:80..8F? byte)
+(define-integrable (u8:80..8f? byte)
(fix:= #x80 (fix:and #xF0 byte)))
-(define-integrable (u8:80..9F? byte)
+(define-integrable (u8:80..9f? byte)
(fix:= #x80 (fix:and #xE0 byte)))
-(define-integrable (u8:80..BF? byte)
+(define-integrable (u8:80..bf? byte)
(fix:= #x80 (fix:and #xC0 byte)))
-(define-integrable (u8:90..BF? byte)
+(define-integrable (u8:90..bf? byte)
(and (fix:>= byte #x90) (fix:<= byte #xBF)))
-(define-integrable (u8:A0..BF? byte)
+(define-integrable (u8:a0..bf? byte)
(and (fix:>= byte #xA0) (fix:<= byte #xBF)))
\f
(define (initial-u16->utf16-char-length u16)
(vector-copy
(if (or (default-object? table) (not table))
(char-syntax-table/entries standard-char-syntax-table)
- (guarantee-char-syntax-table table 'MAKE-CHAR-SYNTAX-TABLE)))))
+ (guarantee-char-syntax-table table 'make-char-syntax-table)))))
(define (get-char-syntax table char)
- (vector-ref (guarantee-char-syntax-table table 'GET-CHAR-SYNTAX)
+ (vector-ref (guarantee-char-syntax-table table 'get-char-syntax)
(char->integer char)))
(define (set-char-syntax! table char string)
- (let ((entries (guarantee-char-syntax-table table 'SET-CHAR-SYNTAX!))
+ (let ((entries (guarantee-char-syntax-table table 'set-char-syntax!))
(entry (string->char-syntax string)))
(cond ((char? char)
(vector-set! entries (char->integer char) entry))
(vector-set! entries (char->integer char) entry))
(char-set-members char)))
(else
- (error:wrong-type-argument char "character" 'SET-CHAR-SYNTAX!)))))
+ (error:wrong-type-argument char "character" 'set-char-syntax!)))))
(define standard-char-syntax-table)
(string->char-syntax string->syntax-entry))
(define (char-syntax->string entry)
- (guarantee-char-syntax entry 'CHAR-SYNTAX->STRING)
+ (guarantee-char-syntax entry 'char-syntax->string)
(let ((code (fix:and #xf entry)))
(string-append
(vector-ref char-syntax-codes code)
(begin (set! alist (delq! entry alist))
(cdr entry))
default)))))
- (let ((comment-handler (lookup 'COMMENT default))
- (combination-handler (lookup 'COMBINATION default))
- (lambda-handler (lookup 'LAMBDA default))
- (sequence-handler (lookup 'SEQUENCE default)))
- (%make-scode-walker (lookup 'ACCESS default)
- (lookup 'ASSIGNMENT default)
+ (let ((comment-handler (lookup 'comment default))
+ (combination-handler (lookup 'combination default))
+ (lambda-handler (lookup 'lambda default))
+ (sequence-handler (lookup 'sequence default)))
+ (%make-scode-walker (lookup 'access default)
+ (lookup 'assignment default)
combination-handler
comment-handler
- (lookup 'CONDITIONAL default)
+ (lookup 'conditional default)
default
- (lookup 'DECLARATION comment-handler)
- (lookup 'DEFINITION default)
- (lookup 'DELAY default)
- (lookup 'DISJUNCTION default)
- (lookup 'ERROR-COMBINATION
+ (lookup 'declaration comment-handler)
+ (lookup 'definition default)
+ (lookup 'delay default)
+ (lookup 'disjunction default)
+ (lookup 'error-combination
combination-handler)
- (lookup 'EXTENDED-LAMBDA lambda-handler)
+ (lookup 'extended-lambda lambda-handler)
lambda-handler
- (lookup 'OPEN-BLOCK sequence-handler)
- (lookup 'QUOTATION default)
+ (lookup 'open-block sequence-handler)
+ (lookup 'quotation default)
sequence-handler
- (lookup 'THE-ENVIRONMENT default)
- (lookup 'UNASSIGNED? combination-handler)
- (lookup 'VARIABLE default))))))
+ (lookup 'the-environment default)
+ (lookup 'unassigned? combination-handler)
+ (lookup 'variable default))))))
(if (not (null? alist))
(error "MAKE-SCODE-WALKER: Unrecognized alist items" alist))
result)))
(if (pair? (car entry))
(for-each kernel (car entry))
(kernel (car entry)))))
- `((ACCESS ,walk/access)
- (ASSIGNMENT ,walk/assignment)
- (COMBINATION ,walk/combination)
- (COMMENT ,walk/comment)
- (CONDITIONAL ,walk/conditional)
- (DEFINITION ,walk/definition)
- (DELAY ,walk/delay)
- (DISJUNCTION ,walk/disjunction)
- (EXTENDED-LAMBDA ,walk/extended-lambda)
- ((LAMBDA LEXPR) ,walk/lambda)
- (QUOTATION ,walk/quotation)
- (SEQUENCE ,walk/sequence)
- (THE-ENVIRONMENT ,walk/the-environment)
- (VARIABLE ,walk/variable)))
+ `((access ,walk/access)
+ (assignment ,walk/assignment)
+ (combination ,walk/combination)
+ (comment ,walk/comment)
+ (conditional ,walk/conditional)
+ (definition ,walk/definition)
+ (delay ,walk/delay)
+ (disjunction ,walk/disjunction)
+ (extended-lambda ,walk/extended-lambda)
+ ((lambda lexpr) ,walk/lambda)
+ (quotation ,walk/quotation)
+ (sequence ,walk/sequence)
+ (the-environment ,walk/the-environment)
+ (variable ,walk/variable)))
table)))
\f
(define (walk/combination walker expression)
(constructor %make-condition-variable
(name waiter-head waiter-tail))
(print-procedure
- (simple-unparser-method 'CONDITION-VARIABLE
+ (simple-unparser-method 'condition-variable
(lambda (condvar)
(cond ((condition-variable-name condvar) => list)
(else '()))))))
(%make-condition-variable name waiter-head waiter-tail)))
(define (condition-variable-name condvar)
- (guarantee-condition-variable condvar 'CONDITION-VARIABLE-NAME)
+ (guarantee-condition-variable condvar 'condition-variable-name)
(condition-variable.name condvar))
(define (condition-variable-specific condvar)
- (guarantee-condition-variable condvar 'CONDITION-VARIABLE-SPECIFIC)
+ (guarantee-condition-variable condvar 'condition-variable-specific)
(condition-variable.specific condvar))
(define (condition-variable-specific-set! condvar specific)
- (guarantee-condition-variable condvar 'SET-CONDITION-VARIABLE-SPECIFIC!)
+ (guarantee-condition-variable condvar 'set-condition-variable-specific!)
(set-condition-variable.specific! condvar specific))
\f
(define (unlock-thread-mutex-and-wait thread-mutex condvar #!optional timeout)
- (guarantee-condition-variable condvar 'CONDITION-VARIABLE-WAIT!/UNLOCK)
- (guarantee-thread-mutex thread-mutex 'CONDITION-VARIABLE-WAIT!/UNLOCK)
+ (guarantee-condition-variable condvar 'condition-variable-wait!/unlock)
+ (guarantee-thread-mutex thread-mutex 'condition-variable-wait!/unlock)
(%condition-variable-wait!/unlock condvar thread-mutex timeout))
(define (condition-variable-wait! condvar thread-mutex #!optional timeout)
- (guarantee-condition-variable condvar 'CONDITION-VARIABLE-WAIT!)
- (guarantee-thread-mutex thread-mutex 'CONDITION-VARIABLE-WAIT!)
+ (guarantee-condition-variable condvar 'condition-variable-wait!)
+ (guarantee-thread-mutex thread-mutex 'condition-variable-wait!)
(begin0 (%condition-variable-wait!/unlock condvar thread-mutex timeout)
(lock-thread-mutex thread-mutex)))
(unblock-thread-events)))))))
\f
(define (condition-variable-signal! condvar)
- (guarantee-condition-variable condvar 'CONDITION-VARIABLE-SIGNAL!)
+ (guarantee-condition-variable condvar 'condition-variable-signal!)
(with-thread-mutex-lock (condition-variable.lock condvar)
(lambda ()
(let ((head (condition-variable.waiter-head condvar))
unspecific)
(define (condition-variable-broadcast! condvar)
- (guarantee-condition-variable condvar 'CONDITION-VARIABLE-BROADCAST!)
+ (guarantee-condition-variable condvar 'condition-variable-broadcast!)
(with-thread-mutex-lock (condition-variable.lock condvar)
(lambda ()
(let ((head (condition-variable.waiter-head condvar))
(history-reductions history))))
(define undefined-history
- (list 'UNDEFINED-HISTORY))
+ (list 'undefined-history))
(define (stack-frame/next stack-frame)
(let ((next (stack-frame/%next stack-frame)))
marker-instance)
(parser-state/block-thread-events? state)
(parser-state/interrupt-mask state)))
- ((eq? marker-type 'SET-INTERRUPT-ENABLES!)
+ ((eq? marker-type 'set-interrupt-enables!)
(continue (parser-state/dynamic-state state)
(parser-state/block-thread-events? state)
marker-instance))
- ((eq? marker-type 'WITH-THREAD-EVENTS-BLOCKED)
+ ((eq? marker-type 'with-thread-events-blocked)
(continue (parser-state/dynamic-state state)
marker-instance
(parser-state/interrupt-mask state)))
(stack-frame/interrupt-mask stack-frame)
(let ((history (stack-frame/history stack-frame)))
(if (eq? history undefined-history)
- (fixed-objects-item 'DUMMY-HISTORY)
+ (fixed-objects-item 'dummy-history)
(history-untransform history)))
(stack-frame/previous-history-offset stack-frame)
(stack-frame/previous-history-control-point stack-frame)
stream
(begin
(if (not (stream-pair? stream))
- (error:wrong-type-argument stream "stream" 'STREAM-TAIL*))
+ (error:wrong-type-argument stream "stream" 'stream-tail*))
(stream-tail* (stream-cdr stream) (fix:- n 1)))))
\f
;;;; Stack Frame Types
(define (microcode-return/code->type code)
(if (not (fix:< code (vector-length stack-frame-types)))
- (error:bad-range-argument code 'MICROCODE-RETURN/CODE->TYPE))
+ (error:bad-range-argument code 'microcode-return/code->type))
(vector-ref stack-frame-types code))
(define (microcode-return/name->type name)
stack-frame-type/interrupt-compiled-expression)
(else
(error:bad-range-argument return-address
- 'RETURN-ADDRESS->STACK-FRAME-TYPE))))
+ 'return-address->stack-frame-type))))
(define (initialize-package!)
(set! return-address/join-stacklets
- (make-return-address (microcode-return 'JOIN-STACKLETS)))
+ (make-return-address (microcode-return 'join-stacklets)))
(set! return-address/reenter-compiled-code
- (make-return-address (microcode-return 'REENTER-COMPILED-CODE)))
+ (make-return-address (microcode-return 'reenter-compiled-code)))
(set! stack-frame-types (make-stack-frame-types))
(set! stack-frame-type/hardware-trap
- (microcode-return/name->type 'HARDWARE-TRAP))
+ (microcode-return/name->type 'hardware-trap))
(set! stack-frame-type/stack-marker
- (microcode-return/name->type 'STACK-MARKER))
+ (microcode-return/name->type 'stack-marker))
(set! stack-frame-type/compiled-return-address
(make-stack-frame-type #f #t #f length/compiled-return-address
parser/standard-compiled))
(stack-frame-type name #t #f length
(if (default-object? parser) parser/standard parser)))
- (standard-frame 'HALT 2)
- (standard-frame 'JOIN-STACKLETS 2)
- (standard-frame 'NON-EXISTENT-CONTINUATION 2)
- (standard-frame 'POP-RETURN-ERROR 2)
- (standard-frame 'RESTORE-VALUE 2)
+ (standard-frame 'halt 2)
+ (standard-frame 'join-stacklets 2)
+ (standard-frame 'non-existent-continuation 2)
+ (standard-frame 'pop-return-error 2)
+ (standard-frame 'restore-value 2)
- (standard-frame 'RESTORE-DONT-COPY-HISTORY 4 parser/restore-history)
- (standard-frame 'RESTORE-HISTORY 4 parser/restore-history)
- (standard-frame 'RESTORE-INTERRUPT-MASK 2 parser/restore-interrupt-mask)
- (standard-frame 'STACK-MARKER 3 parser/stack-marker)
+ (standard-frame 'restore-dont-copy-history 4 parser/restore-history)
+ (standard-frame 'restore-history 4 parser/restore-history)
+ (standard-frame 'restore-interrupt-mask 2 parser/restore-interrupt-mask)
+ (standard-frame 'stack-marker 3 parser/stack-marker)
- (standard-subproblem 'ACCESS-CONTINUE 2)
- (standard-subproblem 'ASSIGNMENT-CONTINUE 3)
- (standard-subproblem 'CONDITIONAL-DECIDE 3)
- (standard-subproblem 'DEFINITION-CONTINUE 3)
- (standard-subproblem 'DISJUNCTION-DECIDE 3)
- (standard-subproblem 'EVAL-ERROR 3)
- (standard-subproblem 'FORCE-SNAP-THUNK 2)
- (standard-subproblem 'SEQUENCE-CONTINUE 3)
+ (standard-subproblem 'access-continue 2)
+ (standard-subproblem 'assignment-continue 3)
+ (standard-subproblem 'conditional-decide 3)
+ (standard-subproblem 'definition-continue 3)
+ (standard-subproblem 'disjunction-decide 3)
+ (standard-subproblem 'eval-error 3)
+ (standard-subproblem 'force-snap-thunk 2)
+ (standard-subproblem 'sequence-continue 3)
- (standard-subproblem 'COMBINATION-SAVE-VALUE length/combination-save-value)
+ (standard-subproblem 'combination-save-value length/combination-save-value)
(let ((length (length/application-frame 2 0)))
- (standard-subproblem 'COMBINATION-APPLY length)
- (non-history-subproblem 'INTERNAL-APPLY length parser/apply)
- (non-history-subproblem 'INTERNAL-APPLY-VAL length parser/apply))
+ (standard-subproblem 'combination-apply length)
+ (non-history-subproblem 'internal-apply length parser/apply)
+ (non-history-subproblem 'internal-apply-val length parser/apply))
(let ((compiler-frame
(lambda (name length)
(stack-frame-type name #t #t length parser/standard))))
(let ((length (length/application-frame 4 0)))
- (compiler-subproblem 'COMPILER-LOOKUP-APPLY-TRAP-RESTART length)
- (compiler-subproblem 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART length))
+ (compiler-subproblem 'compiler-lookup-apply-trap-restart length)
+ (compiler-subproblem 'compiler-operator-lookup-trap-restart length))
- (stack-frame-type 'COMPILER-INTERRUPT-RESTART #f #t
+ (stack-frame-type 'compiler-interrupt-restart #f #t
length/compiler-interrupt-restart
parser/compiler-interrupt-restart)
- (compiler-frame 'COMPILER-LINK-CACHES-RESTART 8)
- (compiler-frame 'REENTER-COMPILED-CODE 2)
+ (compiler-frame 'compiler-link-caches-restart 8)
+ (compiler-frame 'reenter-compiled-code 2)
- (compiler-subproblem 'COMPILER-ASSIGNMENT-TRAP-RESTART 5)
- (compiler-subproblem 'COMPILER-REFERENCE-TRAP-RESTART 4)
- (compiler-subproblem 'COMPILER-SAFE-REFERENCE-TRAP-RESTART 4)
- (compiler-subproblem 'COMPILER-UNASSIGNED?-TRAP-RESTART 4)
+ (compiler-subproblem 'compiler-assignment-trap-restart 5)
+ (compiler-subproblem 'compiler-reference-trap-restart 4)
+ (compiler-subproblem 'compiler-safe-reference-trap-restart 4)
+ (compiler-subproblem 'compiler-unassigned?-trap-restart 4)
- (compiler-subproblem 'COMPILER-ERROR-RESTART 3))
+ (compiler-subproblem 'compiler-error-restart 3))
- (non-history-subproblem 'HARDWARE-TRAP length/hardware-trap)
+ (non-history-subproblem 'hardware-trap length/hardware-trap)
types))
\f
;;;; Hardware trap parsing
(define (initialize-package!)
(let ((input-channel (tty-input-channel))
(output-channel (tty-output-channel))
- (gtype (generic-i/o-port-type 'CHANNEL 'CHANNEL)))
+ (gtype (generic-i/o-port-type 'channel 'channel)))
(let ((type
(make-textual-port-type
- `((BEEP ,operation/beep)
- (CHAR-READY? ,generic-io/char-ready?)
- (CLEAR ,operation/clear)
- (DISCRETIONARY-WRITE-CHAR ,operation/discretionary-write-char)
- (DISCRETIONARY-FLUSH-OUTPUT ,generic-io/flush-output)
- (PEEK-CHAR ,generic-io/peek-char)
- (READ-CHAR ,operation/read-char)
- (READ-FINISH ,operation/read-finish)
- (UNREAD-CHAR ,generic-io/unread-char)
- (WRITE-SELF ,operation/write-self)
- (X-SIZE ,operation/x-size)
- (Y-SIZE ,operation/y-size))
+ `((beep ,operation/beep)
+ (char-ready? ,generic-io/char-ready?)
+ (clear ,operation/clear)
+ (discretionary-write-char ,operation/discretionary-write-char)
+ (discretionary-flush-output ,generic-io/flush-output)
+ (peek-char ,generic-io/peek-char)
+ (read-char ,operation/read-char)
+ (read-finish ,operation/read-finish)
+ (unread-char ,generic-io/unread-char)
+ (write-self ,operation/write-self)
+ (x-size ,operation/x-size)
+ (y-size ,operation/y-size))
gtype)))
(let ((port
(make-textual-port type
(define (make-cstate input-channel output-channel)
(make-gstate (make-binary-port (make-channel-input-source input-channel)
(make-channel-output-sink output-channel))
- 'TEXT
- 'TEXT
+ 'text
+ 'text
(default-object)
(channel-type=file? input-channel)))
(define (set-console-i/o-port! port)
(if (not (i/o-port? port))
- (error:wrong-type-argument port "I/O port" 'SET-CONSOLE-I/O-PORT!))
+ (error:wrong-type-argument port "I/O port" 'set-console-i/o-port!))
(set! console-i/o-port port)
(set! console-input-port port)
(set! console-output-port port)
(%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?)
(define (make-decoded-time second minute hour day month year #!optional zone)
(check-decoded-time-args second minute hour day month year
- 'MAKE-DECODED-TIME)
+ '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 (rfc2822-string->decoded-time string)
(let ((v (*parse-string parser:rfc2822-time string)))
(if (not v)
- (error:bad-range-argument string 'STRING->DECODED-TIME))
+ (error:bad-range-argument string 'string->decoded-time))
(vector-ref v 0)))
(define (string->universal-time string)
(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)
(define (string->time-zone string)
(let ((v (*parse-string parser:time-zone string)))
(if (not v)
- (error:bad-range-argument string 'STRING->TIME-ZONE))
+ (error:bad-range-argument string 'string->time-zone))
(vector-ref v 0)))
(define parser:time-zone
(*parse-string (parser:ctime (if (default-object? zone) #f zone))
string)))
(if (not v)
- (error:bad-range-argument string 'CTIME-STRING->DECODED-TIME))
+ (error:bad-range-argument string 'ctime-string->decoded-time))
(vector-ref v 0)))
(define (universal-time->local-ctime-string time)
\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)
(define (iso8601-string->decoded-time string #!optional start end)
(let ((v (*parse-string parser:iso8601-date/time string start end)))
(if (not v)
- (error:bad-range-argument string 'ISO8601-STRING->DECODED-TIME))
+ (error:bad-range-argument string 'iso8601-string->decoded-time))
(vector-ref v 0)))
(define (xml-rpc-iso8601-string->decoded-time string #!optional start end)
(let ((v (*parse-string parser:xml-rpc-iso8601-date/time string start end)))
(if (not v)
(error:bad-range-argument string
- 'XML-RPC-ISO8601-STRING->DECODED-TIME))
+ 'xml-rpc-iso8601-string->decoded-time))
(vector-ref v 0)))
(define (decoded-time->iso8601-string dt)
;;;; Utilities
(define (month/max-days month)
- (guarantee-month month 'MONTH/MAX-DAYS)
+ (guarantee-month month 'month/max-days)
(vector-ref '#(31 29 31 30 31 30 31 31 30 31 30 31) (- month 1)))
(define (month/short-string month)
- (guarantee-month month 'MONTH/SHORT-STRING)
+ (guarantee-month month 'month/short-string)
(vector-ref month/short-strings (- month 1)))
(define (month/long-string month)
- (guarantee-month month 'MONTH/LONG-STRING)
+ (guarantee-month month 'month/long-string)
(vector-ref month/long-strings (- month 1)))
(define (guarantee-month month name)
(error "Unknown month designation:" string))))
(define (day-of-week/short-string day)
- (guarantee-day-of-week day 'DAY-OF-WEEK/SHORT-STRING)
+ (guarantee-day-of-week day 'day-of-week/short-string)
(vector-ref days-of-week/short-strings day))
(define (day-of-week/long-string day)
- (guarantee-day-of-week day 'DAY-OF-WEEK/LONG-STRING)
+ (guarantee-day-of-week day 'day-of-week/long-string)
(vector-ref days-of-week/long-strings day))
(define (guarantee-day-of-week day name)
(define (string->year string)
(let ((n (string->number string)))
(if (not (exact-nonnegative-integer? n))
- (error:bad-range-argument string 'STRING->YEAR))
+ (error:bad-range-argument string 'string->year))
(cond ((< n 70) (+ 2000 n))
((< n 100) (+ 1900 n))
(else n))))
(let loop ()
(let ((entry
(assv (char-upcase
- (prompt-for-command-char (cons 'STANDARD prompt)
+ (prompt-for-command-char (cons 'standard prompt)
port))
(cdr command-set))))
(if entry
(define (debug/read-eval-print environment from to)
(leaving-command-loop
(lambda ()
- (with-simple-restart 'CONTINUE
+ (with-simple-restart 'continue
(lambda (port)
(write-string "Return to " port)
(write-string from port)
#f))
(define (default-type-name context)
- (symbol 'RTD: (parser-context/name context)))
+ (symbol 'rtd: (parser-context/name context)))
\f
(define (apply-option-transformers options context)
(let loop ((options options))
(error "Duplicate slot option:" previous option)))
(set! options-seen (cons option options-seen))
(case keyword
- ((TYPE)
+ ((type)
(set! type
(cond ((true-marker? argument) #t)
((symbol? argument) argument)
(else (error "Illegal slot option:" option)))))
- ((READ-ONLY)
+ ((read-only)
(set! read-only?
(cond ((false-marker? argument) #f)
((true-marker? argument) #t)
;;;; Code Generation
(define (absolute name context)
- (close-syntax `(ACCESS ,name SYSTEM-GLOBAL-ENVIRONMENT)
+ (close-syntax `(access ,name system-global-environment)
(parser-context/closing-environment context)))
(define (close name context)
(define (initialize-dragon4!)
(set! param:flonum-unparser-cutoff
- (make-settable-parameter 'NORMAL
+ (make-settable-parameter 'normal
(lambda (cutoff)
(guarantee-cutoff-spec cutoff)
cutoff)))
(if (default-object? flonum-unparser-cutoff)
(param:flonum-unparser-cutoff)
flonum-unparser-cutoff)))
- (cond ((eq? 'NORMAL cutoff)
- (values 'NORMAL 0 flonum-unparser:normal-output))
+ (cond ((eq? 'normal cutoff)
+ (values 'normal 0 flonum-unparser:normal-output))
((compound-cutoff-spec? cutoff)
(values (car cutoff)
(- (cadr cutoff))
(else
(warn "illegal flonum unparser cutoff parameter"
cutoff)
- (values 'NORMAL 0 flonum-unparser:normal-output)))))
+ (values 'normal 0 flonum-unparser:normal-output)))))
(define (cutoff-spec? cutoff)
- (or (eq? 'NORMAL cutoff)
+ (or (eq? 'normal cutoff)
(compound-cutoff-spec? cutoff)))
(define (compound-cutoff-spec? cutoff)
(pair? (cdr cutoff))
(let ((mode (car cutoff))
(place (cadr cutoff)))
- (and (memq mode '(ABSOLUTE RELATIVE NORMAL))
+ (and (memq mode '(absolute relative normal))
(exact-integer? place)
- (or (not (eq? 'RELATIVE mode))
+ (or (not (eq? 'relative mode))
(positive? place))))
(or (null? (cddr cutoff))
(and (pair? (cddr cutoff))
(null? (cdddr cutoff))
(let ((mode (caddr cutoff)))
- (or (memq mode '(NORMAL SCIENTIFIC ENGINEERING))
+ (or (memq mode '(normal scientific engineering))
(and (procedure? mode)
(procedure-arity-valid? mode 3))))))))
(define (lookup-symbolic-display-mode mode)
(case mode
- ((ENGINEERING) flonum-unparser:engineering-output)
- ((SCIENTIFIC) flonum-unparser:scientific-output)
- ((NORMAL) flonum-unparser:normal-output)
+ ((engineering) flonum-unparser:engineering-output)
+ ((scientific) flonum-unparser:scientific-output)
+ ((normal) flonum-unparser:normal-output)
(else mode)))
(define (dragon4-normalize x precision)
(loop k s m- m+ round-up?)
(values k r s m- m+ cutoff round-up?)))))))
(case cutoff-mode
- ((NORMAL)
+ ((normal)
(values k r s m- m+
(- k (flo:significand-digits radix) 2) ; i.e. ignore cutoff
round-up?))
- ((ABSOLUTE) (cutoff-adjust cutoff))
- ((RELATIVE) (cutoff-adjust (+ k cutoff)))
+ ((absolute) (cutoff-adjust cutoff))
+ ((relative) (cutoff-adjust (+ k cutoff)))
(else (error:wrong-type-datum cutoff-mode #f))))
(let ((2r+m+ (int:+ 2r m+)))
("procedure" (runtime procedure))
("process" (runtime subprocess))
("prop1d" (runtime 1d-property))
- ("prop2d" (runtime 2D-property))
+ ("prop2d" (runtime 2d-property))
("qsort" (runtime quick-sort))
("queue" (runtime simple-queue))
("random" (runtime random-number))
("world-report" (runtime world-report))
("wrkdir" (runtime working-directory))
("wttree" (runtime wt-tree))
- ("x11graph" (runtime X-graphics))
+ ("x11graph" (runtime x-graphics))
("xeval" (runtime extended-scode-eval))
("ystep" (runtime stepper))))
\ No newline at end of file
(string-append (number->string level)
" "
(if (and (pair? prompt)
- (eq? 'STANDARD (car prompt)))
+ (eq? 'standard (car prompt)))
(let ((entry (assoc (cdr prompt) cmdl-prompt-alist)))
(if entry
(cadr entry)
(loop)))
#t)
-(define (emacs/^G-interrupt)
+(define (emacs/^g-interrupt)
(transmit-signal the-console-port #\g))
\f
;;;; Miscellaneous Hooks
(define (emacs/read-start port)
(transmit-signal port #\s)
- (let ((operation (deferred-operation 'READ-START)))
+ (let ((operation (deferred-operation 'read-start)))
(if operation
(operation port))))
(define (emacs/read-finish port)
- (let ((operation (deferred-operation 'READ-FINISH)))
+ (let ((operation (deferred-operation 'read-finish)))
(if operation
(operation port)))
(transmit-signal port #\f))
(set! vanilla-console-port-type (textual-port-type the-console-port))
(set! emacs-console-port-type
(make-textual-port-type
- `((PROMPT-FOR-EXPRESSION ,emacs/prompt-for-expression)
- (PROMPT-FOR-COMMAND-CHAR ,emacs/prompt-for-command-char)
- (PROMPT-FOR-COMMAND-EXPRESSION ,emacs/prompt-for-command-expression)
- (PROMPT-FOR-CONFIRMATION ,emacs/prompt-for-confirmation)
- (DEBUGGER-FAILURE ,emacs/debugger-failure)
- (DEBUGGER-MESSAGE ,emacs/debugger-message)
- (DEBUGGER-PRESENTATION ,emacs/debugger-presentation)
- (WRITE-RESULT ,emacs/write-result)
- (SET-DEFAULT-DIRECTORY ,emacs/set-default-directory)
- (READ-START ,emacs/read-start)
- (READ-FINISH ,emacs/read-finish)
- (GC-START ,emacs/gc-start)
- (GC-FINISH ,emacs/gc-finish))
+ `((prompt-for-expression ,emacs/prompt-for-expression)
+ (prompt-for-command-char ,emacs/prompt-for-command-char)
+ (prompt-for-command-expression ,emacs/prompt-for-command-expression)
+ (prompt-for-confirmation ,emacs/prompt-for-confirmation)
+ (debugger-failure ,emacs/debugger-failure)
+ (debugger-message ,emacs/debugger-message)
+ (debugger-presentation ,emacs/debugger-presentation)
+ (write-result ,emacs/write-result)
+ (set-default-directory ,emacs/set-default-directory)
+ (read-start ,emacs/read-start)
+ (read-finish ,emacs/read-finish)
+ (gc-start ,emacs/gc-start)
+ (gc-finish ,emacs/gc-finish))
vanilla-console-port-type))
(add-event-receiver! event:after-restore
(lambda ()
(begin
(set! hook/clean-input/flush-typeahead
emacs/clean-input/flush-typeahead)
- (set! hook/^G-interrupt emacs/^G-interrupt)
+ (set! hook/^g-interrupt emacs/^g-interrupt)
(set! hook/error-decision emacs/error-decision)
emacs-console-port-type)
(begin
(set! hook/clean-input/flush-typeahead #f)
- (set! hook/^G-interrupt #f)
+ (set! hook/^g-interrupt #f)
(set! hook/error-decision #f)
vanilla-console-port-type)))
((closure-ccenv? environment)
(closure-ccenv/has-parent? environment))
(else
- (error:not-a environment? environment 'ENVIRONMENT-HAS-PARENT?))))
+ (error:not-a environment? environment 'environment-has-parent?))))
(define (environment-parent environment)
(cond ((system-global-environment? environment)
- (error:bad-range-argument environment 'ENVIRONMENT-PARENT))
+ (error:bad-range-argument environment 'environment-parent))
((ic-environment? environment)
(ic-environment/parent environment))
((stack-ccenv? environment)
((closure-ccenv? environment)
(closure-ccenv/parent environment))
(else
- (error:not-a 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
- (error:not-a 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
- (error:not-a environment? environment 'ENVIRONMENT-MACRO-NAMES))))
+ (error:not-a environment? environment 'environment-macro-names))))
\f
(define (environment-bindings environment)
(let ((items (environment-bound-names environment)))
(stack-ccenv/arguments environment))
((or (system-global-environment? environment)
(closure-ccenv? environment))
- 'UNKNOWN)
+ 'unknown)
(else
- (error:not-a 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
- (error:not-a environment? environment 'ENVIRONMENT-LAMBDA))))
+ (error:not-a environment? environment 'environment-lambda))))
(define (environment-bound? environment name)
- (not (eq? 'UNBOUND (environment-reference-type environment name))))
+ (not (eq? 'unbound (environment-reference-type environment name))))
(define (environment-reference-type environment name)
(cond ((interpreter-environment? environment)
((closure-ccenv? environment)
(closure-ccenv/reference-type environment name))
(else
- (error:not-a environment? environment 'ENVIRONMENT-REFERENCE-TYPE))))
+ (error:not-a environment? environment 'environment-reference-type))))
(define (environment-assigned? environment name)
(case (environment-reference-type environment name)
- ((UNBOUND) (error:unbound-variable environment name))
- ((MACRO) (error:macro-binding environment name))
- ((UNASSIGNED) #f)
+ ((unbound) (error:unbound-variable environment name))
+ ((macro) (error:macro-binding environment name))
+ ((unassigned) #f)
(else #t)))
\f
(define (environment-lookup environment name)
(define (environment-lookup-or environment name no-value)
(case (environment-reference-type environment name)
- ((UNBOUND UNASSIGNED) (no-value))
- ((MACRO) (error:macro-binding environment name))
+ ((unbound unassigned) (no-value))
+ ((macro) (error:macro-binding environment name))
(else (environment-lookup environment name))))
(define (environment-lookup-macro environment name)
- (and (eq? 'MACRO (environment-reference-type environment name))
+ (and (eq? 'macro (environment-reference-type environment name))
(let ((value (environment-safe-lookup environment name)))
(and (macro-reference-trap? value)
(macro-reference-trap-transformer value)))))
((closure-ccenv? environment)
(closure-ccenv/safe-lookup environment name))
(else
- (error:not-a 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
- (error:not-a 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
- (error:not-a 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 (error:not-a environment? environment 'ENVIRONMENT-DEFINABLE?))))
+ (else (error:not-a environment? environment 'environment-definable?))))
(define (environment-define environment name value)
(cond ((interpreter-environment? environment)
(interpreter-environment/define environment name value))
((or (stack-ccenv? environment)
(closure-ccenv? environment))
- (error:bad-range-argument environment 'ENVIRONMENT-DEFINE))
+ (error:bad-range-argument environment 'environment-define))
(else
- (error:not-a environment? environment 'ENVIRONMENT-DEFINE))))
+ (error:not-a environment? environment 'environment-define))))
(define (environment-define-macro environment name value)
(cond ((interpreter-environment? environment)
(interpreter-environment/define-macro environment name value))
((or (stack-ccenv? environment)
(closure-ccenv? environment))
- (error:bad-range-argument environment 'ENVIRONMENT-DEFINE-MACRO))
+ (error:bad-range-argument environment 'environment-define-macro))
(else
- (error:not-a environment? environment 'ENVIRONMENT-DEFINE-MACRO))))
+ (error:not-a environment? environment 'environment-define-macro))))
\f
;;;; Global environment
(define (interpreter-environment/reference-type environment name)
(let ((i ((ucode-primitive lexical-reference-type 2) environment name))
- (v '#(UNBOUND UNASSIGNED NORMAL MACRO)))
+ (v '#(unbound unassigned normal macro)))
(if (not (fix:< i (vector-length v)))
- (error "Unknown reference type:" i 'ENVIRONMENT-REFERENCE-TYPE))
+ (error "Unknown reference type:" i 'environment-reference-type))
(vector-ref v i)))
(define (interpreter-environment/safe-lookup environment name)
(define (interpreter-environment/assignable? environment name)
(case (interpreter-environment/reference-type environment name)
- ((UNBOUND) (error:unbound-variable environment name))
- ((MACRO) (error:macro-binding environment name))
+ ((unbound) (error:unbound-variable environment name))
+ ((macro) (error:macro-binding environment name))
(else #t)))
(define (interpreter-environment/assign! environment name value)
(define (ic-environment/parent environment)
(let ((parent (ic-frame-parent environment)))
(if (not (interpreter-environment? parent))
- (error:bad-range-argument environment 'ENVIRONMENT-PARENT))
+ (error:bad-range-argument environment 'environment-parent))
parent))
(define (ic-frame-parent environment)
\f
(define (extend-top-level-environment environment #!optional names values)
(if (not (interpreter-environment? environment))
- (error:not-a 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)
- 'EXTEND-TOP-LEVEL-ENVIRONMENT))
+ (if (default-object? values) 'default values)
+ 'extend-top-level-environment))
(define (make-top-level-environment #!optional names values)
(%extend-top-level-environment system-global-environment
(if (default-object? names) '() names)
- (if (default-object? values) 'DEFAULT values)
- 'MAKE-TOP-LEVEL-ENVIRONMENT))
+ (if (default-object? values) 'default values)
+ 'make-top-level-environment))
(define (make-root-top-level-environment #!optional names values)
(%extend-top-level-environment (object-new-type (object-type #f)
(fix:xor (object-datum #f)
1))
(if (default-object? names) '() names)
- (if (default-object? values) 'DEFAULT values)
- 'MAKE-ROOT-TOP-LEVEL-ENVIRONMENT))
+ (if (default-object? values) 'default values)
+ 'make-root-top-level-environment))
(define (%extend-top-level-environment environment names values procedure)
(if (not (list-of-type? names symbol?))
names
unspecific)
environment)
- (if (eq? values 'DEFAULT)
+ (if (eq? values 'default)
(let ((values (make-list (length names))))
(do ((values values (cdr values)))
((not (pair? values)))
(let ((block (dbg-continuation/block object)))
(let ((parent (dbg-block/parent block)))
(case (dbg-block/type parent)
- ((STACK)
+ ((stack)
(make-stack-ccenv parent
frame
(+ (dbg-continuation/offset object)
(dbg-block/length block))))
- ((IC)
+ ((ic)
(let ((index (dbg-block/ic-parent-index block)))
(if index
(guarantee-interpreter-environment
((dbg-procedure? object)
(let ((block (dbg-procedure/block object)))
(case (dbg-block/type block)
- ((STACK)
+ ((stack)
(make-stack-ccenv block
frame
(if (compiled-closure? ret-add) 0 1)))
(define (compiled-procedure/environment entry)
(if (not (compiled-procedure? entry))
- (error "Not a compiled procedure" entry 'COMPILED-PROCEDURE/ENVIRONMENT))
+ (error "Not a compiled procedure" entry 'compiled-procedure/environment))
(let ((procedure (compiled-entry/dbg-object entry)))
(if (not procedure)
(error "Unable to obtain closing environment" entry))
(compiled-code-address->block entry))))
(if parent
(case (dbg-block/type parent)
- ((CLOSURE)
+ ((closure)
(make-closure-ccenv (dbg-block/original-parent block)
parent
entry))
- ((IC)
+ ((ic)
(use-compile-code-block-environment))
(else
(error "Illegal procedure parent block" parent)))
(define (stack-ccenv/has-parent? environment)
(if (dbg-block/parent (stack-ccenv/block environment))
#t
- 'SIMULATED))
+ 'simulated))
(define (stack-ccenv/parent environment)
(let ((block (stack-ccenv/block environment)))
(let ((parent (dbg-block/parent block)))
(if parent
(case (dbg-block/type parent)
- ((STACK)
+ ((stack)
(let loop
((block block)
(frame (stack-ccenv/frame environment))
(+ (vector-length
(dbg-block/layout-vector stack-link))
(case (dbg-block/type stack-link)
- ((STACK)
+ ((stack)
0)
- ((CONTINUATION)
+ ((continuation)
(dbg-continuation/offset
(dbg-block/procedure stack-link)))
(else
(error "illegal stack-link type"
stack-link)))
index)))))))
- ((CLOSURE)
+ ((closure)
(make-closure-ccenv (dbg-block/original-parent block)
parent
(stack-ccenv/normal-closure environment)))
- ((IC)
+ ((ic)
(guarantee-interpreter-environment
(if (dbg-block/static-link-index block)
(stack-ccenv/static-link environment)
(letrec ((lookup
(lambda (variable)
(case (dbg-variable/type variable)
- ((INTEGRATED)
+ ((integrated)
(dbg-variable/value variable))
- ((INDIRECTED)
+ ((indirected)
(lookup (dbg-variable/value variable)))
(else
(stack-ccenv/safe-lookup
(dbg-procedure/optional procedure))
lookup
(dbg-procedure/required procedure)))
- 'UNKNOWN)))
+ 'unknown)))
(define (stack-ccenv/bound-names environment)
(map dbg-variable/name
(dbg-block/layout-vector (closure-ccenv/stack-block environment)))
(lambda (variable)
(and (dbg-variable? variable)
- (or (eq? (dbg-variable/type variable) 'INTEGRATED)
+ (or (eq? (dbg-variable/type variable) 'integrated)
(vector-find-next-element
(dbg-block/layout-vector
(closure-ccenv/closure-block environment))
(let ((parent (dbg-block/parent stack-block)))
(and parent
(case (dbg-block/type parent)
- ((CLOSURE) (and (dbg-block/original-parent stack-block) #t))
- ((STACK IC) #t)
+ ((closure) (and (dbg-block/original-parent stack-block) #t))
+ ((stack ic) #t)
(else (error "Illegal parent block" parent))))))
- 'SIMULATED))
+ 'simulated))
(define (closure-ccenv/parent environment)
(let ((stack-block (closure-ccenv/stack-block environment))
system-global-environment))))
(if parent
(case (dbg-block/type parent)
- ((STACK)
+ ((stack)
(make-closure-ccenv parent closure-block closure))
- ((CLOSURE)
+ ((closure)
(let ((parent (dbg-block/original-parent stack-block)))
(if parent
(make-closure-ccenv parent closure-block closure)
(use-simulation))))
- ((IC)
+ ((ic)
(guarantee-interpreter-environment
(let ((index (dbg-block/ic-parent-index closure-block)))
(if index
(if index
(let ((variable (vector-ref (dbg-block/layout-vector block) index)))
(case (dbg-variable/type variable)
- ((NORMAL)
+ ((normal)
(get-value index))
- ((CELL)
+ ((cell)
(let ((value (get-value index)))
(if (not (cell? value))
(error "Value of variable should be in cell:"
variable value))
(cell-contents value)))
- ((INTEGRATED)
+ ((integrated)
(dbg-variable/value variable))
- ((INDIRECTED)
+ ((indirected)
(loop (dbg-variable/name (dbg-variable/value variable))))
(else
(error "Unknown variable type:" variable))))
(define (dbg-variable-reference-type block name get-value not-found)
(let ((value->reference-type
(lambda (value)
- (cond ((unassigned-reference-trap? value) 'UNASSIGNED)
- ((macro-reference-trap? value) 'MACRO)
- (else 'NORMAL)))))
+ (cond ((unassigned-reference-trap? value) 'unassigned)
+ ((macro-reference-trap? value) 'macro)
+ (else 'normal)))))
(let loop ((name name))
(let ((index (dbg-block/find-name block name)))
(if index
(let ((variable
(vector-ref (dbg-block/layout-vector block) index)))
(case (dbg-variable/type variable)
- ((NORMAL)
+ ((normal)
(value->reference-type (get-value index)))
- ((CELL)
+ ((cell)
(let ((value (get-value index)))
(if (not (cell? value))
(error "Value of variable should be in cell"
variable value))
(value->reference-type (cell-contents value))))
- ((INTEGRATED)
+ ((integrated)
(value->reference-type (dbg-variable/value variable)))
- ((INDIRECTED)
+ ((indirected)
(loop (dbg-variable/name (dbg-variable/value variable))))
(else
(error "Unknown variable type:" variable))))
(define (assignable-dbg-variable? block name not-found)
(let ((index (dbg-block/find-name block name)))
(if index
- (eq? 'CELL
+ (eq? 'cell
(dbg-variable/type
(vector-ref (dbg-block/layout-vector block)
index)))
(if index
(let ((variable (vector-ref (dbg-block/layout-vector block) index)))
(case (dbg-variable/type variable)
- ((CELL)
+ ((cell)
(let ((cell (get-value index)))
(if (not (cell? cell))
(error "Value of variable should be in cell:" name cell))
(set-cell-contents! cell value)
unspecific))
- ((NORMAL INTEGRATED INDIRECTED)
+ ((normal integrated indirected)
(error "Variable cannot be modified:" variable))
(else
(error "Unknown variable type:" variable))))
(constructor %make-condition-type
(name field-indexes number-of-fields reporter))
(print-procedure
- (standard-unparser-method 'CONDITION-TYPE
+ (standard-unparser-method 'condition-type
(lambda (type port)
(write-char #\space port)
(write-string (%condition-type/name type) port)))))
(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-condition-type generalization 'make-condition-type))
+ (guarantee list-of-unique-symbols? field-names 'make-condition-type)
(let ((type
(call-with-values
(lambda ()
((not name) "(anonymous)")
(else
(error:wrong-type-argument name "condition-type name"
- 'MAKE-CONDITION-TYPE)))
+ 'make-condition-type)))
field-indexes
n-fields
(cond ((string? reporter)
(else
(error:wrong-type-argument reporter
"condition-type reporter"
- 'MAKE-CONDITION-TYPE))))))))
+ 'make-condition-type))))))))
(set-%condition-type/generalizations!
type
(cons type
(cdr association)))
(define (condition-type/name type)
- (guarantee-condition-type type 'CONDITION-TYPE/NAME)
+ (guarantee-condition-type type 'condition-type/name)
(%condition-type/name type))
(define (condition-type/field-names type)
- (guarantee-condition-type type 'CONDITION-TYPE/FIELD-NAMES)
+ (guarantee-condition-type type 'condition-type/field-names)
(map car (%condition-type/field-indexes type)))
(define (condition-type/generalizations type)
- (guarantee-condition-type type 'CONDITION-TYPE/GENERALIZATIONS)
+ (guarantee-condition-type type 'condition-type/generalizations)
(list-copy (cdr (%condition-type/generalizations type))))
(define (condition-type/properties type)
- (guarantee-condition-type type 'CONDITION-TYPE/PROPERTIES)
+ (guarantee-condition-type type 'condition-type/properties)
(%condition-type/properties type))
(define (condition-type/put! type key datum)
(constructor %%make-condition
(type continuation restarts field-values))
(print-procedure
- (standard-unparser-method 'CONDITION
+ (standard-unparser-method 'condition
(lambda (condition port)
(write-char #\space port)
(write-string
(make-vector (%condition-type/number-of-fields type) #f)))
(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-condition-type type 'make-condition)
+ (guarantee continuation? continuation 'make-condition)
+ (guarantee unique-keyword-list? field-alist 'make-condition)
(let ((condition
(%make-condition type
continuation
- (%restarts-argument restarts 'MAKE-CONDITION))))
+ (%restarts-argument restarts 'make-condition))))
(let ((field-values (%condition/field-values condition)))
(do ((alist field-alist (cddr alist)))
((not (pair? alist)))
(vector-set! field-values
(%condition-type/field-index type (car alist)
- 'MAKE-CONDITION)
+ 'make-condition)
(cadr alist))))
condition))
constructor))))
\f
(define-integrable (%restarts-argument restarts operator)
- (cond ((eq? 'BOUND-RESTARTS restarts)
+ (cond ((eq? 'bound-restarts restarts)
(param:bound-restarts))
((condition? restarts)
(%condition/restarts restarts))
(list-copy restarts))))
(define (condition-of-type? object type)
- (guarantee-condition-type type 'CONDITION-OF-TYPE?)
+ (guarantee-condition-type type 'condition-of-type?)
(%condition-of-type? object type))
(define (condition-predicate type)
- (guarantee-condition-type type 'CONDITION-PREDICATE)
+ (guarantee-condition-type type 'condition-predicate)
(lambda (object) (%condition-of-type? object type)))
(define (%condition-of-type? object type)
(memq type (%condition-type/generalizations (%condition/type object)))))
(define (condition-accessor type field-name)
- (guarantee-condition-type type 'CONDITION-ACCESSOR)
- (guarantee symbol? field-name 'CONDITION-ACCESSOR)
+ (guarantee-condition-type type 'condition-accessor)
+ (guarantee symbol? field-name 'condition-accessor)
(let ((predicate (condition-predicate type))
(index
(%condition-type/field-index type
field-name
- 'CONDITION-ACCESSOR)))
+ 'condition-accessor)))
(lambda (condition)
(if (not (predicate condition))
(error:wrong-type-argument condition
(string-append "condition of type "
(write-to-string type))
- 'CONDITION-ACCESSOR))
+ 'condition-accessor))
(vector-ref (%condition/field-values condition) index))))
(define (access-condition condition field-name)
- (guarantee-condition condition 'ACCESS-CONDITION)
+ (guarantee-condition condition 'access-condition)
((condition-accessor (%condition/type condition) field-name) condition))
(define (condition/type condition)
- (guarantee-condition condition 'CONDITION/TYPE)
+ (guarantee-condition condition 'condition/type)
(%condition/type condition))
(define (condition/continuation condition)
- (guarantee-condition condition 'CONDITION/CONTINUATION)
+ (guarantee-condition condition 'condition/continuation)
(%condition/continuation condition))
(define (condition/restarts condition)
- (guarantee-condition condition 'CONDITION/RESTARTS)
+ (guarantee-condition condition 'condition/restarts)
(list-copy (%condition/restarts condition)))
(define (condition/properties condition)
- (guarantee-condition condition 'CONDITION/PROPERTIES)
+ (guarantee-condition condition 'condition/properties)
(%condition/properties condition))
(define (condition/put! condition key datum)
(1d-table/get (condition/properties condition) key #f))
(define (write-condition-report condition port)
- (guarantee-condition condition 'WRITE-CONDITION-REPORT)
- (guarantee textual-output-port? port 'WRITE-CONDITION-REPORT)
+ (guarantee-condition condition 'write-condition-report)
+ (guarantee textual-output-port? port 'write-condition-report)
(let ((reporter (%condition-type/reporter (%condition/type condition))))
(if (%condition/error? condition)
(ignore-errors (lambda () (reporter condition port)))
(constructor %make-restart
(name reporter effector interactor))
(print-procedure
- (standard-unparser-method 'RESTART
+ (standard-unparser-method 'restart
(lambda (restart port)
(write-char #\space port)
(let ((name (%restart/name restart)))
(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))
+ (error:wrong-type-argument reporter "reporter" 'with-restart))
(if (not (procedure? effector))
- (error:wrong-type-argument effector "effector" 'WITH-RESTART))
+ (error:wrong-type-argument effector "effector" 'with-restart))
(if (not (or (not interactor) (procedure? interactor)))
- (error:wrong-type-argument interactor "interactor" 'WITH-RESTART))
+ (error:wrong-type-argument interactor "interactor" 'with-restart))
(parameterize*
(list (cons param:bound-restarts
(cons (%make-restart name reporter effector interactor)
thunk))))
(define (restart/name restart)
- (guarantee-restart restart 'RESTART/NAME)
+ (guarantee-restart restart 'restart/name)
(%restart/name restart))
(define (write-restart-report restart port)
- (guarantee-restart restart 'WRITE-RESTART-REPORT)
- (guarantee textual-output-port? port 'WRITE-RESTART-REPORT)
+ (guarantee-restart restart 'write-restart-report)
+ (guarantee textual-output-port? port 'write-restart-report)
(let ((reporter (%restart/reporter restart)))
(if (string? reporter)
(write-string reporter port)
(reporter port))))
(define (restart/effector restart)
- (guarantee-restart restart 'RESTART/EFFECTOR)
+ (guarantee-restart restart 'restart/effector)
(%restart/effector restart))
(define (restart/interactor restart)
- (guarantee-restart restart 'RESTART/INTERACTOR)
+ (guarantee-restart restart 'restart/interactor)
(%restart/interactor restart))
(define (restart/properties restart)
- (guarantee-restart restart 'RESTART/PROPERTIES)
+ (guarantee-restart restart 'restart/properties)
(%restart/properties restart))
(define (restart/get restart key)
- (if (eq? key 'INTERACTIVE)
+ (if (eq? key 'interactive)
(restart/interactor restart)
(1d-table/get (restart/properties restart) key #f)))
(define (restart/put! restart key datum)
- (if (eq? key 'INTERACTIVE)
+ (if (eq? key 'interactive)
(set-%restart/interactor! restart datum)
(1d-table/put! (restart/properties restart) key datum)))
\f
(receiver (car (param:bound-restarts))))))
(define (invoke-restart restart . arguments)
- (guarantee-restart restart 'INVOKE-RESTART)
+ (guarantee-restart restart 'invoke-restart)
(hook/invoke-restart (%restart/effector restart) arguments))
(define (invoke-restart-interactively restart #!optional condition)
- (guarantee-restart restart 'INVOKE-RESTART-INTERACTIVELY)
+ (guarantee-restart restart 'invoke-restart-interactively)
(let ((effector (%restart/effector restart))
(arguments
(let ((interactor (%restart/interactor restart)))
(let ((thread (and condition (condition/other-thread condition))))
(if thread
(begin
- (restart-thread thread 'ASK
+ (restart-thread thread 'ask
(lambda ()
(hook/invoke-restart effector arguments)))
(continue-from-derived-thread-error condition))
(define (condition/other-thread condition)
(and (condition/derived-thread? condition)
- (let ((thread (access-condition condition 'THREAD)))
+ (let ((thread (access-condition condition 'thread)))
(and (not (eq? thread (current-thread)))
thread))))
(define (continue-from-derived-thread-error condition)
(let loop ((restarts (bound-restarts)))
(if (pair? restarts)
- (if (and (eq? 'CONTINUE (restart/name (car restarts)))
+ (if (and (eq? 'continue (restart/name (car restarts)))
(eq? condition
- (restart/get (car restarts) 'ASSOCIATED-CONDITION)))
+ (restart/get (car restarts) 'associated-condition)))
(invoke-restart (car restarts))
(loop (cdr restarts))))))
(loop (cdr restarts))))))
\f
(define (find-restart name #!optional restarts)
- (guarantee symbol? name 'FIND-RESTART)
- (%find-restart name (restarts-default restarts 'FIND-RESTART)))
+ (guarantee symbol? name 'find-restart)
+ (%find-restart name (restarts-default restarts 'find-restart)))
(define (abort #!optional restarts)
- (let ((restart (%find-restart 'ABORT (restarts-default restarts 'ABORT))))
+ (let ((restart (%find-restart 'abort (restarts-default restarts 'abort))))
(if (not restart)
- (error:no-such-restart 'ABORT))
+ (error:no-such-restart 'abort))
((%restart/effector restart))))
(define (continue #!optional restarts)
(let ((restart
- (%find-restart 'CONTINUE (restarts-default restarts 'CONTINUE))))
+ (%find-restart 'continue (restarts-default restarts 'continue))))
(if restart
((%restart/effector restart)))))
(define (muffle-warning #!optional restarts)
(let ((restart
- (%find-restart 'MUFFLE-WARNING
- (restarts-default restarts 'MUFFLE-WARNING))))
+ (%find-restart 'muffle-warning
+ (restarts-default restarts 'muffle-warning))))
(if (not restart)
- (error:no-such-restart 'MUFFLE-WARNING))
+ (error:no-such-restart 'muffle-warning))
((%restart/effector restart))))
(define (retry #!optional restarts)
(let ((restart
- (%find-restart 'RETRY (restarts-default restarts 'RETRY))))
+ (%find-restart 'retry (restarts-default restarts 'retry))))
(if restart
((%restart/effector restart)))))
(define (store-value datum #!optional restarts)
(let ((restart
- (%find-restart 'STORE-VALUE
- (restarts-default restarts 'STORE-VALUE))))
+ (%find-restart 'store-value
+ (restarts-default restarts 'store-value))))
(if restart
((%restart/effector restart) datum))))
(define (use-value datum #!optional restarts)
(let ((restart
- (%find-restart 'USE-VALUE
- (restarts-default restarts 'USE-VALUE))))
+ (%find-restart 'use-value
+ (restarts-default restarts 'use-value))))
(if restart
((%restart/effector restart) datum))))
(define (restarts-default restarts name)
(cond ((or (default-object? restarts)
- (eq? 'BOUND-RESTARTS restarts))
+ (eq? 'bound-restarts restarts))
(param:bound-restarts))
((condition? restarts)
(%condition/restarts restarts))
(define break-on-signals-types)
(define (bind-default-condition-handler types handler)
- (guarantee-condition-types types 'BIND-DEFAULT-CONDITION-HANDLER)
- (guarantee-condition-handler handler 'BIND-DEFAULT-CONDITION-HANDLER)
+ (guarantee-condition-types types 'bind-default-condition-handler)
+ (guarantee-condition-handler handler 'bind-default-condition-handler)
(static-handler-frames
(cons (cons types handler)
(static-handler-frames)))
unspecific)
(define (bind-condition-handler types handler thunk)
- (guarantee-condition-types types 'BIND-CONDITION-HANDLER)
- (guarantee-condition-handler handler 'BIND-CONDITION-HANDLER)
+ (guarantee-condition-types types 'bind-condition-handler)
+ (guarantee-condition-handler handler 'bind-condition-handler)
(parameterize*
(list (cons dynamic-handler-frames
(cons (cons types handler) (dynamic-handler-frames))))
(guarantee unary-procedure? object caller))
(define (break-on-signals types)
- (guarantee-condition-types types 'BREAK-ON-SIGNALS)
+ (guarantee-condition-types types 'break-on-signals)
(break-on-signals-types types)
unspecific)
(handler condition))
(define (signal-condition condition)
- (guarantee-condition condition 'SIGNAL-CONDITION)
+ (guarantee-condition condition 'signal-condition)
(let ((generalizations
(%condition-type/generalizations (%condition/type condition))))
(let ((intersect-generalizations?
(intersect-generalizations? types)))
(parameterize* (list (cons break-on-signals-types '()))
(lambda ()
- (breakpoint-procedure 'INHERIT
+ (breakpoint-procedure 'inherit
"BKPT entered because of BREAK-ON-SIGNALS:"
condition))))
(do ((frames (dynamic-handler-frames) (cdr frames)))
(signal-simple datum arguments make-simple-error standard-error-handler))
(define (warn datum . arguments)
- (with-simple-restart 'MUFFLE-WARNING "Ignore warning."
+ (with-simple-restart 'muffle-warning "Ignore warning."
(lambda ()
(signal-simple datum arguments
make-simple-warning standard-warning-handler))))
(if (condition-type? datum)
(make-condition datum
continuation
- 'BOUND-RESTARTS
+ 'bound-restarts
arguments)
(make-simple-condition continuation
- 'BOUND-RESTARTS
+ 'bound-restarts
datum
arguments))))
(begin
(parameterize* (list (cons param:standard-error-hook #f))
(lambda ()
(hook condition))))))
- (repl/start (push-repl 'INHERIT condition '() "error>")))
+ (repl/start (push-repl 'inherit condition '() "error>")))
(define (standard-warning-handler condition)
(let ((hook
(define param:standard-warning-hook)
(define (condition-signaller type field-names default-handler)
- (guarantee-condition-handler default-handler 'CONDITION-SIGNALLER)
+ (guarantee-condition-handler default-handler 'condition-signaller)
(let ((make-condition (condition-constructor type field-names)))
(lambda field-values
(call-with-current-continuation
(let ((condition
(apply make-condition
(cons* continuation
- 'BOUND-RESTARTS
+ 'bound-restarts
field-values))))
(signal-condition condition)
(default-handler condition)))))))
type field-names default-handler
index use-value-prompt use-value-message retry-message)
(guarantee-condition-handler default-handler
- 'SUBSTITUTABLE-VALUE-CONDITION-SIGNALLER)
+ 'substitutable-value-condition-signaller)
(let ((make-condition (condition-constructor type field-names))
(arity (length field-names)))
(letrec
(let ((condition
(apply make-condition
(cons* continuation
- 'BOUND-RESTARTS
+ 'bound-restarts
field-values))))
- (with-restart 'USE-VALUE
+ (with-restart 'use-value
(if (string? use-value-message)
use-value-message
(use-value-message condition))
(lambda ()
(values (prompt-for-evaluated-expression prompt))))
(lambda ()
- (with-restart 'RETRY
+ (with-restart 'retry
(if (string? retry-message)
retry-message
(retry-message condition))
(define condition/derived-thread?)
(define (condition-type/error? type)
- (guarantee-condition-type type 'CONDITION-TYPE/ERROR?)
+ (guarantee-condition-type type 'condition-type/error?)
(%condition-type/error? type))
(define (condition/error? condition)
- (guarantee-condition condition 'CONDITION/ERROR?)
+ (guarantee-condition condition 'condition/error?)
(%condition/error? condition))
(define-integrable (%condition/error? condition)
(lambda (effector arguments)
(apply effector arguments)))
(set! condition-type:serious-condition
- (make-condition-type 'SERIOUS-CONDITION #f '() #f))
+ (make-condition-type 'serious-condition #f '() #f))
(set! condition-type:warning
- (make-condition-type 'WARNING #f '() #f))
+ (make-condition-type 'warning #f '() #f))
(set! condition-type:error
- (make-condition-type 'ERROR condition-type:serious-condition '() #f))
+ (make-condition-type 'error condition-type:serious-condition '() #f))
(let ((reporter/simple-condition
(lambda (condition port)
- (format-error-message (access-condition condition 'MESSAGE)
- (access-condition condition 'IRRITANTS)
+ (format-error-message (access-condition condition 'message)
+ (access-condition condition 'irritants)
port))))
(set! condition-type:simple-condition
- (make-condition-type 'SIMPLE-CONDITION #f '(MESSAGE IRRITANTS)
+ (make-condition-type 'simple-condition #f '(message irritants)
reporter/simple-condition))
(set! condition-type:simple-error
- (make-condition-type 'SIMPLE-ERROR condition-type:error
- '(MESSAGE IRRITANTS)
+ (make-condition-type 'simple-error condition-type:error
+ '(message irritants)
reporter/simple-condition))
(set! condition-type:simple-warning
- (make-condition-type 'SIMPLE-WARNING condition-type:warning
- '(MESSAGE IRRITANTS)
+ (make-condition-type 'simple-warning condition-type:warning
+ '(message irritants)
reporter/simple-condition)))
(set! condition-type:illegal-datum
- (make-condition-type 'ILLEGAL-DATUM condition-type:error '(DATUM)
+ (make-condition-type 'illegal-datum condition-type:error '(datum)
(lambda (condition port)
(write-string "The object " port)
- (write (access-condition condition 'DATUM) port)
+ (write (access-condition condition 'datum) port)
(write-string " has been found in an inappropriate context."
port))))
(set! condition-type:datum-out-of-range
- (make-condition-type 'DATUM-OUT-OF-RANGE condition-type:illegal-datum
+ (make-condition-type 'datum-out-of-range condition-type:illegal-datum
'()
(lambda (condition port)
(write-string "The object " port)
- (write (access-condition condition 'DATUM) port)
+ (write (access-condition condition 'datum) port)
(write-string " is not in the correct range." port))))
\f
(let ((write-type-description
(let ((char-set:vowels
(char-set #\a #\e #\i #\o #\u #\A #\E #\I #\O #\U)))
(lambda (condition port)
- (let ((type (access-condition condition 'TYPE)))
+ (let ((type (access-condition condition 'type)))
(if (string? type)
(begin
(if (not (or (string-null? type)
(write-string "the correct type" port))))))
(write-operand-description
(lambda (condition port)
- (let ((operator (access-condition condition 'OPERATOR))
- (operand (access-condition condition 'OPERAND)))
+ (let ((operator (access-condition condition 'operator))
+ (operand (access-condition condition 'operand)))
(if (or (symbol? operator)
(procedure? operator))
(begin
(write-operator operator port)
(write-string "," port)))))))
(set! condition-type:wrong-type-datum
- (make-condition-type 'WRONG-TYPE-DATUM condition-type:illegal-datum
- '(TYPE)
+ (make-condition-type 'wrong-type-datum condition-type:illegal-datum
+ '(type)
(lambda (condition port)
(write-string "The object " port)
- (write (access-condition condition 'DATUM) port)
+ (write (access-condition condition 'datum) port)
(write-string " is not " port)
(write-type-description condition port)
(write-string "." port))))
(set! condition-type:wrong-type-argument
- (make-condition-type 'WRONG-TYPE-ARGUMENT
+ (make-condition-type 'wrong-type-argument
condition-type:wrong-type-datum
- '(OPERATOR OPERAND)
+ '(operator operand)
(lambda (condition port)
(write-string "The object " port)
- (write (access-condition condition 'DATUM) port)
+ (write (access-condition condition 'datum) port)
(write-operand-description condition port)
(write-string " is not " port)
(write-type-description condition port)
(write-string "." port))))
(set! condition-type:bad-range-argument
- (make-condition-type 'BAD-RANGE-ARGUMENT
+ (make-condition-type 'bad-range-argument
condition-type:datum-out-of-range
- '(OPERATOR OPERAND)
+ '(operator operand)
(lambda (condition port)
(write-string "The object " port)
- (write (access-condition condition 'DATUM) port)
+ (write (access-condition condition 'datum) port)
(write-operand-description condition port)
(write-string " is not in the correct range." port)))))
\f
(set! condition-type:wrong-number-of-arguments
- (make-condition-type 'WRONG-NUMBER-OF-ARGUMENTS
+ (make-condition-type 'wrong-number-of-arguments
condition-type:wrong-type-datum
- '(OPERANDS)
+ '(operands)
(lambda (condition port)
(let ((pluralize-argument
(lambda (number)
(if (= number 1) " argument" " arguments")
port))))
(write-string "The procedure " port)
- (write-operator (access-condition condition 'DATUM) port)
+ (write-operator (access-condition condition 'datum) port)
(write-string " has been called with " port)
- (let ((count (length (access-condition condition 'OPERANDS))))
+ (let ((count (length (access-condition condition 'operands))))
(write count port)
(pluralize-argument count))
(write-string "; it requires " port)
- (let ((arity (access-condition condition 'TYPE)))
+ (let ((arity (access-condition condition 'type)))
(let ((arity-min (procedure-arity-min arity))
(arity-max (procedure-arity-max arity)))
(cond ((eqv? arity-min arity-max)
(write-char #\. port)))))
(set! condition-type:illegal-pathname-component
- (make-condition-type 'ILLEGAL-PATHNAME-COMPONENT
+ (make-condition-type 'illegal-pathname-component
condition-type:wrong-type-datum '()
(lambda (condition port)
(write-string "The object " port)
- (write (access-condition condition 'DATUM) port)
+ (write (access-condition condition 'datum) port)
(write-string " is not a valid pathname " port)
- (write-string (access-condition condition 'TYPE) port)
+ (write-string (access-condition condition 'type) port)
(write-string "." port))))
(set! condition-type:control-error
- (make-condition-type 'CONTROL-ERROR condition-type:error '()
+ (make-condition-type 'control-error condition-type:error '()
"Control error."))
(set! condition-type:no-such-restart
- (make-condition-type 'NO-SUCH-RESTART condition-type:control-error
- '(NAME)
+ (make-condition-type 'no-such-restart condition-type:control-error
+ '(name)
(lambda (condition port)
(write-string "The restart named " port)
- (write (access-condition condition 'NAME) port)
+ (write (access-condition condition 'name) port)
(write-string " is not bound." port))))
(let ((anonymous-error
(write-string "Anonymous error associated with " port)
(write (access-condition condition field-name) port)
(write-string "." port))))))
- (set! condition-type:port-error (anonymous-error 'PORT-ERROR 'PORT))
- (set! condition-type:file-error (anonymous-error 'FILE-ERROR 'FILENAME))
- (set! condition-type:cell-error (anonymous-error 'CELL-ERROR 'LOCATION))
- (set! condition-type:thread-error (anonymous-error 'THREAD-ERROR 'THREAD)))
+ (set! condition-type:port-error (anonymous-error 'port-error 'port))
+ (set! condition-type:file-error (anonymous-error 'file-error 'filename))
+ (set! condition-type:cell-error (anonymous-error 'cell-error 'location))
+ (set! condition-type:thread-error (anonymous-error 'thread-error 'thread)))
\f
(set! condition-type:derived-port-error
- (make-condition-type 'DERIVED-PORT-ERROR condition-type:port-error
- '(CONDITION)
+ (make-condition-type 'derived-port-error condition-type:port-error
+ '(condition)
(lambda (condition port)
(write-string "The port " port)
- (write (access-condition condition 'PORT) port)
+ (write (access-condition condition 'port) port)
(write-string " signalled an error " port)
- (write (access-condition condition 'CONDITION) port)
+ (write (access-condition condition 'condition) port)
(write-string ":" port)
(newline port)
- (write-condition-report (access-condition condition 'CONDITION)
+ (write-condition-report (access-condition condition 'condition)
port))))
(set! error:derived-port
(let ((make-condition
(condition-constructor condition-type:derived-port-error
- '(PORT CONDITION))))
+ '(port condition))))
(lambda (port condition)
- (guarantee-condition condition 'ERROR:DERIVED-PORT)
+ (guarantee-condition condition 'error:derived-port)
(error (make-condition (%condition/continuation condition)
(%condition/restarts condition)
port
condition)))))
(set! condition-type:derived-file-error
- (make-condition-type 'DERIVED-FILE-ERROR condition-type:file-error
- '(CONDITION)
+ (make-condition-type 'derived-file-error condition-type:file-error
+ '(condition)
(lambda (condition port)
(write-string "The file " port)
- (write (access-condition condition 'FILENAME) port)
+ (write (access-condition condition 'filename) port)
(write-string " signalled an error " port)
- (write (access-condition condition 'CONDITION) port)
+ (write (access-condition condition 'condition) port)
(write-string ":" port)
(newline port)
- (write-condition-report (access-condition condition 'CONDITION)
+ (write-condition-report (access-condition condition 'condition)
port))))
(set! error:derived-file
(let ((make-condition
(condition-constructor condition-type:derived-file-error
- '(FILENAME CONDITION))))
+ '(filename condition))))
(lambda (filename condition)
- (guarantee-condition condition 'ERROR:DERIVED-FILE)
+ (guarantee-condition condition 'error:derived-file)
(error (make-condition (%condition/continuation condition)
(%condition/restarts condition)
filename
condition)))))
(set! condition-type:derived-thread-error
- (make-condition-type 'DERIVED-THREAD-ERROR condition-type:thread-error
- '(CONDITION)
+ (make-condition-type 'derived-thread-error condition-type:thread-error
+ '(condition)
(lambda (condition port)
(write-string "The thread " port)
- (write (access-condition condition 'THREAD) port)
+ (write (access-condition condition 'thread) port)
(write-string " signalled " port)
- (let ((condition (access-condition condition 'CONDITION)))
+ (let ((condition (access-condition condition 'condition)))
(write-string (if (condition/error? condition)
"an error "
"a condition ")
(set! error:derived-thread
(let ((make-condition
(condition-constructor condition-type:derived-thread-error
- '(THREAD CONDITION))))
+ '(thread condition))))
(lambda (thread condition)
- (guarantee-condition condition 'ERROR:DERIVED-THREAD)
+ (guarantee-condition condition 'error:derived-thread)
(let ((condition
(make-condition (%condition/continuation condition)
(%condition/restarts condition)
thread
condition)))
- (with-simple-restart 'CONTINUE "Continue from error."
+ (with-simple-restart 'continue "Continue from error."
(lambda ()
(restart/put! (first-bound-restart)
- 'ASSOCIATED-CONDITION
+ 'associated-condition
condition)
(error condition)))))))
(set! condition/derived-thread?
(condition-predicate condition-type:derived-thread-error))
\f
(set! condition-type:file-operation-error
- (make-condition-type 'FILE-OPERATION-ERROR condition-type:file-error
- '(VERB NOUN REASON OPERATOR OPERANDS)
+ (make-condition-type 'file-operation-error condition-type:file-error
+ '(verb noun reason operator operands)
(lambda (condition port)
- (let ((noun (access-condition condition 'NOUN)))
+ (let ((noun (access-condition condition 'noun)))
(write-string "Unable to " port)
- (write-string (access-condition condition 'VERB) port)
+ (write-string (access-condition condition 'verb) port)
(write-string " " port)
(write-string noun port)
(write-string " " port)
- (write (->namestring (access-condition condition 'FILENAME))
+ (write (->namestring (access-condition condition 'filename))
port)
(write-string " because: " port)
- (let ((reason (access-condition condition 'REASON)))
+ (let ((reason (access-condition condition 'reason)))
(if reason
(write-string (string-titlecase reason) port)
(begin
(write-string "." port)))))
(set! error:file-operation
(let ((get-verb
- (condition-accessor condition-type:file-operation-error 'VERB))
+ (condition-accessor condition-type:file-operation-error 'verb))
(get-noun
- (condition-accessor condition-type:file-operation-error 'NOUN)))
+ (condition-accessor condition-type:file-operation-error 'noun)))
(substitutable-value-condition-signaller
condition-type:file-operation-error
- '(FILENAME VERB NOUN REASON OPERATOR OPERANDS)
+ '(filename verb noun reason operator operands)
standard-error-handler
0
(lambda (condition)
" again.")))))
(set! condition-type:variable-error
- (make-condition-type 'VARIABLE-ERROR condition-type:cell-error
- '(ENVIRONMENT)
+ (make-condition-type 'variable-error condition-type:cell-error
+ '(environment)
(lambda (condition port)
(write-string "Anonymous error associated with variable " port)
- (write (access-condition condition 'LOCATION) port)
+ (write (access-condition condition 'location) port)
(write-string "." port))))
(set! condition-type:unbound-variable
- (make-condition-type 'UNBOUND-VARIABLE condition-type:variable-error
+ (make-condition-type 'unbound-variable condition-type:variable-error
'()
(lambda (condition port)
(write-string "Unbound variable: " port)
- (write (access-condition condition 'LOCATION) port))))
+ (write (access-condition condition 'location) port))))
(set! condition-type:unassigned-variable
- (make-condition-type 'UNASSIGNED-VARIABLE condition-type:variable-error
+ (make-condition-type 'unassigned-variable condition-type:variable-error
'()
(lambda (condition port)
(write-string "Unassigned variable: " port)
- (write (access-condition condition 'LOCATION) port))))
+ (write (access-condition condition 'location) port))))
(set! condition-type:macro-binding
- (make-condition-type 'MACRO-BINDING condition-type:variable-error '()
+ (make-condition-type 'macro-binding condition-type:variable-error '()
(lambda (condition port)
(write-string "Variable reference to a syntactic keyword: " port)
- (write (access-condition condition 'LOCATION) port))))
+ (write (access-condition condition 'location) port))))
\f
(let ((arithmetic-error-report
(lambda (description)
(lambda (condition port)
(write-string description port)
- (let ((operator (access-condition condition 'OPERATOR)))
+ (let ((operator (access-condition condition 'operator)))
(if operator
(begin
(write-string " signalled by " port)
(write-operator operator port)
(write-string "." port))))))))
(set! condition-type:arithmetic-error
- (make-condition-type 'ARITHMETIC-ERROR condition-type:error
- '(OPERATOR OPERANDS)
+ (make-condition-type 'arithmetic-error condition-type:error
+ '(operator operands)
(arithmetic-error-report "Anonymous arithmetic error")))
(set! condition-type:divide-by-zero
- (make-condition-type 'DIVIDE-BY-ZERO condition-type:arithmetic-error
+ (make-condition-type 'divide-by-zero condition-type:arithmetic-error
'()
(arithmetic-error-report "Division by zero")))
(set! condition-type:integer-divide-by-zero
- (make-condition-type 'INTEGER-DIVIDE-BY-ZERO
+ (make-condition-type 'integer-divide-by-zero
condition-type:divide-by-zero
'()
(arithmetic-error-report "Integer division by zero")))
(set! condition-type:floating-point-divide-by-zero
- (make-condition-type 'FLOATING-POINT-DIVIDE-BY-ZERO
+ (make-condition-type 'floating-point-divide-by-zero
condition-type:divide-by-zero
'()
(arithmetic-error-report "Floating-point division by zero")))
(set! condition-type:inexact-floating-point-result
- (make-condition-type 'INEXACT-FLOATING-POINT-RESULT
+ (make-condition-type 'inexact-floating-point-result
condition-type:arithmetic-error
'()
(arithmetic-error-report "Inexact floating-point result")))
(set! condition-type:invalid-floating-point-operation
- (make-condition-type 'INVALID-FLOATING-POINT-OPERATION
+ (make-condition-type 'invalid-floating-point-operation
condition-type:arithmetic-error
'()
(arithmetic-error-report "Invalid floating-point operation")))
(set! condition-type:floating-point-overflow
- (make-condition-type 'FLOATING-POINT-OVERFLOW
+ (make-condition-type 'floating-point-overflow
condition-type:arithmetic-error
'()
(arithmetic-error-report "Floating-point overflow")))
(set! condition-type:floating-point-underflow
- (make-condition-type 'FLOATING-POINT-UNDERFLOW
+ (make-condition-type 'floating-point-underflow
condition-type:arithmetic-error
'()
(arithmetic-error-report "Floating-point underflow"))))
\f
(set! make-simple-error
(condition-constructor condition-type:simple-error
- '(MESSAGE IRRITANTS)))
+ '(message irritants)))
(set! make-simple-warning
(condition-constructor condition-type:simple-warning
- '(MESSAGE IRRITANTS)))
+ '(message irritants)))
(set! error:wrong-type-datum
(condition-signaller condition-type:wrong-type-datum
- '(DATUM TYPE)
+ '(datum type)
standard-error-handler))
(set! error:datum-out-of-range
(condition-signaller condition-type:datum-out-of-range
- '(DATUM)
+ '(datum)
standard-error-handler))
(set! error:wrong-type-argument
(condition-signaller condition-type:wrong-type-argument
- '(DATUM TYPE OPERATOR)
+ '(datum type operator)
standard-error-handler))
(set! error:bad-range-argument
(condition-signaller condition-type:bad-range-argument
- '(DATUM OPERATOR)
+ '(datum operator)
standard-error-handler))
(set! error:wrong-number-of-arguments
(condition-signaller condition-type:wrong-number-of-arguments
- '(DATUM TYPE OPERANDS)
+ '(datum type operands)
standard-error-handler))
(set! error:illegal-pathname-component
(condition-signaller condition-type:illegal-pathname-component
- '(DATUM TYPE)
+ '(datum type)
standard-error-handler))
(set! error:divide-by-zero
(condition-signaller condition-type:divide-by-zero
- '(OPERATOR OPERANDS)
+ '(operator operands)
standard-error-handler))
(set! error:no-such-restart
(condition-signaller condition-type:no-such-restart
- '(NAME)
+ '(name)
standard-error-handler))
(set! error:unassigned-variable
(condition-signaller condition-type:unassigned-variable
- '(ENVIRONMENT LOCATION)
+ '(environment location)
standard-error-handler))
(set! error:unbound-variable
(condition-signaller condition-type:unbound-variable
- '(ENVIRONMENT LOCATION)
+ '(environment location)
standard-error-handler))
(set! error:macro-binding
(condition-signaller condition-type:macro-binding
- '(ENVIRONMENT LOCATION)
+ '(environment location)
standard-error-handler))
unspecific)
\f
(else
(error:wrong-type-argument map-error
"map-error procedure"
- 'IGNORE-ERRORS)))
+ 'ignore-errors)))
thunk))))
(define warn-errors?
(define (ordinal-number-string n)
(if (not (and (exact-nonnegative-integer? n) (< n 100)))
(error:wrong-type-argument n "exact integer between 0 and 99"
- 'ORDINAL-NUMBER-STRING))
+ 'ordinal-number-string))
(let ((ones-names
#("zeroth" "first" "second" "third" "fourth" "fifth" "sixth"
"seventh" "eighth" "ninth"))
(declare (usual-integrations))
\f
(define (initialize-package!)
- (set! add-event-receiver! (make-receiver-modifier 'ADD-RECEIVER))
- (set! remove-event-receiver! (make-receiver-modifier 'REMOVE-RECEIVER))
+ (set! add-event-receiver! (make-receiver-modifier 'add-receiver))
+ (set! remove-event-receiver! (make-receiver-modifier 'remove-receiver))
unspecific)
(define-structure (event-distributor
(define (event-distributor/invoke! event-distributor . arguments)
(enqueue! (event-distributor/events event-distributor)
- (cons 'INVOKE-RECEIVERS arguments))
+ (cons 'invoke-receivers arguments))
(process-events! event-distributor))
(define (make-receiver-modifier keyword)
(queue-map! (event-distributor/events event-distributor)
(lambda (event)
(case (car event)
- ((INVOKE-RECEIVERS)
+ ((invoke-receivers)
(do ((receivers
(event-distributor/receivers event-distributor)
(cdr receivers)))
((null? receivers))
(apply (car receivers) (cdr event))))
- ((ADD-RECEIVER)
+ ((add-receiver)
(let ((receiver (cdr event))
(receivers
(event-distributor/receivers event-distributor)))
(set-event-distributor/receivers!
event-distributor
(append! receivers (list receiver))))))
- ((REMOVE-RECEIVER)
+ ((remove-receiver)
(set-event-distributor/receivers!
event-distributor
(delv! (cdr event)
#;(define-syntax %assert
(syntax-rules ()
- ((_ TEST . MSG)
+ ((_ test . msg)
#f)))
(define-syntax %assert
(syntax-rules ()
- ((_ TEST . MSG)
- (if (not TEST)
- (error . MSG)))))
+ ((_ test . msg)
+ (if (not test)
+ (error . msg)))))
;; Use this definition to avoid frequently checking %trace?.
#;(define-syntax %trace
(syntax-rules ()
- ((_ . MSG)
+ ((_ . msg)
#f)))
(define %trace? #f)
(define-syntax %trace
(syntax-rules ()
- ((_ . MSG)
- (if %trace? (%outf-error . MSG)))))
+ ((_ . msg)
+ (if %trace? (%outf-error . msg)))))
(define (tindent)
(make-string (* 2 (length calloutback-stack)) #\space))
(define i/o-file-type)
(define (initialize-package!)
(let ((other-operations
- `((LENGTH ,operation/length)
- (PATHNAME ,operation/pathname)
- (POSITION ,operation/position)
- (SET-POSITION! ,operation/set-position!)
- (TRUENAME ,operation/pathname)
- (WRITE-SELF ,operation/write-self))))
+ `((length ,operation/length)
+ (pathname ,operation/pathname)
+ (position ,operation/position)
+ (set-position! ,operation/set-position!)
+ (truename ,operation/pathname)
+ (write-self ,operation/write-self))))
(let ((make-type
(lambda (source sink)
(make-textual-port-type other-operations
(generic-i/o-port-type source sink)))))
- (set! input-file-type (make-type 'CHANNEL #f))
- (set! output-file-type (make-type #f 'CHANNEL))
- (set! i/o-file-type (make-type 'CHANNEL 'CHANNEL))))
+ (set! input-file-type (make-type 'channel #f))
+ (set! output-file-type (make-type #f 'channel))
+ (set! i/o-file-type (make-type 'channel 'channel))))
unspecific)
(define (operation/pathname port)
(let ((port
(%make-textual-file-port input-channel output-channel pathname
caller)))
- (port/set-coding port 'BINARY)
- (port/set-line-ending port 'BINARY)
+ (port/set-coding port 'binary)
+ (port/set-line-ending port 'binary)
port))
(define (%make-textual-file-port input-channel output-channel pathname caller)
(if interrupted-thread
(let ((fp-env (thread-float-environment interrupted-thread)))
(if (eqv? fp-env #t)
- (let ((fp-env ((ucode-primitive FLOAT-ENVIRONMENT 0))))
+ (let ((fp-env ((ucode-primitive float-environment 0))))
(set-thread-float-environment! interrupted-thread fp-env)
fp-env)
fp-env))
;; No idea what environment we're in. Assume the worst.
- ((ucode-primitive FLOAT-ENVIRONMENT 0)))))
+ ((ucode-primitive float-environment 0)))))
(if fp-env
- ((ucode-primitive SET-FLOAT-ENVIRONMENT 1) default-environment))
+ ((ucode-primitive set-float-environment 1) default-environment))
fp-env))
;;; Restore the environment saved by ENTER-DEFAULT-FLOAT-ENVIRONMENT
(define (restore-float-environment-from-default fp-env)
(if fp-env
- ((ucode-primitive SET-FLOAT-ENVIRONMENT 1) fp-env)))
+ ((ucode-primitive set-float-environment 1) fp-env)))
;;; Enter a floating-point environment for switching to a thread.
(define (enter-float-environment fp-env)
- ((ucode-primitive SET-FLOAT-ENVIRONMENT 1) (or fp-env default-environment)))
+ ((ucode-primitive set-float-environment 1) (or fp-env default-environment)))
;;; Save a floating-point environment when a thread yields or is
;;; preempted and must let another thread run. FP-ENV is absent when
thread
(if (or (default-object? fp-env)
(eqv? #t fp-env))
- ((ucode-primitive FLOAT-ENVIRONMENT 0))
+ ((ucode-primitive float-environment 0))
fp-env))))
\f
(define (use-floating-point-environment!)
(define (flo:environment)
(let ((fp-env (thread-float-environment (current-thread))))
(if (eqv? fp-env #t)
- (let ((fp-env ((ucode-primitive FLOAT-ENVIRONMENT 0))))
+ (let ((fp-env ((ucode-primitive float-environment 0))))
;; Cache it now so we don't need to ask the machine again
;; when we next switch threads. There is a harmless race
;; here if we are preempted.
;; updating the thread cache, and the thread starts running
;; again, there would be nothing to set the machine straight.
(set-thread-float-environment! (current-thread) fp-env)
- ((ucode-primitive SET-FLOAT-ENVIRONMENT 1)
+ ((ucode-primitive set-float-environment 1)
(or fp-env default-environment))))))
(define (flo:update-environment! fp-env)
(without-interrupts
(lambda ()
(set-thread-float-environment! (current-thread) fp-env)
- ((ucode-primitive UPDATE-FLOAT-ENVIRONMENT 1)
+ ((ucode-primitive update-float-environment 1)
(or fp-env default-environment)))))))
(define default-environment)
(set! default-environment
(without-interrupts
(lambda ()
- (let ((fp-env ((ucode-primitive FLOAT-ENVIRONMENT 0))))
- ((ucode-primitive SET-FLOAT-ROUNDING-MODE 1)
+ (let ((fp-env ((ucode-primitive float-environment 0))))
+ ((ucode-primitive set-float-rounding-mode 1)
(%mode-name->number
(flo:default-rounding-mode)
'|#[(runtime floating-point-environment)reset-package!]|))
- ((ucode-primitive CLEAR-FLOAT-EXCEPTIONS 1)
+ ((ucode-primitive clear-float-exceptions 1)
(flo:supported-exceptions))
- ((ucode-primitive SET-TRAPPED-FLOAT-EXCEPTIONS 1)
+ ((ucode-primitive set-trapped-float-exceptions 1)
(flo:default-trapped-exceptions))
- (let ((fp-env* ((ucode-primitive FLOAT-ENVIRONMENT 0))))
- ((ucode-primitive SET-FLOAT-ENVIRONMENT 1) fp-env)
+ (let ((fp-env* ((ucode-primitive float-environment 0))))
+ ((ucode-primitive set-float-environment 1) fp-env)
fp-env*)))))
unspecific)
(set-float-rounding-mode 1))
(define float-rounding-mode-names
- '#(TO-NEAREST TOWARD-ZERO DOWNWARD UPWARD))
+ '#(to-nearest toward-zero downward upward))
(define (flo:rounding-modes)
(let ((n (vector-length float-rounding-mode-names))
names))))
(define (flo:default-rounding-mode)
- 'TO-NEAREST)
+ 'to-nearest)
(define (flo:rounding-mode)
(let ((m (get-float-rounding-mode)))
(define (flo:set-rounding-mode! mode)
(use-floating-point-environment!)
- (set-float-rounding-mode (%mode-name->number mode 'FLO:SET-ROUNDING-MODE!)))
+ (set-float-rounding-mode (%mode-name->number mode 'flo:set-rounding-mode!)))
(define (flo:with-rounding-mode mode thunk)
- (let ((mode (%mode-name->number mode 'FLO:WITH-ROUNDING-MODE)))
+ (let ((mode (%mode-name->number mode 'flo:with-rounding-mode)))
(flo:preserving-environment
(lambda ()
(use-floating-point-environment!)
(define (flo:clear-exceptions! exceptions)
(use-floating-point-environment!)
- ((ucode-primitive CLEAR-FLOAT-EXCEPTIONS 1) exceptions))
+ ((ucode-primitive clear-float-exceptions 1) exceptions))
(define (flo:raise-exceptions! exceptions)
(use-floating-point-environment!)
- ((ucode-primitive RAISE-FLOAT-EXCEPTIONS 1) exceptions))
+ ((ucode-primitive raise-float-exceptions 1) exceptions))
(define (flo:restore-exception-flags! fexcept exceptions)
(use-floating-point-environment!)
- ((ucode-primitive RESTORE-FLOAT-EXCEPTION-FLAGS 2) fexcept exceptions))
+ ((ucode-primitive restore-float-exception-flags 2) fexcept exceptions))
(define (flo:set-trapped-exceptions! exceptions)
(use-floating-point-environment!)
- ((ucode-primitive SET-TRAPPED-FLOAT-EXCEPTIONS 1) exceptions))
+ ((ucode-primitive set-trapped-float-exceptions 1) exceptions))
(define (flo:trap-exceptions! exceptions)
(use-floating-point-environment!)
- ((ucode-primitive TRAP-FLOAT-EXCEPTIONS 1) exceptions))
+ ((ucode-primitive trap-float-exceptions 1) exceptions))
(define (flo:untrap-exceptions! exceptions)
(use-floating-point-environment!)
- ((ucode-primitive UNTRAP-FLOAT-EXCEPTIONS 1) exceptions))
+ ((ucode-primitive untrap-float-exceptions 1) exceptions))
(define (flo:defer-exception-traps!)
(use-floating-point-environment!)
- ((ucode-primitive DEFER-FLOAT-EXCEPTION-TRAPS 0)))
+ ((ucode-primitive defer-float-exception-traps 0)))
\f
(define (flo:default-trapped-exceptions)
;; By default, we trap the standard IEEE 754 exceptions that Scheme
(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)
- (n 'INEXACT-RESULT (flo:exception:inexact-result)
- (n 'INVALID-OPERATION (flo:exception:invalid-operation)
- (n 'OVERFLOW (flo:exception:overflow)
- (n 'UNDERFLOW (flo:exception:underflow)
+ (error:bad-range-argument exceptions 'flo:exceptions->names))
+ (n 'divide-by-zero (flo:exception:divide-by-zero)
+ (n 'inexact-result (flo:exception:inexact-result)
+ (n 'invalid-operation (flo:exception:invalid-operation)
+ (n 'overflow (flo:exception:overflow)
+ (n 'underflow (flo:exception:underflow)
'()))))))
(define (flo:names->exceptions names)
(define (name->exceptions name)
(case name
- ((DIVIDE-BY-ZERO) (flo:exception:divide-by-zero))
- ((INEXACT-RESULT) (flo:exception:inexact-result))
- ((INVALID-OPERATION) (flo:exception:invalid-operation))
- ((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)
+ ((divide-by-zero) (flo:exception:divide-by-zero))
+ ((inexact-result) (flo:exception:inexact-result))
+ ((invalid-operation) (flo:exception:invalid-operation))
+ ((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)
(reduce fix:or 0 (map name->exceptions names)))
\f
;;;; Floating-point environment utilities
frame
(select-subexp expression))))))
(case (vector-ref source-code 0)
- ((SEQUENCE-CONTINUE)
+ ((sequence-continue)
(win &pair-car))
- ((ASSIGNMENT-CONTINUE
- DEFINITION-CONTINUE)
+ ((assignment-continue
+ definition-continue)
(win &pair-cdr))
- ((CONDITIONAL-DECIDE)
+ ((conditional-decide)
(win &triple-first))
- ((COMBINATION-OPERAND)
+ ((combination-operand)
(values
expression
(get-environment)
(scode-combination-operator expression)
(list-ref (scode-combination-operands expression)
(-1+ (vector-ref source-code 2)))))))
- ((COMBINATION-ELEMENT)
+ ((combination-element)
(win2 undefined-environment
(vector-ref source-code 2)))
- ((SEQUENCE-ELEMENT)
+ ((sequence-element)
(win2 undefined-environment
(vector-ref source-code 2)))
- ((CONDITIONAL-PREDICATE)
+ ((conditional-predicate)
(win2 undefined-environment
(vector-ref source-code 2)))
(else
\f
(define (initialize-package!)
(set! stack-frame-type/pop-return-error
- (microcode-return/name->type 'POP-RETURN-ERROR))
- (record-method 'COMBINATION-APPLY method/null)
- (record-method 'REENTER-COMPILED-CODE method/null)
+ (microcode-return/name->type 'pop-return-error))
+ (record-method 'combination-apply method/null)
+ (record-method 'reenter-compiled-code method/null)
(let ((method (method/standard &pair-car)))
- (record-method 'DISJUNCTION-DECIDE method)
- (record-method 'SEQUENCE-CONTINUE method))
+ (record-method 'disjunction-decide method)
+ (record-method 'sequence-continue method))
(let ((method (method/standard &pair-cdr)))
- (record-method 'ASSIGNMENT-CONTINUE method)
- (record-method 'DEFINITION-CONTINUE method))
+ (record-method 'assignment-continue method)
+ (record-method 'definition-continue method))
(let ((method (method/standard &triple-first)))
- (record-method 'CONDITIONAL-DECIDE method))
+ (record-method 'conditional-decide method))
(let ((method (method/expression-only &pair-car)))
- (record-method 'ACCESS-CONTINUE method))
- (record-method 'COMBINATION-SAVE-VALUE method/combination-save-value)
- (record-method 'EVAL-ERROR method/eval-error)
- (record-method 'FORCE-SNAP-THUNK method/force-snap-thunk)
+ (record-method 'access-continue method))
+ (record-method 'combination-save-value method/combination-save-value)
+ (record-method 'eval-error method/eval-error)
+ (record-method 'force-snap-thunk method/force-snap-thunk)
(let ((method (method/application-frame 3)))
- (record-method 'INTERNAL-APPLY method)
- (record-method 'INTERNAL-APPLY-VAL method))
+ (record-method 'internal-apply method)
+ (record-method 'internal-apply-val method))
(let ((method (method/compiler-reference-trap make-scode-variable)))
- (record-method 'COMPILER-REFERENCE-TRAP-RESTART method)
- (record-method 'COMPILER-SAFE-REFERENCE-TRAP-RESTART method))
- (record-method 'COMPILER-UNASSIGNED?-TRAP-RESTART
+ (record-method 'compiler-reference-trap-restart method)
+ (record-method 'compiler-safe-reference-trap-restart method))
+ (record-method 'compiler-unassigned?-trap-restart
(method/compiler-reference-trap make-scode-unassigned?))
- (record-method 'COMPILER-ASSIGNMENT-TRAP-RESTART
+ (record-method 'compiler-assignment-trap-restart
(method/compiler-assignment-trap make-scode-assignment))
- (record-method 'COMPILER-LOOKUP-APPLY-TRAP-RESTART
+ (record-method 'compiler-lookup-apply-trap-restart
method/compiler-lookup-apply-trap-restart)
- (record-method 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART
+ (record-method 'compiler-operator-lookup-trap-restart
method/compiler-lookup-apply-trap-restart)
- (record-method 'COMPILER-ERROR-RESTART
+ (record-method 'compiler-error-restart
method/compiler-error-restart)
- (record-method 'HARDWARE-TRAP method/hardware-trap)
+ (record-method 'hardware-trap method/hardware-trap)
(set-stack-frame-type/debugging-info-method!
stack-frame-type/compiled-return-address
method/compiled-code)
(define (default/purify item pure-space? queue?)
pure-space?
- (if (and (not (eq? 'NON-POINTER (object-gc-type item)))
+ (if (and (not (eq? 'non-pointer (object-gc-type item)))
(not (object-constant? item)))
(if queue?
(with-thread-mutex-lock constant-space-queue-mutex
object-context
set-object-context!)
(if (not (procedure? procedure))
- (error:wrong-type-argument procedure "procedure" 'MAKE-GC-FINALIZER))
+ (error:wrong-type-argument procedure "procedure" 'make-gc-finalizer))
(if (not (procedure-arity-valid? procedure 1))
- (error:bad-range-argument procedure 'MAKE-GC-FINALIZER))
+ (error:bad-range-argument procedure 'make-gc-finalizer))
(let ((finalizer
(%make-gc-finalizer procedure
object?
finalizer))
(define (add-to-gc-finalizer! finalizer object)
- (guarantee-gc-finalizer finalizer 'ADD-TO-GC-FINALIZER!)
+ (guarantee-gc-finalizer finalizer 'add-to-gc-finalizer!)
(if (not ((gc-finalizer-object? finalizer) object))
(error:wrong-type-argument object
"finalized object"
- 'ADD-TO-GC-FINALIZER!))
+ 'add-to-gc-finalizer!))
(with-finalizer-lock finalizer
(lambda ()
(let ((context ((gc-finalizer-object-context finalizer) object)))
(if (not context)
- (error:bad-range-argument object 'ADD-TO-GC-FINALIZER!))
+ (error:bad-range-argument object 'add-to-gc-finalizer!))
(set-gc-finalizer-items! finalizer
(cons (weak-cons object context)
(gc-finalizer-items finalizer))))))
object)
(define (remove-from-gc-finalizer! finalizer object)
- (guarantee-gc-finalizer finalizer 'REMOVE-FROM-GC-FINALIZER!)
+ (guarantee-gc-finalizer finalizer 'remove-from-gc-finalizer!)
(let ((object? (gc-finalizer-object? finalizer)))
(if (not (object? object))
(error:wrong-type-argument object
"finalized object"
- 'REMOVE-FROM-GC-FINALIZER!)))
+ 'remove-from-gc-finalizer!)))
(with-finalizer-lock finalizer
(lambda ()
(remove-from-locked-gc-finalizer! finalizer object))))
(set-object-context! (gc-finalizer-set-object-context! finalizer)))
(let ((context (object-context object)))
(if (not context)
- (error:bad-range-argument object 'REMOVE-FROM-GC-FINALIZER!))
+ (error:bad-range-argument object 'remove-from-gc-finalizer!))
(let loop ((items (gc-finalizer-items finalizer)) (prev #f))
(if (not (pair? items))
- (error:bad-range-argument object 'REMOVE-FROM-GC-FINALIZER!))
+ (error:bad-range-argument object 'remove-from-gc-finalizer!))
(if (eq? object (weak-car (car items)))
(let ((next (cdr items)))
(if prev
(without-interruption thunk))))
(define (with-gc-finalizer-lock finalizer thunk)
- (guarantee-gc-finalizer finalizer 'WITH-GC-FINALIZER-LOCK)
+ (guarantee-gc-finalizer finalizer 'with-gc-finalizer-lock)
(with-finalizer-lock finalizer thunk))
\f
(define (remove-all-from-gc-finalizer! finalizer)
- (guarantee-gc-finalizer finalizer 'REMOVE-ALL-FROM-GC-FINALIZER!)
+ (guarantee-gc-finalizer finalizer 'remove-all-from-gc-finalizer!)
(let ((procedure (gc-finalizer-procedure finalizer))
(object-context (gc-finalizer-object-context finalizer))
(set-object-context! (gc-finalizer-set-object-context! finalizer)))
(loop)))))))))
(define (search-gc-finalizer finalizer predicate)
- (guarantee-gc-finalizer finalizer 'SEARCH-GC-FINALIZER)
+ (guarantee-gc-finalizer finalizer 'search-gc-finalizer)
(with-thread-mutex-lock (gc-finalizer-mutex finalizer)
(lambda ()
(let loop ((items (gc-finalizer-items finalizer)))
(loop (cdr items)))))))))
(define (gc-finalizer-elements finalizer)
- (guarantee-gc-finalizer finalizer 'GC-FINALIZER-ELEMENTS)
+ (guarantee-gc-finalizer finalizer 'gc-finalizer-elements)
(with-thread-mutex-lock (gc-finalizer-mutex finalizer)
(lambda ()
(let loop ((items (gc-finalizer-items finalizer)) (objects '()))
;; interrupts turned on, yet not leave a dangling descriptor around
;; if the open is interrupted before the runtime system's data
;; structures are updated.
- (guarantee-gc-finalizer finalizer 'MAKE-GC-FINALIZED-OBJECT)
+ (guarantee-gc-finalizer finalizer 'make-gc-finalized-object)
(let ((p (weak-cons #f #f)))
(dynamic-wind
(lambda () unspecific)
(define (initialize-package!)
(set! history-modes
- `((NONE . ,none:install-history!)
- (BOUNDED . ,bounded:install-history!)
- (UNBOUNDED . ,unbounded:install-history!)))
- (set-history-mode! 'BOUNDED)
+ `((none . ,none:install-history!)
+ (bounded . ,bounded:install-history!)
+ (unbounded . ,unbounded:install-history!)))
+ (set-history-mode! 'bounded)
(set! timestamp (cons 0 0))
(statistics-reset!)
(add-event-receiver! event:after-restore statistics-reset!)
(define (set-history-mode! mode)
(let ((entry (assq mode history-modes)))
(if (not entry)
- (error "Bad mode name" 'SET-HISTORY-MODE! mode))
+ (error "Bad mode name" 'set-history-mode! mode))
((cdr entry))
(set! history-mode (car entry))))
(define (none:record-in-history! item)
item
- 'DONE)
+ 'done)
(define (none:get-history)
'())
;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who can
;; create the database.
-(define GDBM_READER 0) ;A reader.
-(define GDBM_WRITER 1) ;A writer.
-(define GDBM_WRCREAT 2) ;A writer. Create the db if needed.
-(define GDBM_NEWDB 3) ;A writer. Always create a new db.
-(define GDBM_FAST 16) ;Write fast! => No fsyncs.
+(define gdbm_reader 0) ;A reader.
+(define gdbm_writer 1) ;A writer.
+(define gdbm_wrcreat 2) ;A writer. Create the db if needed.
+(define gdbm_newdb 3) ;A writer. Always create a new db.
+(define gdbm_fast 16) ;Write fast! => No fsyncs.
(define (gdbm-open filename block-size flags mode)
(if (not (gdbm-available?))
(define (gdbm-close gdbf)
(if (not (gdbf? gdbf))
- (error:wrong-type-argument gdbf "gdbm handle" 'GDBM-CLOSE))
+ (error:wrong-type-argument gdbf "gdbm handle" 'gdbm-close))
(remove-from-gc-finalizer! gdbf-finalizer gdbf))
;; Parameters to gdbm_store for simple insertion or replacement in the
;; case that the key is already in the database.
-(define GDBM_INSERT 0) ;Never replace old data with new.
-(define GDBM_REPLACE 1) ;Always replace old data with new.
+(define gdbm_insert 0) ;Never replace old data with new.
+(define gdbm_replace 1) ;Always replace old data with new.
(define (gdbm-store gdbf key datum flags)
(gdbm-error
- ((ucode-primitive gdbm-store 4) (guarantee-gdbf gdbf 'GDBM-STORE)
+ ((ucode-primitive gdbm-store 4) (guarantee-gdbf gdbf 'gdbm-store)
key datum flags)))
(define (gdbm-fetch gdbf key)
- ((ucode-primitive gdbm-fetch 2) (guarantee-gdbf gdbf 'GDBM-FETCH) key))
+ ((ucode-primitive gdbm-fetch 2) (guarantee-gdbf gdbf 'gdbm-fetch) key))
(define (gdbm-exists? gdbf key)
- ((ucode-primitive gdbm-exists 2) (guarantee-gdbf gdbf 'GDBM-EXISTS?) key))
+ ((ucode-primitive gdbm-exists 2) (guarantee-gdbf gdbf 'gdbm-exists?) key))
(define (gdbm-delete gdbf key)
(gdbm-error
- ((ucode-primitive gdbm-delete 2) (guarantee-gdbf gdbf 'GDBM-DELETE) key)))
+ ((ucode-primitive gdbm-delete 2) (guarantee-gdbf gdbf 'gdbm-delete) key)))
(define (gdbm-firstkey gdbf)
- ((ucode-primitive gdbm-firstkey 1) (guarantee-gdbf gdbf 'GDBM-FIRSTKEY)))
+ ((ucode-primitive gdbm-firstkey 1) (guarantee-gdbf gdbf 'gdbm-firstkey)))
(define (gdbm-nextkey gdbf key)
- ((ucode-primitive gdbm-nextkey 2) (guarantee-gdbf gdbf 'GDBM-NEXTKEY) key))
+ ((ucode-primitive gdbm-nextkey 2) (guarantee-gdbf gdbf 'gdbm-nextkey) key))
(define (gdbm-reorganize gdbf)
(gdbm-error
((ucode-primitive gdbm-reorganize 1)
- (guarantee-gdbf gdbf 'GDBM-REORGANIZE))))
+ (guarantee-gdbf gdbf 'gdbm-reorganize))))
(define (gdbm-sync gdbf)
- ((ucode-primitive gdbm-sync 1) (guarantee-gdbf gdbf 'GDBM-SYNC)))
+ ((ucode-primitive gdbm-sync 1) (guarantee-gdbf gdbf 'gdbm-sync)))
(define (gdbm-version)
((ucode-primitive gdbm-version 0)))
;; Parameters to gdbm_setopt, specifing the type of operation to perform.
-(define GDBM_CACHESIZE 1) ;Set the cache size.
-(define GDBM_FASTMODE 2) ;Toggle fast mode.
+(define gdbm_cachesize 1) ;Set the cache size.
+(define gdbm_fastmode 2) ;Toggle fast mode.
(define (gdbm-setopt gdbf opt val)
(gdbm-error
- ((ucode-primitive gdbm-setopt 3) (guarantee-gdbf gdbf 'GDBM-SETOPT)
+ ((ucode-primitive gdbm-setopt 3) (guarantee-gdbf gdbf 'gdbm-setopt)
opt val)))
(define-structure (gdbf
- (print-procedure (simple-unparser-method 'GDBF
+ (print-procedure (simple-unparser-method 'gdbf
(lambda (gdbf)
(list (gdbf-filename gdbf))))))
descriptor
(known-input-line-ending? name)
(not (known-output-line-ending? name)))
(if (and channel
- (eq? (channel-type channel) 'TCP-STREAM-SOCKET))
- 'CRLF
+ (eq? (channel-type channel) 'tcp-stream-socket))
+ 'crlf
(default-line-ending))
name))
\f
environment
(if (syntax-match? '(symbol) (cdr form))
(let ((root (cadr form)))
- (let ((aliases (symbol root '-ALIASES))
- (proc (symbol 'DEFINE- root '-ALIAS)))
- `(BEGIN
- (SET! ,aliases (CONVERT-FORWARD ,aliases))
- (SET! ,proc ,(symbol proc '/POST-BOOT)))))
+ (let ((aliases (symbol root '-aliases))
+ (proc (symbol 'define- root '-alias)))
+ `(begin
+ (set! ,aliases (convert-forward ,aliases))
+ (set! ,proc ,(symbol proc '/post-boot)))))
(ill-formed-syntax form))))))
(initialize-name-map coding)
(initialize-name-map line-ending)))
- (set! binary-decoder (name->decoder 'BINARY))
- (set! binary-encoder (name->encoder 'BINARY))
- (set! binary-normalizer (name->normalizer 'BINARY))
- (set! binary-denormalizer (name->denormalizer 'BINARY))
+ (set! binary-decoder (name->decoder 'binary))
+ (set! binary-encoder (name->encoder 'binary))
+ (set! binary-normalizer (name->normalizer 'binary))
+ (set! binary-denormalizer (name->denormalizer 'binary))
unspecific))
(define (define-coding-aliases name aliases)
aliases))
(define (primary-input-port-codings)
- (cons 'US-ASCII (hash-table-keys decoders)))
+ (cons 'us-ascii (hash-table-keys decoders)))
(define (primary-output-port-codings)
- (cons 'US-ASCII (hash-table-keys encoders)))
+ (cons 'us-ascii (hash-table-keys encoders)))
(define max-char-bytes 4)
\f
\f
;;;; 8-bit codecs
-(define-decoder 'ISO-8859-1
+(define-decoder 'iso-8859-1
(lambda (ib)
(let ((sv (read-byte ib)))
(if (fix:fixnum? sv)
(integer->char sv)
sv))))
-(define-encoder 'ISO-8859-1
+(define-encoder 'iso-8859-1
(lambda (ob char)
(let ((cp (char->integer char)))
(if (not (fix:< cp #x100))
(define-deferred char-set:iso-8859-1
(char-set* (iota #x100)))
-(define-coding-aliases 'ISO-8859-1
- '(ISO_8859-1:1987 ISO-IR-100 ISO_8859-1 LATIN1 L1 IBM819 CP819 CSISOLATIN1))
+(define-coding-aliases 'iso-8859-1
+ '(iso_8859-1:1987 iso-ir-100 iso_8859-1 latin1 l1 ibm819 cp819 csisolatin1))
-(define-coding-aliases 'ISO-8859-1
- '(BINARY TEXT))
+(define-coding-aliases 'iso-8859-1
+ '(binary text))
-(define-coding-aliases 'ISO-8859-1
+(define-coding-aliases 'iso-8859-1
;; Treat US-ASCII like ISO-8859-1.
- '(US-ASCII ANSI_X3.4-1968 ISO-IR-6 ANSI_X3.4-1986 ISO_646.IRV:1991 ASCII
- ISO646-US US IBM367 CP367 CSASCII))
+ '(us-ascii ansi_x3.4-1968 iso-ir-6 ansi_x3.4-1986 iso_646.irv:1991 ascii
+ iso646-us us ibm367 cp367 csascii))
\f
(define-syntax define-8-bit-codecs
(sc-macro-transformer
(fix:< (car a) (car b))))))
(let ((lhs (list->vector (map car alist)))
(rhs (map cdr alist)))
- `(BEGIN
- (DEFINE-DECODER ',name
- (LET ((TABLE
+ `(begin
+ (define-decoder ',name
+ (let ((table
#(,@(map (lambda (cp)
(and cp
(integer->char cp)))
(if (fix:< i start)
(cons i (loop (fix:+ i 1)))
code-points))))))
- (LAMBDA (IB)
- (DECODE-8-BIT IB TABLE))))
- (DEFINE-ENCODER ',name
- (LET ((LHS ',lhs)
- (RHS (APPLY BYTEVECTOR ',rhs)))
- (LAMBDA (OB CHAR)
- (ENCODE-8-BIT OB CHAR ,start LHS RHS))))
- (DEFINE-DEFERRED ,(symbol 'CHAR-SET: name)
- (CHAR-SET* ',(append (iota #x80)
+ (lambda (ib)
+ (decode-8-bit ib table))))
+ (define-encoder ',name
+ (let ((lhs ',lhs)
+ (rhs (apply bytevector ',rhs)))
+ (lambda (ob char)
+ (encode-8-bit ob char ,start lhs rhs))))
+ (define-deferred ,(symbol 'char-set: name)
+ (char-set* ',(append (iota #x80)
(filter (lambda (cp) cp)
code-points))))))))
(ill-formed-syntax form)))))
#x0144 #x0148 #x00F3 #x00F4 #x0151 #x00F6 #x00F7 #x0159
#x016F #x00FA #x0171 #x00FC #x00FD #x0163 #x02D9)
-(define-coding-aliases 'ISO-8859-2
- '(ISO_8859-2:1987 ISO-IR-101 ISO_8859-2 LATIN2 L2 CSISOLATIN2))
+(define-coding-aliases 'iso-8859-2
+ '(iso_8859-2:1987 iso-ir-101 iso_8859-2 latin2 l2 csisolatin2))
(define-8-bit-codecs iso-8859-3 #xA1
#x0126 #x02D8 #x00A3 #x00A4 #f #x0124 #x00A7 #x00A8
#x00F1 #x00F2 #x00F3 #x00F4 #x0121 #x00F6 #x00F7 #x011D
#x00F9 #x00FA #x00FB #x00FC #x016D #x015D #x02D9)
-(define-coding-aliases 'ISO-8859-3
- '(ISO_8859-3:1988 ISO-IR-109 ISO_8859-3 LATIN3 L3 CSISOLATIN3))
+(define-coding-aliases 'iso-8859-3
+ '(iso_8859-3:1988 iso-ir-109 iso_8859-3 latin3 l3 csisolatin3))
(define-8-bit-codecs iso-8859-4 #xA1
#x0104 #x0138 #x0156 #x00A4 #x0128 #x013B #x00A7 #x00A8
#x0146 #x014D #x0137 #x00F4 #x00F5 #x00F6 #x00F7 #x00F8
#x0173 #x00FA #x00FB #x00FC #x0169 #x016B #x02D9)
-(define-coding-aliases 'ISO-8859-4
- '(ISO_8859-4:1988 ISO-IR-110 ISO_8859-4 LATIN4 L4 CSISOLATIN4))
+(define-coding-aliases 'iso-8859-4
+ '(iso_8859-4:1988 iso-ir-110 iso_8859-4 latin4 l4 csisolatin4))
(define-8-bit-codecs iso-8859-5 #xA1
#x0401 #x0402 #x0403 #x0404 #x0405 #x0406 #x0407 #x0408
#x0451 #x0452 #x0453 #x0454 #x0455 #x0456 #x0457 #x0458
#x0459 #x045A #x045B #x045C #x00A7 #x045E #x045F)
-(define-coding-aliases 'ISO-8859-5
- '(ISO_8859-5:1988 ISO-IR-144 ISO_8859-5 CYRILLIC CSISOLATINCYRILLIC))
+(define-coding-aliases 'iso-8859-5
+ '(iso_8859-5:1988 iso-ir-144 iso_8859-5 cyrillic csisolatincyrillic))
\f
(define-8-bit-codecs iso-8859-6 #xA1
#f #f #f #x00A4 #f #f #f #f
#x0651 #x0652 #f #f #f #f #f #f
#f #f #f #f #f #f #f)
-(define-coding-aliases 'ISO-8859-6
- '(ISO_8859-6:1987 ISO-IR-127 ISO_8859-6 ECMA-114 ASMO-708 ARABIC
- CSISOLATINARABIC))
+(define-coding-aliases 'iso-8859-6
+ '(iso_8859-6:1987 iso-ir-127 iso_8859-6 ecma-114 asmo-708 arabic
+ csisolatinarabic))
(define-8-bit-codecs iso-8859-7 #xA1
#x2018 #x2019 #x00A3 #f #f #x00A6 #x00A7 #x00A8
#x03C1 #x03C2 #x03C3 #x03C4 #x03C5 #x03C6 #x03C7 #x03C8
#x03C9 #x03CA #x03CB #x03CC #x03CD #x03CE #f)
-(define-coding-aliases 'ISO-8859-7
- '(ISO_8859-7:1987 ISO-IR-126 ISO_8859-7 ELOT_928 ECMA-118 GREEK GREEK8
- CSISOLATINGREEK))
+(define-coding-aliases 'iso-8859-7
+ '(iso_8859-7:1987 iso-ir-126 iso_8859-7 elot_928 ecma-118 greek greek8
+ csisolatingreek))
(define-8-bit-codecs iso-8859-8 #xA1
#f #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7 #x00A8
#x05E1 #x05E2 #x05E3 #x05E4 #x05E5 #x05E6 #x05E7 #x05E8
#x05E9 #x05EA #f #f #x200E #x200F #f)
-(define-coding-aliases 'ISO-8859-8
- '(ISO_8859-8:1988 ISO-IR-138 ISO_8859-8 HEBREW CSISOLATINHEBREW))
+(define-coding-aliases 'iso-8859-8
+ '(iso_8859-8:1988 iso-ir-138 iso_8859-8 hebrew csisolatinhebrew))
\f
(define-8-bit-codecs iso-8859-9 #xA1
#x00A1 #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7 #x00A8
#x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7 #x00F8
#x00F9 #x00FA #x00FB #x00FC #x0131 #x015F #x00FF)
-(define-coding-aliases 'ISO-8859-9
- '(ISO_8859-9:1989 ISO-IR-148 ISO_8859-9 LATIN5 L5 CSISOLATIN5))
+(define-coding-aliases 'iso-8859-9
+ '(iso_8859-9:1989 iso-ir-148 iso_8859-9 latin5 l5 csisolatin5))
(define-8-bit-codecs iso-8859-10 #xA1
#x0104 #x0112 #x0122 #x012A #x0128 #x0136 #x00A7 #x013B
#x0146 #x014D #x00F3 #x00F4 #x00F5 #x00F6 #x0169 #x00F8
#x0173 #x00FA #x00FB #x00FC #x00FD #x00FE #x0138)
-(define-coding-aliases 'ISO-8859-10
- '(ISO-IR-157 L6 ISO_8859-10:1992 CSISOLATIN6 LATIN6))
+(define-coding-aliases 'iso-8859-10
+ '(iso-ir-157 l6 iso_8859-10:1992 csisolatin6 latin6))
(define-8-bit-codecs iso-8859-11 #xA1
#x0E01 #x0E02 #x0E03 #x0E04 #x0E05 #x0E06 #x0E07 #x0E08
#x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x1E6B #x00F8
#x00F9 #x00FA #x00FB #x00FC #x00FD #x0177 #x00FF)
-(define-coding-aliases 'ISO-8859-14
- '(ISO-IR-199 ISO_8859-14:1998 ISO_8859-14 LATIN8 ISO-CELTIC L8))
+(define-coding-aliases 'iso-8859-14
+ '(iso-ir-199 iso_8859-14:1998 iso_8859-14 latin8 iso-celtic l8))
(define-8-bit-codecs iso-8859-15 #xA1
#x00A1 #x00A2 #x00A3 #x20AC #x00A5 #x0160 #x00A7 #x0161
#x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7 #x00F8
#x00F9 #x00FA #x00FB #x00FC #x00FD #x00FE #x00FF)
-(define-coding-aliases 'ISO-8859-15
- '(ISO_8859-15 LATIN-9))
+(define-coding-aliases 'iso-8859-15
+ '(iso_8859-15 latin-9))
(define-8-bit-codecs iso-8859-16 #xA1
#x0104 #x0105 #x0141 #x20AC #x201E #x0160 #x00A7 #x0161
#x0144 #x00F2 #x00F3 #x00F4 #x0151 #x00F6 #x015B #x0171
#x00F9 #x00FA #x00FB #x00FC #x0119 #x021B #x00FF)
-(define-coding-aliases 'ISO-8859-16
- '(ISO-IR-226 ISO_8859-16:2001 ISO_8859-16 LATIN10 L10))
+(define-coding-aliases 'iso-8859-16
+ '(iso-ir-226 iso_8859-16:2001 iso_8859-16 latin10 l10))
\f
(define-8-bit-codecs windows-1250 #x80
#x20ac #f #x201a #f #x201e #x2026 #x2020 #x2021
\f
;;;; Unicode codecs
-(define-decoder 'UTF-8
+(define-decoder 'utf-8
(lambda (ib)
(let ((n (initial-byte->utf8-char-length (peek-byte ib))))
(read-bytes! ib 0 n)
(decode-utf8-char (input-buffer-bytes ib) 0))))
-(define-encoder 'UTF-8
+(define-encoder 'utf-8
(lambda (ob char)
(encode-utf8-char! (output-buffer-bytes ob) 0 char)))
-(define-coding-alias 'UTF-16
+(define-coding-alias 'utf-16
(lambda ()
- (if (host-big-endian?) 'UTF-16BE 'UTF-16LE)))
+ (if (host-big-endian?) 'utf-16be 'utf-16le)))
(define-decoder 'utf-16be
(lambda (ib)
(read-bytes! ib 2 n))
(decode-utf16le-char (input-buffer-bytes ib) 0))))
-(define-encoder 'UTF-16BE
+(define-encoder 'utf-16be
(lambda (ob char)
(encode-utf16be-char! (output-buffer-bytes ob) 0 char)))
-(define-encoder 'UTF-16LE
+(define-encoder 'utf-16le
(lambda (ob char)
(encode-utf16le-char! (output-buffer-bytes ob) 0 char)))
-(define-coding-alias 'UTF-32
+(define-coding-alias 'utf-32
(lambda ()
- (if (host-big-endian?) 'UTF-32BE 'UTF-32LE)))
+ (if (host-big-endian?) 'utf-32be 'utf-32le)))
(define-decoder 'utf-32be
(lambda (ib)
(read-bytes! ib 0 4)
(decode-utf32le-char (input-buffer-bytes ib) 0)))
-(define-encoder 'UTF-32BE
+(define-encoder 'utf-32be
(lambda (ob char)
(encode-utf32be-char! (output-buffer-bytes ob) 0 char)))
-(define-encoder 'UTF-32LE
+(define-encoder 'utf-32le
(lambda (ob char)
(encode-utf32le-char! (output-buffer-bytes ob) 0 char)))
\f
;;;; Normalizers
-(define-normalizer 'NEWLINE
+(define-normalizer 'newline
(lambda (ib)
(decode-char ib)))
-(define-denormalizer 'NEWLINE
+(define-denormalizer 'newline
(lambda (ob char)
(encode-char ob char)))
-(define-normalizer 'CR
+(define-normalizer 'cr
(lambda (ib)
(let ((c0 (decode-char ib)))
- (if (eq? c0 #\U+000D)
+ (if (eq? c0 #\u+000D)
#\newline
c0))))
-(define-denormalizer 'CR
+(define-denormalizer 'cr
(lambda (ob char)
- (encode-char ob (if (char=? char #\newline) #\U+000D char))))
+ (encode-char ob (if (char=? char #\newline) #\u+000D char))))
-(define-normalizer 'CRLF
+(define-normalizer 'crlf
(lambda (ib)
(let ((c0 (decode-char ib)))
(case c0
- ((#\U+000D)
+ ((#\u+000D)
(let ((c1 (decode-char ib)))
(case c1
- ((#\U+000A)
+ ((#\u+000A)
#\newline)
((#f)
(unread-decoded-char ib c1)
c0))))
(else c0)))))
-(define-denormalizer 'CRLF
+(define-denormalizer 'crlf
(lambda (ob char)
(if (char=? char #\newline)
- (let ((n1 (encode-char ob #\U+000D)))
+ (let ((n1 (encode-char ob #\u+000D)))
(if (eq? n1 1)
- (let ((n2 (encode-char ob #\U+000A)))
+ (let ((n2 (encode-char ob #\u+000A)))
(if (not (eq? n2 1))
(error:char-encoding ob char))
2)
n1))
(encode-char ob char))))
\f
-(define-normalizer 'XML-1.0
+(define-normalizer 'xml-1.0
(lambda (ib)
(let ((c0 (decode-char ib)))
(case c0
- ((#\U+000D)
+ ((#\u+000D)
(let ((c1 (decode-char ib)))
(case c1
- ((#\U+000A)
+ ((#\u+000A)
#\newline)
((#f)
(unread-decoded-char ib c1)
#\newline))))
(else c0)))))
-(define-denormalizer 'XML-1.0
+(define-denormalizer 'xml-1.0
(lambda (ob char)
(encode-char ob char)))
-(define-normalizer 'XML-1.1
+(define-normalizer 'xml-1.1
(lambda (ib)
(let ((c0 (decode-char ib)))
(case c0
- ((#\U+000D)
+ ((#\u+000D)
(let ((c1 (decode-char ib)))
(case c1
- ((#\U+000A #\U+0085)
+ ((#\u+000A #\u+0085)
#\newline)
((#f)
(unread-decoded-char ib c1)
(else
(unread-decoded-char ib c1)
#\newline))))
- ((#\U+0085 #\U+2028) #\newline)
+ ((#\u+0085 #\u+2028) #\newline)
(else c0)))))
-(define-denormalizer 'XML-1.1
+(define-denormalizer 'xml-1.1
(lambda (ob char)
(encode-char ob char)))
-(define-line-ending-alias 'TEXT 'XML-1.0)
-(define-line-ending-alias 'LF 'NEWLINE)
-(define-line-ending-alias 'BINARY 'NEWLINE)
-(define-line-ending-alias 'HTTP 'XML-1.0)
+(define-line-ending-alias 'text 'xml-1.0)
+(define-line-ending-alias 'lf 'newline)
+(define-line-ending-alias 'binary 'newline)
+(define-line-ending-alias 'http 'xml-1.0)
\f
;;;; Conditions
(add-boot-init!
(lambda ()
(set! condition-type:char-decoding-error
- (make-condition-type 'CHAR-DECODING-ERROR condition-type:port-error '()
+ (make-condition-type 'char-decoding-error condition-type:port-error '()
(lambda (condition port)
(write-string "The input port " port)
- (write (access-condition condition 'PORT) port)
+ (write (access-condition condition 'port) port)
(write-string " was unable to decode a character." port)
(newline port))))
(set! %error:char-decoding
(condition-signaller condition-type:char-decoding-error
- '(PORT)
+ '(port)
standard-error-handler))
(set! condition-type:char-encoding-error
- (make-condition-type 'CHAR-ENCODING-ERROR condition-type:port-error
- '(CHAR)
+ (make-condition-type 'char-encoding-error condition-type:port-error
+ '(char)
(lambda (condition port)
(write-string "The output port " port)
- (write (access-condition condition 'PORT) port)
+ (write (access-condition condition 'port) port)
(write-string " was unable to encode the character " port)
- (write (access-condition condition 'CHAR) port)
+ (write (access-condition condition 'char) port)
(newline port))))
(set! %error:char-encoding
(condition-signaller condition-type:char-encoding-error
- '(PORT CHAR)
+ '(port char)
standard-error-handler))
unspecific))
\ No newline at end of file
(set! param:quit-hook (make-settable-parameter default/quit))
;; Kludge until the next released version, to avoid a bootstrapping
;; failure.
- (set! ephemeron-type (microcode-type 'EPHEMERON))
+ (set! ephemeron-type (microcode-type 'ephemeron))
unspecific)
\f
;;;; Potpourri
(lambda (port) (write object port)))))
\f
(define (pa procedure)
- (guarantee procedure? procedure 'PA)
+ (guarantee procedure? procedure 'pa)
(cond ((procedure-lambda procedure)
=> (lambda (scode)
(pp (unsyntax-lambda-list scode))))
(fix:>= t -4)
(fix:<= t 4)))
(error "Illegal GC-type value:" t))
- (vector-ref '#(COMPILED-ENTRY VECTOR GC-INTERNAL UNDEFINED NON-POINTER
- CELL PAIR TRIPLE QUADRUPLE)
+ (vector-ref '#(compiled-entry vector gc-internal undefined non-pointer
+ cell pair triple quadruple)
(fix:+ t 4)))
(define (object-non-pointer? object)
(case (object-gc-type object)
- ((NON-POINTER) #t)
- ((GC-INTERNAL)
+ ((non-pointer) #t)
+ ((gc-internal)
(or (object-type? (ucode-type manifest-nm-vector) object)
(and (object-type? (ucode-type reference-trap) object)
(<= (object-datum object) trap-max-immediate))))
(define (object-pointer? object)
(case (object-gc-type object)
- ((CELL PAIR TRIPLE QUADRUPLE VECTOR COMPILED-ENTRY) #t)
- ((GC-INTERNAL)
+ ((cell pair triple quadruple vector compiled-entry) #t)
+ ((gc-internal)
(or (object-type? (ucode-type broken-heart) object)
(and (object-type? (ucode-type reference-trap) object)
(> (object-datum object) trap-max-immediate))))
(define (non-pointer-type-code? code)
(case (type-code->gc-type code)
- ((NON-POINTER) #t)
- ((GC-INTERNAL) (fix:= (ucode-type manifest-nm-vector) code))
+ ((non-pointer) #t)
+ ((gc-internal) (fix:= (ucode-type manifest-nm-vector) code))
(else #f)))
(define (pointer-type-code? code)
(case (type-code->gc-type code)
- ((CELL PAIR TRIPLE QUADRUPLE VECTOR COMPILED-ENTRY) #t)
- ((GC-INTERNAL) (fix:= (ucode-type broken-heart) code))
+ ((cell pair triple quadruple vector compiled-entry) #t)
+ ((gc-internal) (fix:= (ucode-type broken-heart) code))
(else #f)))
(define (undefined-value? object)
(define (for-each-interned-symbol procedure)
(with-obarray-lock
(lambda ()
- (for-each-symbol-in-obarray (fixed-objects-item 'OBARRAY) procedure))))
+ (for-each-symbol-in-obarray (fixed-objects-item 'obarray) procedure))))
(define (for-each-symbol-in-obarray obarray procedure)
(let per-bucket ((index (vector-length obarray)))
(define (clean-obarray)
(with-obarray-lock
(lambda ()
- (let ((obarray (fixed-objects-item 'OBARRAY)))
+ (let ((obarray (fixed-objects-item 'obarray)))
(let loop ((index (vector-length obarray)))
(if (fix:> index 0)
(let ((index (fix:- index 1)))
(if (not ((ucode-primitive primitive-fasdump)
object (string-for-primitive filename) dump-option))
(begin
- (with-simple-restart 'RETRY "Try again."
+ (with-simple-restart 'retry "Try again."
(lambda ()
(error "FASDUMP: Object is too large to be dumped:"
object)))
(%make-hook-list '()))
(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)))
;;; . for
;;; . GC
-(define canonical-false (list 'FALSE))
+(define canonical-false (list 'false))
(define (canonicalize object)
(if (eq? object #f)
object))
(define (make-ephemeron key datum)
- ((ucode-primitive MAKE-EPHEMERON 2) (canonicalize key) (canonicalize datum)))
+ ((ucode-primitive make-ephemeron 2) (canonicalize key) (canonicalize datum)))
(define (ephemeron? object)
(object-type? ephemeron-type object))
(define-guarantee ephemeron "ephemeron")
(define (ephemeron-key ephemeron)
- (guarantee-ephemeron ephemeron 'EPHEMERON-KEY)
+ (guarantee-ephemeron ephemeron 'ephemeron-key)
(decanonicalize (primitive-object-ref ephemeron 1)))
(define (ephemeron-datum ephemeron)
- (guarantee-ephemeron ephemeron 'EPHEMERON-DATUM)
+ (guarantee-ephemeron ephemeron 'ephemeron-datum)
(decanonicalize (primitive-object-ref ephemeron 2)))
(define (set-ephemeron-key! ephemeron key)
- (guarantee-ephemeron ephemeron 'SET-EPHEMERON-KEY!)
+ (guarantee-ephemeron ephemeron 'set-ephemeron-key!)
(let ((key* (primitive-object-ref ephemeron 1)))
(if key* (primitive-object-set! ephemeron 1 (canonicalize key)))
(reference-barrier key*))
unspecific)
(define (set-ephemeron-datum! ephemeron datum)
- (guarantee-ephemeron ephemeron 'SET-EPHEMERON-DATUM!)
+ (guarantee-ephemeron ephemeron 'set-ephemeron-datum!)
(let ((key (primitive-object-ref ephemeron 1)))
(if key (primitive-object-set! ephemeron 2 (canonicalize datum)))
(reference-barrier key))
unspecific)
(define (ephemeron-broken? ephemeron)
- (guarantee-ephemeron ephemeron 'EPHEMERON-BROKEN?)
+ (guarantee-ephemeron ephemeron 'ephemeron-broken?)
(not (primitive-object-ref ephemeron 1)))
\ No newline at end of file
operation/set-line-style
custom-operations))
(print-procedure
- (simple-unparser-method 'GRAPHICS-TYPE
+ (simple-unparser-method 'graphics-type
(lambda (type)
(list (graphics-device-type/name type))))))
(name false read-only true)
((graphics-device-type/operation/available? type)))
(define (graphics-type-name type)
- (guarantee-graphics-type type 'GRAPHICS-TYPE-NAME)
+ (guarantee-graphics-type type 'graphics-type-name)
(graphics-device-type/name type))
(define (graphics-type-properties type)
- (guarantee-graphics-type type 'GRAPHICS-TYPE-PROPERTIES)
+ (guarantee-graphics-type type 'graphics-type-properties)
(graphics-device-type/properties type))
(define (guarantee-graphics-type type name)
(sc-macro-transformer
(lambda (form environment)
(let ((name (cadr form)))
- `(DEFINE-INTEGRABLE
- (,(symbol 'GRAPHICS-DEVICE/OPERATION/ name) DEVICE)
- (,(close-syntax (symbol 'GRAPHICS-DEVICE-TYPE/OPERATION/
+ `(define-integrable
+ (,(symbol 'graphics-device/operation/ name) device)
+ (,(close-syntax (symbol 'graphics-device-type/operation/
name)
environment)
- (GRAPHICS-DEVICE/TYPE DEVICE)))))))
+ (graphics-device/type device)))))))
(define-graphics-operation clear)
(define-graphics-operation close)
(let ((type (graphics-type object error?)))
(and type
(or (1d-table/get (graphics-type-properties type)
- 'IMAGE-TYPE
+ 'image-type
#f)
(and error?
(error "Graphics type has no associated image type:"
(%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)
+ '%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
(< 0 x)
(<= x 1)))
"real number between 0 (exclusive) and 1 (inclusive)"
- 'SET-HASH-TABLE/REHASH-THRESHOLD!)))
+ 'set-hash-table/rehash-threshold!)))
(without-interruption
(lambda ()
(set-table-rehash-threshold! table 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
((real? x) (< 1 x))
(else #f)))
"real number > 1 or exact integer >= 1"
- 'SET-HASH-TABLE/REHASH-SIZE!)))
+ 'set-hash-table/rehash-size!)))
(without-interruption
(lambda ()
(set-table-rehash-size! table 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))
(define-integrable (maybe-weak-cons a d)
(if (non-weak? a)
(cons a d)
- (system-pair-cons (ucode-type WEAK-CONS) a d)))
+ (system-pair-cons (ucode-type weak-cons) a d)))
\f
;;;; Entries of various flavours
(let ((name (caadr form))
(parameters (cdadr form))
(body (cddr form)))
- `(DEFINE-SYNTAX ,name
- (SC-MACRO-TRANSFORMER
- (LAMBDA (FORM ENVIRONMENT)
- (CONS '(NAMED-LAMBDA (,name ,@parameters)
- (DECLARE (INTEGRATE ,@parameters))
+ `(define-syntax ,name
+ (sc-macro-transformer
+ (lambda (form environment)
+ (cons '(named-lambda (,name ,@parameters)
+ (declare (integrate ,@parameters))
,@body)
- (MAP (LAMBDA (SUBFORM)
- (CLOSE-SYNTAX SUBFORM ENVIRONMENT))
- (CDR FORM))))))))))
+ (map (lambda (subform)
+ (close-syntax subform environment))
+ (cdr form))))))))))
(define-integrableish (open-type-constructor entry-type)
(declare (integrate-operator %make-hash-table-type make-table-type))
(lambda ()
(let-syntax ((init
(syntax-rules ()
- ((INIT constructor type)
- (SET! constructor (HASH-TABLE-CONSTRUCTOR type))))))
+ ((init constructor type)
+ (set! constructor (hash-table-constructor type))))))
(init make-equal-hash-table equal-hash-table-type)
;; This is done above.
;; (init make-key-ephemeral-eq-hash-table key-ephemeral-eq-hash-table-type)
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)))
(if (eq? datum default-marker)
(begin
(if (default-object? get-default)
- (error:bad-range-argument key 'HASH-TABLE-REF))
+ (error:bad-range-argument key 'hash-table-ref))
(get-default))
datum)))
key
(if (default-object? get-default)
(lambda ()
- (error:bad-range-argument key 'HASH-TABLE-UPDATE!))
+ (error:bad-range-argument key 'hash-table-update!))
get-default)))))
(define (hash-table-update!/default table key procedure default)
(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)
(define-integrable without-interruption with-thread-events-blocked)
(define default-marker
- (list 'DEFAULT-MARKER))
+ (list 'default-marker))
(define equality-predicate?)
(define maybe-get-equality-predicate-hasher)
default-hash-table
table))))
(if (not object)
- (error:bad-range-argument n 'UNHASH))
+ (error:bad-range-argument n 'unhash))
object)))
(define (valid-hash-number? n #!optional table)
(if (not (hash-table? table))
(error:wrong-type-argument table
"object-hash table"
- 'OBJECT-HASH))
+ 'object-hash))
table)))
(insert? (or (default-object? insert?) insert?)))
(with-thread-mutex-lock (hash-table/mutex table)
(if (not (hash-table? table))
(error:wrong-type-argument table
"object-hash table"
- 'OBJECT-UNHASH))
+ 'object-unhash))
table))))
(with-thread-mutex-lock (hash-table/mutex table)
(lambda ()
(define the-empty-history)
(define (unfold-and-reverse-rib rib)
- (let loop ((current (next-reduction rib)) (output 'WRAP-AROUND))
+ (let loop ((current (next-reduction rib)) (output 'wrap-around))
(let ((step
(let ((tail
(if (marked-reduction? current)
(define (initialize-package!)
(set! the-empty-history
- (cons (fixed-objects-item 'DUMMY-HISTORY)
+ (cons (fixed-objects-item 'dummy-history)
'()))
unspecific)
\ No newline at end of file
(cons (car headers) (loop (cdr headers))))
'())))
- (list (add 'ACCEPT
+ (list (add 'accept
(lambda ()
- `((,(make-mime-type 'APPLICATION 'XHTML+XML))
- (,(make-mime-type 'TEXT 'XHTML) (Q . "0.9"))
- (,(make-mime-type 'TEXT 'PLAIN) (Q . "0.5"))
- (TEXT (Q . "0.1")))))
- (add 'ACCEPT-CHARSET (lambda () '((US-ASCII) (ISO-8859-1) (UTF-8))))
- (add 'ACCEPT-ENCODING (lambda () '((IDENTITY))))
- (add 'ACCEPT-LANGUAGE (lambda () `((EN-US) (EN (Q . "0.9")))))
- (modify 'CONNECTION
+ `((,(make-mime-type 'application 'xhtml+xml))
+ (,(make-mime-type 'text 'xhtml) (q . "0.9"))
+ (,(make-mime-type 'text 'plain) (q . "0.5"))
+ (text (q . "0.1")))))
+ (add 'accept-charset (lambda () '((us-ascii) (iso-8859-1) (utf-8))))
+ (add 'accept-encoding (lambda () '((identity))))
+ (add 'accept-language (lambda () `((en-us) (en (q . "0.9")))))
+ (modify 'connection
(lambda (value change no-change)
- (if (memq 'TE value)
+ (if (memq 'te value)
(no-change)
- (change (cons 'TE value))))
+ (change (cons 'te value))))
'())
- (add 'DATE
+ (add 'date
(lambda ()
(universal-time->global-decoded-time (get-universal-time))))
(lambda (method uri headers)
method
- (if (http-header 'HOST headers #f)
+ (if (http-header 'host headers #f)
headers
(cons (make-http-header
- 'HOST
+ 'host
(let ((authority (uri-authority uri)))
(cons (uri-authority-host authority)
(uri-authority-port authority))))
headers)))
- (modify 'TE
+ (modify 'te
(lambda (value change no-change)
- (if (assq 'TRAILERS value)
+ (if (assq 'trailers value)
(no-change)
- (change (cons (list 'TRAILERS) value))))
+ (change (cons (list 'trailers) value))))
'())
- (add 'USER-AGENT (lambda () default-http-user-agent)))))
\ No newline at end of file
+ (add 'user-agent (lambda () default-http-user-agent)))))
\ No newline at end of file
(body http-request-body))
(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)
+ (guarantee-headers&body headers body 'make-http-request)
(%make-http-request method uri version headers body)))
(define-unparser-method http-request?
- (simple-unparser-method 'HTTP-REQUEST
+ (simple-unparser-method 'http-request
(lambda (request)
(list (http-request-method request)
(uri->string (http-request-uri request))))))
(body http-response-body))
(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)
+ (guarantee-headers&body headers body 'make-http-response)
(%make-http-response version status reason headers body)))
(define-unparser-method http-response?
- (simple-unparser-method 'HTTP-RESPONSE
+ (simple-unparser-method 'http-response
(lambda (response)
(list (http-response-status response)))))
(if (not (= n m))
(error:bad-range-argument body caller))
(values headers body))
- (values (cons (make-http-header 'CONTENT-LENGTH
+ (values (cons (make-http-header 'content-length
(number->string m))
headers)
body))))
(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)
(define (http-message-headers message)
(cond ((http-request? message) (http-request-headers message))
((http-response? message) (http-response-headers message))
- (else (error:not-http-message message 'HTTP-MESSAGE-HEADERS))))
+ (else (error:not-http-message message 'http-message-headers))))
(define (http-message-body message)
(cond ((http-request? message) (http-request-body message))
((http-response? message) (http-response-body message))
- (else (error:not-http-message message 'HTTP-MESSAGE-BODY))))
+ (else (error:not-http-message message 'http-message-body))))
(define (http-request-uri? object)
(or (simple-http-request-uri? object)
;;;; Output
(define (%text-mode port)
- (port/set-coding port 'ISO-8859-1)
- (port/set-line-ending port 'CRLF))
+ (port/set-coding port 'iso-8859-1)
+ (port/set-line-ending port 'crlf))
(define (%binary-mode port)
- (port/set-coding port 'BINARY)
- (port/set-line-ending port 'BINARY))
+ (port/set-coding port 'binary)
+ (port/set-line-ending port 'binary))
(define (write-http-request request port)
(%text-mode port)
(car b.t))))))))
\f
(define (%read-chunked-body headers port)
- (let ((h (http-header 'TRANSFER-ENCODING headers #f)))
+ (let ((h (http-header 'transfer-encoding headers #f)))
(and h
(let ((v (http-header-parsed-value h)))
(and (not (default-object? v))
- (assq 'CHUNKED v)))
+ (assq 'chunked v)))
(let ((output (open-output-bytevector))
(buffer (make-string #x1000)))
(let loop ()
(%read-chunk n (make-string #x1000) port output)))))))
(define (%read-terminal-body headers port)
- (and (let ((h (http-header 'CONNECTION headers #f)))
+ (and (let ((h (http-header 'connection headers #f)))
(and h
(let ((v (http-header-parsed-value h)))
(and (not (default-object? v))
- (memq 'CLOSE v)))))
+ (memq 'close v)))))
(list (%read-all port))))
(define (%read-all port)
;;;; 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)))
(binary->textual-port
(open-input-bytevector (http-message-body message)))))
(receive (type coding) (%get-content-type message)
- (cond ((eq? (mime-type/top-level type) 'TEXT)
- (port/set-coding port (or coding 'TEXT))
- (port/set-line-ending port 'TEXT))
- ((and (eq? (mime-type/top-level type) 'APPLICATION)
+ (cond ((eq? (mime-type/top-level type) 'text)
+ (port/set-coding port (or coding 'text))
+ (port/set-line-ending port 'text))
+ ((and (eq? (mime-type/top-level type) 'application)
(let ((sub (mime-type/subtype type)))
- (or (eq? sub 'XML)
+ (or (eq? sub 'xml)
(string-suffix-ci? "+xml" (symbol->string sub)))))
- (port/set-coding port (or coding 'UTF-8))
- (port/set-line-ending port 'XML-1.0))
+ (port/set-coding port (or coding 'utf-8))
+ (port/set-line-ending port 'xml-1.0))
(coding
(port/set-coding port coding)
- (port/set-line-ending port 'TEXT))
+ (port/set-line-ending port 'text))
(else
- (port/set-coding port 'BINARY)
- (port/set-line-ending port 'BINARY))))
+ (port/set-coding port 'binary)
+ (port/set-line-ending port 'binary))))
port))
(define (%get-content-type message)
- (optional-header (http-message-header 'CONTENT-TYPE message #f)
+ (optional-header (http-message-header 'content-type message #f)
(lambda (v)
(values (car v)
- (let ((p (assq 'CHARSET (cdr v))))
+ (let ((p (assq 'charset (cdr v))))
(and p
(let ((coding (intern (cdr p))))
(and (known-input-port-coding? coding)
coding))))))
(lambda ()
- (values (make-mime-type 'APPLICATION 'OCTET-STREAM)
+ (values (make-mime-type 'application 'octet-stream)
#f))))
(define (%get-content-length headers)
- (optional-header (http-header 'CONTENT-LENGTH headers #f)
+ (optional-header (http-header 'content-length headers #f)
(lambda (n) n)
(lambda () #f)))
(loop (cddr args) (+ i 1)))))))
(define (opt-writer elt-writer)
- (cons 'OPT-WRITER elt-writer))
+ (cons 'opt-writer elt-writer))
(define (opt-writer? object)
(and (pair? object)
\f
(define (qparam? object)
(and (parameter? object)
- (eq? (car object) 'Q)))
+ (eq? (car object) 'q)))
(define lp:token+qparam
(list-parser
(if (zero? trailing-significand)
(compose-ieee754-infinity sign base emax precision)
(let ((p-1 (- precision 1))
- (T trailing-significand))
- (let ((quiet (extract-bit-field 1 p-1 T))
- (payload (extract-bit-field p-1 0 T)))
+ (t trailing-significand))
+ (let ((quiet (extract-bit-field 1 p-1 t))
+ (payload (extract-bit-field p-1 0 t)))
(compose-ieee754-nan sign quiet payload
base emax precision)))))
(else
(let ((lose
(lambda ()
(error:wrong-type-argument info "dbg-info-vector"
- 'DBG-INFO-VECTOR/BLOCKS-VECTOR))))
+ 'dbg-info-vector/blocks-vector))))
(cond ((new-dbg-info-vector? info)
(vector-append (vector (dbg-info-vector/root-block info))
(dbg-info-vector/other-blocks info)))
(let ((lose
(lambda ()
(error:wrong-type-argument info "dbg-info-vector"
- 'DBG-INFO-VECTOR/PURIFICATION-ROOT))))
+ 'dbg-info-vector/purification-root))))
(cond ((new-dbg-info-vector? info)
(dbg-info-vector/other-blocks info))
((old-dbg-info-vector? info)
(define (%compound-items? items)
(and (pair? items)
- (eq? (car items) 'COMPILED-BY-PROCEDURES)
+ (eq? (car items) 'compiled-by-procedures)
(pair? (cdr items))
(vector? (cadr items))
(pair? (cddr items))
((dbg-block-name
(sc-macro-transformer
(lambda (form environment)
- (let ((symbol (symbol 'DBG-BLOCK-NAME/ (cadr form))))
- `(DEFINE-INTEGRABLE ,symbol
+ (let ((symbol (symbol 'dbg-block-name/ (cadr form))))
+ `(define-integrable ,symbol
',((ucode-primitive string->symbol)
(string-append "#[(runtime compiler-info)"
(string-downcase (symbol->string symbol))
(define (convert-old-debugging-wrapper wrapper)
(let ((make-wrapper
(lambda (pathname index info)
- (vector 'DEBUGGING-INFO-WRAPPER 1 #f
+ (vector 'debugging-info-wrapper 1 #f
(convert-old-style-pathname pathname)
index info))))
(cond ((dbg-info? wrapper)
(define (debugging-file-wrapper? wrapper)
(and (vector? wrapper)
(fix:= (vector-length wrapper) 4)
- (eq? (vector-ref wrapper 0) 'DEBUGGING-FILE-WRAPPER)
+ (eq? (vector-ref wrapper 0) 'debugging-file-wrapper)
(or (and (fix:= (vector-ref wrapper 1) 1)
(not (vector-ref wrapper 2)))
(and (fix:= (vector-ref wrapper 1) 2)
(cond ((debugging-file-wrapper? wrapper)
wrapper)
((dbg-info? wrapper)
- (vector 'DEBUGGING-FILE-WRAPPER 1 #f (vector wrapper)))
+ (vector 'debugging-file-wrapper 1 #f (vector wrapper)))
((and (vector? wrapper)
(let ((n (vector-length wrapper)))
(and (fix:>= n 1)
(or (fix:= i n)
(and (dbg-info? (vector-ref wrapper i))
(loop (fix:+ i 1))))))))
- (vector 'DEBUGGING-FILE-WRAPPER 1 #f wrapper))
+ (vector 'debugging-file-wrapper 1 #f wrapper))
(else #f)))
(define (get-wrapped-dbg-info file-wrapper wrapper)
(merge-pathnames
(pathname-new-directory
(file-pathname pathname)
- (cons 'RELATIVE
+ (cons 'relative
(list-tail (pathname-directory pathname)
(length (pathname-directory (car rule))))))
(cdr rule))
(define (%find-library-directory pathname)
(let ((dir (pathname-directory pathname)))
(or (and (pair? dir)
- (eq? 'RELATIVE (car dir))
+ (eq? 'relative (car dir))
(pair? (cdr dir))
(string? (cadr dir))
(let ((libdir (system-library-directory-pathname (cadr dir))))
0))
(define (input-port/read-line port)
- (with-input-port-blocking-mode port 'BLOCKING
+ (with-input-port-blocking-mode port 'blocking
(lambda ()
(let ((read-char (textual-port-operation/read-char port))
(builder (string-builder)))
(loop)))))))))
(define (input-port/read-string port delimiters)
- (with-input-port-blocking-mode port 'BLOCKING
+ (with-input-port-blocking-mode port 'blocking
(lambda ()
(let ((read-char (textual-port-operation/read-char port))
(builder (string-builder)))
(loop)))))))))
\f
(define (input-port/discard-chars port delimiters)
- (with-input-port-blocking-mode port 'BLOCKING
+ (with-input-port-blocking-mode port 'blocking
(lambda ()
(let ((read-char (textual-port-operation/read-char port)))
(let loop ()
(eq? object (eof-object)))
(define (input-port/eof? port)
- (let ((eof? (textual-port-operation port 'EOF?)))
+ (let ((eof? (textual-port-operation port 'eof?)))
(and eof?
(eof? port))))
(define (input-port/line port)
- (let ((operation (textual-port-operation port 'INPUT-LINE)))
+ (let ((operation (textual-port-operation port 'input-line)))
(and operation
(operation port))))
\f
;;;; High level
(define (char-ready? #!optional port interval)
- (let ((port (optional-input-port port 'CHAR-READY?))
+ (let ((port (optional-input-port port 'char-ready?))
(interval
(if (default-object? interval)
0
(begin
- (guarantee exact-nonnegative-integer? interval 'CHAR-READY?)
+ (guarantee exact-nonnegative-integer? interval 'char-ready?)
interval))))
(if (positive? interval)
(let ((timeout (+ (real-time-clock) interval)))
(input-port/char-ready? port))))
(define (read-char #!optional port)
- (let ((port (optional-input-port port 'READ-CHAR)))
+ (let ((port (optional-input-port port 'read-char)))
(let loop ()
(or (input-port/read-char port)
(loop)))))
(define (unread-char char #!optional port)
- (guarantee char? char 'UNREAD-CHAR)
- (input-port/unread-char (optional-input-port port 'UNREAD-CHAR) char))
+ (guarantee char? char 'unread-char)
+ (input-port/unread-char (optional-input-port port 'unread-char) char))
(define (peek-char #!optional port)
- (let ((port (optional-input-port port 'READ-CHAR)))
+ (let ((port (optional-input-port port 'read-char)))
(let loop ()
(or (input-port/peek-char port)
(loop)))))
(define (read-char-no-hang #!optional port)
- (let ((port (optional-input-port port 'READ-CHAR-NO-HANG)))
+ (let ((port (optional-input-port port 'read-char-no-hang)))
(and (input-port/char-ready? port)
(if (input-port/eof? port)
(eof-object)
(r7rs-read-string k port)))
(define (read-delimited-string delimiters #!optional port)
- (input-port/read-string (optional-input-port port 'READ-STRING) delimiters))
+ (input-port/read-string (optional-input-port port 'read-string) delimiters))
(define (r7rs-read-string k #!optional port)
(guarantee index-fixnum? k 'read-string)
\f
(define (read #!optional port environment)
(declare (ignore environment))
- (parse-object (optional-input-port port 'READ)))
+ (parse-object (optional-input-port port 'read)))
(define (read-file pathname #!optional environment)
(declare (ignore environment))
- (call-with-input-file (pathname-default-version pathname 'NEWEST)
+ (call-with-input-file (pathname-default-version pathname 'newest)
(lambda (port)
(let loop ((sexps '()))
(let ((sexp (read port)))
(loop (cons sexp sexps))))))))
(define (read-line #!optional port)
- (input-port/read-line (optional-input-port port 'READ-LINE)))
+ (input-port/read-line (optional-input-port port 'read-line)))
(define (read-string! string #!optional port start end)
(let ((port (optional-input-port port 'read-string!))
(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)))
\f
(define (initialize-package!)
(set! index:interrupt-vector
- (fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR))
+ (fixed-objects-vector-slot 'system-interrupt-vector))
(set! index:interrupt-mask-vector
- (fixed-objects-vector-slot 'INTERRUPT-MASK-VECTOR))
+ (fixed-objects-vector-slot 'interrupt-mask-vector))
(set! index:termination-vector
- (fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-PROCEDURES))
+ (fixed-objects-vector-slot 'microcode-terminations-procedures))
(set! event:console-resize (make-event-distributor))
(set! hook/clean-input/flush-typeahead false)
(set! hook/clean-input/keep-typeahead false)
- (set! hook/^B-interrupt false)
- (set! hook/^G-interrupt false)
- (set! hook/^U-interrupt false)
- (set! hook/^X-interrupt false)
+ (set! hook/^b-interrupt false)
+ (set! hook/^g-interrupt false)
+ (set! hook/^u-interrupt false)
+ (set! hook/^x-interrupt false)
(set! keyboard-interrupt-vector
(let ((table (make-vector 256 false)))
(for-each (lambda (entry)
(vector-set! table
(char->integer (car entry))
(cadr entry)))
- `((#\B ,^B-interrupt-handler)
- (#\G ,^G-interrupt-handler)
- (#\U ,^U-interrupt-handler)
- (#\X ,^X-interrupt-handler)))
+ `((#\B ,^b-interrupt-handler)
+ (#\G ,^g-interrupt-handler)
+ (#\U ,^u-interrupt-handler)
+ (#\X ,^x-interrupt-handler)))
table))
(install))
(define keyboard-interrupt-vector)
(define hook/clean-input/flush-typeahead)
(define hook/clean-input/keep-typeahead)
-(define hook/^B-interrupt)
-(define hook/^G-interrupt)
-(define hook/^U-interrupt)
-(define hook/^X-interrupt)
+(define hook/^b-interrupt)
+(define hook/^g-interrupt)
+(define hook/^u-interrupt)
+(define hook/^x-interrupt)
(define (external-interrupt-handler interrupt-code interrupt-mask)
interrupt-code interrupt-mask
(error "Bad interrupt character:" char))
(handler char))))
-(define (^B-interrupt-handler char)
- (signal-interrupt hook/^B-interrupt
+(define (^b-interrupt-handler char)
+ (signal-interrupt hook/^b-interrupt
hook/clean-input/keep-typeahead
char
cmdl-interrupt/breakpoint))
-(define (^G-interrupt-handler char)
- (signal-interrupt hook/^G-interrupt
+(define (^g-interrupt-handler char)
+ (signal-interrupt hook/^g-interrupt
hook/clean-input/flush-typeahead
char
cmdl-interrupt/abort-top-level))
-(define (^U-interrupt-handler char)
- (signal-interrupt hook/^U-interrupt
+(define (^u-interrupt-handler char)
+ (signal-interrupt hook/^u-interrupt
hook/clean-input/flush-typeahead
char
cmdl-interrupt/abort-previous))
-(define (^X-interrupt-handler char)
- (signal-interrupt hook/^X-interrupt
+(define (^x-interrupt-handler char)
+ (signal-interrupt hook/^x-interrupt
hook/clean-input/flush-typeahead
char
cmdl-interrupt/abort-nearest))
interrupt-mask/all)
(vector-set! termination-vector
- (microcode-termination 'GC-OUT-OF-SPACE)
+ (microcode-termination 'gc-out-of-space)
gc-out-of-space-handler)
(vector-set! fov index:interrupt-mask-vector interrupt-mask-vector)
(define-integrable keyword-prefix "#[keyword]")
(define (string->keyword string #!optional fold-case?)
- (guarantee string? string 'STRING->KEYWORD)
+ (guarantee string? string 'string->keyword)
((if (if (default-object? fold-case?) #f fold-case?)
intern
string->symbol)
(define-guarantee keyword "keyword")
(define (keyword->string keyword)
- (guarantee-keyword keyword 'KEYWORD->STRING)
+ (guarantee-keyword keyword 'keyword->string)
(string-tail (symbol->string keyword) (string-length keyword-prefix)))
\ No newline at end of file
(values required optional rest)))
(define (bad-lambda-list pattern)
- (error:not-a mit-lambda-list? pattern 'PARSE-MIT-LAMBDA-LIST))
+ (error:not-a mit-lambda-list? pattern 'parse-mit-lambda-list))
(parse-parameters required lambda-list)))
(eq? (vector-ref text 0) wrapper-tag)))))
(define wrapper-tag
- '(LAMBDA-WRAPPER))
+ '(lambda-wrapper))
(define-integrable (wrapper-body wrapper)
(scode-comment-expression wrapper))
projects / mit-scheme.git / commitdiff