From ca1cf87771a1d6f71efc9229f9e93470dfa8d60d Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 3 Apr 2018 23:23:23 -0700 Subject: [PATCH] Downcase a lot more symbols and constants. --- src/runtime/arith.scm | 358 ++++++++++++++++----------------- src/runtime/berkeley-db.scm | 108 +++++----- src/runtime/bytevector.scm | 6 +- src/runtime/char-set.scm | 8 +- src/runtime/char.scm | 46 ++--- src/runtime/chrsyn.scm | 10 +- src/runtime/codwlk.scm | 64 +++--- src/runtime/condvar.scm | 20 +- src/runtime/conpar.scm | 86 ++++---- src/runtime/console-io.scm | 32 +-- src/runtime/contin.scm | 2 +- src/runtime/datime.scm | 30 +-- src/runtime/dbgcmd.scm | 4 +- src/runtime/defstr.scm | 8 +- src/runtime/dragon4.scm | 28 +-- src/runtime/ed-ffi.scm | 4 +- src/runtime/emacs.scm | 38 ++-- src/runtime/environment.scm | 146 +++++++------- src/runtime/error.scm | 376 +++++++++++++++++------------------ src/runtime/events.scm | 12 +- src/runtime/ffi.scm | 14 +- src/runtime/file-io.scm | 22 +- src/runtime/floenv.scm | 80 ++++---- src/runtime/framex.scm | 60 +++--- src/runtime/gc.scm | 2 +- src/runtime/gcfinal.scm | 28 +-- src/runtime/gcstat.scm | 12 +- src/runtime/gdbm.scm | 40 ++-- src/runtime/generic-io.scm | 206 +++++++++---------- src/runtime/global.scm | 52 ++--- src/runtime/graphics.scm | 16 +- src/runtime/hash-table.scm | 80 ++++---- src/runtime/hash.scm | 6 +- src/runtime/histry.scm | 4 +- src/runtime/http-client.scm | 36 ++-- src/runtime/http-io.scm | 74 +++---- src/runtime/http-syntax.scm | 4 +- src/runtime/ieee754.scm | 6 +- src/runtime/infstr.scm | 18 +- src/runtime/infutl.scm | 4 +- src/runtime/input-port.scm | 32 +-- src/runtime/integer-bits.scm | 2 +- src/runtime/interrupt.scm | 48 ++--- src/runtime/keyword.scm | 4 +- src/runtime/lambda-list.scm | 2 +- src/runtime/lambda.scm | 2 +- 46 files changed, 1120 insertions(+), 1120 deletions(-) diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm index 3827e919f..7cdae3b8e 100644 --- a/src/runtime/arith.scm +++ b/src/runtime/arith.scm @@ -36,7 +36,7 @@ USA. (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 @@ -117,21 +117,21 @@ USA. (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) ;; The binary cases for the following operators rely on the fact that the ;; & operators, either interpreted or open-coded by the @@ -147,23 +147,23 @@ USA. (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 &*)) @@ -344,7 +344,7 @@ USA. (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 @@ -466,7 +466,7 @@ USA. (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 @@ -536,29 +536,29 @@ USA. (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:-) @@ -693,24 +693,24 @@ USA. (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)))))))) @@ -780,7 +780,7 @@ USA. ((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) @@ -947,7 +947,7 @@ USA. (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))) @@ -964,10 +964,10 @@ USA. (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+)) @@ -989,21 +989,21 @@ USA. (lambda (q) (if (rat:rational? q) q - (error:wrong-type-argument q #f 'INEXACT->EXACT)))) + (error:wrong-type-argument q #f 'inexact->exact)))) (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:-)) @@ -1117,7 +1117,7 @@ USA. (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 @@ -1126,20 +1126,20 @@ USA. (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) @@ -1155,10 +1155,10 @@ USA. (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) @@ -1167,10 +1167,10 @@ USA. (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) @@ -1178,11 +1178,11 @@ USA. (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) @@ -1231,10 +1231,10 @@ USA. ((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) @@ -1365,33 +1365,33 @@ USA. (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))) (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) @@ -1472,7 +1472,7 @@ USA. ((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) @@ -1506,111 +1506,111 @@ USA. ((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))) (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))) (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))) (define (complex:exp z) (if (recnum? z) @@ -1708,9 +1708,9 @@ USA. (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))))) @@ -1756,9 +1756,9 @@ USA. ((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 @@ -1793,16 +1793,16 @@ USA. (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) @@ -1816,12 +1816,12 @@ USA. (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) @@ -1989,11 +1989,11 @@ USA. (<= 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 @@ -2011,11 +2011,11 @@ USA. (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 @@ -2023,26 +2023,26 @@ USA. 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 diff --git a/src/runtime/berkeley-db.scm b/src/runtime/berkeley-db.scm index 5baf19fd7..bc7863342 100644 --- a/src/runtime/berkeley-db.scm +++ b/src/runtime/berkeley-db.scm @@ -62,86 +62,86 @@ USA. (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) ;; 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) @@ -150,7 +150,7 @@ USA. (define bdb-error (condition-signaller condition-type:bdb-error - '(RC PRIMITIVE) + '(rc primitive) standard-error-handler)) (define-record-type diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm index 43131d274..da6aefeab 100644 --- a/src/runtime/bytevector.scm +++ b/src/runtime/bytevector.scm @@ -442,11 +442,11 @@ USA. (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)) diff --git a/src/runtime/char-set.scm b/src/runtime/char-set.scm index efc7827b3..29c977023 100644 --- a/src/runtime/char-set.scm +++ b/src/runtime/char-set.scm @@ -624,13 +624,13 @@ USA. (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) diff --git a/src/runtime/char.scm b/src/runtime/char.scm index 333cef286..48147a398 100644 --- a/src/runtime/char.scm +++ b/src/runtime/char.scm @@ -40,8 +40,8 @@ USA. (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) @@ -58,20 +58,20 @@ USA. (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))) @@ -197,7 +197,7 @@ USA. (if (default-object? radix) 10 (begin - (guarantee radix? radix 'CHAR->DIGIT) + (guarantee radix? radix 'char->digit) radix))) (digit (digit-value char))) (if digit @@ -564,7 +564,7 @@ USA. ;; 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 ;; ------------------ ------ ------ ------ @@ -574,11 +574,11 @@ USA. ;; 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 ;; ------------------ ------ ------ ------ ------ @@ -587,27 +587,27 @@ USA. ;; 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))) (define (initial-u16->utf16-char-length u16) diff --git a/src/runtime/chrsyn.scm b/src/runtime/chrsyn.scm index aab6a82a1..b53fdb5fb 100644 --- a/src/runtime/chrsyn.scm +++ b/src/runtime/chrsyn.scm @@ -43,14 +43,14 @@ USA. (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)) @@ -59,7 +59,7 @@ USA. (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) @@ -110,7 +110,7 @@ USA. (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) diff --git a/src/runtime/codwlk.scm b/src/runtime/codwlk.scm index b0e5ff3d7..e9bc3b8e8 100644 --- a/src/runtime/codwlk.scm +++ b/src/runtime/codwlk.scm @@ -64,30 +64,30 @@ USA. (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))) @@ -109,20 +109,20 @@ USA. (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))) (define (walk/combination walker expression) diff --git a/src/runtime/condvar.scm b/src/runtime/condvar.scm index f1bb14b32..561f80bf1 100644 --- a/src/runtime/condvar.scm +++ b/src/runtime/condvar.scm @@ -34,7 +34,7 @@ USA. (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 '())))))) @@ -55,25 +55,25 @@ USA. (%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)) (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))) @@ -111,7 +111,7 @@ USA. (unblock-thread-events))))))) (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)) @@ -142,7 +142,7 @@ USA. 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)) diff --git a/src/runtime/conpar.scm b/src/runtime/conpar.scm index bf9b8fecd..ec0457a48 100644 --- a/src/runtime/conpar.scm +++ b/src/runtime/conpar.scm @@ -65,7 +65,7 @@ USA. (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))) @@ -444,11 +444,11 @@ USA. 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))) @@ -517,7 +517,7 @@ USA. (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) @@ -683,7 +683,7 @@ USA. 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))))) ;;;; Stack Frame Types @@ -702,7 +702,7 @@ USA. (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) @@ -727,18 +727,18 @@ USA. 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)) @@ -793,32 +793,32 @@ USA. (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) @@ -828,24 +828,24 @@ USA. (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)) ;;;; Hardware trap parsing diff --git a/src/runtime/console-io.scm b/src/runtime/console-io.scm index effd7c306..e32333970 100644 --- a/src/runtime/console-io.scm +++ b/src/runtime/console-io.scm @@ -32,21 +32,21 @@ USA. (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 @@ -81,14 +81,14 @@ USA. (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) diff --git a/src/runtime/contin.scm b/src/runtime/contin.scm index be0397b32..d0aa78cf9 100644 --- a/src/runtime/contin.scm +++ b/src/runtime/contin.scm @@ -39,7 +39,7 @@ USA. (%within-continuation k #f (lambda () (receiver k))))))) (define (within-continuation k thunk) - (guarantee continuation? k 'WITHIN-CONTINUATION) + (guarantee continuation? k 'within-continuation) (%within-continuation k #f thunk)) (define (make-continuation control-point dynamic-state block-thread-events?) diff --git a/src/runtime/datime.scm b/src/runtime/datime.scm index 2c31d35ef..2cdeb9afc 100644 --- a/src/runtime/datime.scm +++ b/src/runtime/datime.scm @@ -78,10 +78,10 @@ USA. (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) @@ -273,7 +273,7 @@ USA. (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) @@ -349,7 +349,7 @@ USA. (write-time-zone tz port)))) (define (write-time-zone tz port) - (guarantee time-zone? tz 'WRITE-TIME-ZONE) + (guarantee time-zone? tz 'write-time-zone) (let ((minutes (round (* 60 (- tz))))) (let ((qr (integer-divide (abs minutes) 60))) (write-char (if (< minutes 0) #\- #\+) port) @@ -359,7 +359,7 @@ USA. (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 @@ -458,7 +458,7 @@ USA. (*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) @@ -481,7 +481,7 @@ USA. (define (parser:ctime zone) (if zone - (guarantee time-zone? zone 'PARSER:CTIME)) + (guarantee time-zone? zone 'parser:ctime)) (*parser (encapsulate (lambda (v) (make-decoded-time (vector-ref v 5) @@ -524,14 +524,14 @@ USA. (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) @@ -870,15 +870,15 @@ USA. ;;;; 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) @@ -894,11 +894,11 @@ USA. (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) @@ -922,7 +922,7 @@ USA. (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)))) diff --git a/src/runtime/dbgcmd.scm b/src/runtime/dbgcmd.scm index 78c726f19..b80d514fe 100644 --- a/src/runtime/dbgcmd.scm +++ b/src/runtime/dbgcmd.scm @@ -78,7 +78,7 @@ USA. (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 @@ -120,7 +120,7 @@ USA. (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) diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm index 4738cddb6..eb3f8171a 100644 --- a/src/runtime/defstr.scm +++ b/src/runtime/defstr.scm @@ -296,7 +296,7 @@ differences: #f)) (define (default-type-name context) - (symbol 'RTD: (parser-context/name context))) + (symbol 'rtd: (parser-context/name context))) (define (apply-option-transformers options context) (let loop ((options options)) @@ -523,12 +523,12 @@ differences: (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) @@ -591,7 +591,7 @@ differences: ;;;; 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) diff --git a/src/runtime/dragon4.scm b/src/runtime/dragon4.scm index c09572add..35883f18b 100644 --- a/src/runtime/dragon4.scm +++ b/src/runtime/dragon4.scm @@ -51,7 +51,7 @@ not much different to numbers within a few orders of magnitude of 1. (define (initialize-dragon4!) (set! param:flonum-unparser-cutoff - (make-settable-parameter 'NORMAL + (make-settable-parameter 'normal (lambda (cutoff) (guarantee-cutoff-spec cutoff) cutoff))) @@ -152,8 +152,8 @@ not much different to numbers within a few orders of magnitude of 1. (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)) @@ -164,10 +164,10 @@ not much different to numbers within a few orders of magnitude of 1. (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) @@ -175,15 +175,15 @@ not much different to numbers within a few orders of magnitude of 1. (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)))))))) @@ -191,9 +191,9 @@ not much different to numbers within a few orders of magnitude of 1. (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) @@ -270,12 +270,12 @@ not much different to numbers within a few orders of magnitude of 1. (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+))) diff --git a/src/runtime/ed-ffi.scm b/src/runtime/ed-ffi.scm index 922a550e8..724896c98 100644 --- a/src/runtime/ed-ffi.scm +++ b/src/runtime/ed-ffi.scm @@ -131,7 +131,7 @@ USA. ("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)) @@ -192,6 +192,6 @@ USA. ("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 diff --git a/src/runtime/emacs.scm b/src/runtime/emacs.scm index 72430c725..85cbb234a 100644 --- a/src/runtime/emacs.scm +++ b/src/runtime/emacs.scm @@ -49,7 +49,7 @@ USA. (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) @@ -118,7 +118,7 @@ USA. (loop))) #t) -(define (emacs/^G-interrupt) +(define (emacs/^g-interrupt) (transmit-signal the-console-port #\g)) ;;;; Miscellaneous Hooks @@ -161,12 +161,12 @@ USA. (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)) @@ -239,19 +239,19 @@ USA. (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 () @@ -266,12 +266,12 @@ USA. (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))) diff --git a/src/runtime/environment.scm b/src/runtime/environment.scm index 8727c189b..cb6f88dbf 100644 --- a/src/runtime/environment.scm +++ b/src/runtime/environment.scm @@ -46,11 +46,11 @@ USA. ((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) @@ -58,7 +58,7 @@ USA. ((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) @@ -70,7 +70,7 @@ USA. ((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) @@ -81,7 +81,7 @@ USA. (closure-ccenv? environment)) '()) (else - (error:not-a environment? environment 'ENVIRONMENT-MACRO-NAMES)))) + (error:not-a environment? environment 'environment-macro-names)))) (define (environment-bindings environment) (let ((items (environment-bound-names environment))) @@ -104,9 +104,9 @@ USA. (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))) @@ -123,10 +123,10 @@ USA. ((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) @@ -136,13 +136,13 @@ USA. ((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))) (define (environment-lookup environment name) @@ -155,12 +155,12 @@ USA. (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))))) @@ -173,7 +173,7 @@ USA. ((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) @@ -183,7 +183,7 @@ USA. ((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) @@ -193,31 +193,31 @@ USA. ((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)))) ;;;; Global environment @@ -280,9 +280,9 @@ USA. (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) @@ -293,8 +293,8 @@ USA. (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) @@ -377,7 +377,7 @@ USA. (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) @@ -414,25 +414,25 @@ USA. (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?)) @@ -444,7 +444,7 @@ USA. 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))) @@ -477,12 +477,12 @@ USA. (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 @@ -493,7 +493,7 @@ USA. ((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))) @@ -509,7 +509,7 @@ USA. (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)) @@ -524,11 +524,11 @@ USA. (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))) @@ -538,14 +538,14 @@ USA. (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)) @@ -572,20 +572,20 @@ USA. (+ (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) @@ -613,9 +613,9 @@ USA. (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 @@ -627,7 +627,7 @@ USA. (dbg-procedure/optional procedure)) lookup (dbg-procedure/required procedure))) - 'UNKNOWN))) + 'unknown))) (define (stack-ccenv/bound-names environment) (map dbg-variable/name @@ -743,7 +743,7 @@ USA. (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)) @@ -798,10 +798,10 @@ USA. (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)) @@ -820,14 +820,14 @@ USA. 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 @@ -846,17 +846,17 @@ USA. (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)))) @@ -865,26 +865,26 @@ USA. (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)))) @@ -893,7 +893,7 @@ USA. (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))) @@ -904,13 +904,13 @@ USA. (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)))) diff --git a/src/runtime/error.scm b/src/runtime/error.scm index 6677a38ec..378f7b0f4 100644 --- a/src/runtime/error.scm +++ b/src/runtime/error.scm @@ -36,7 +36,7 @@ USA. (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))))) @@ -57,8 +57,8 @@ USA. (define (make-condition-type name generalization field-names reporter) (if generalization - (guarantee-condition-type generalization 'MAKE-CONDITION-TYPE)) - (guarantee list-of-unique-symbols? field-names 'MAKE-CONDITION-TYPE) + (guarantee-condition-type generalization 'make-condition-type)) + (guarantee list-of-unique-symbols? field-names 'make-condition-type) (let ((type (call-with-values (lambda () @@ -70,7 +70,7 @@ USA. ((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) @@ -89,7 +89,7 @@ USA. (else (error:wrong-type-argument reporter "condition-type reporter" - 'MAKE-CONDITION-TYPE)))))))) + 'make-condition-type)))))))) (set-%condition-type/generalizations! type (cons type @@ -130,19 +130,19 @@ USA. (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) @@ -158,7 +158,7 @@ USA. (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 @@ -177,19 +177,19 @@ USA. (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)) @@ -225,7 +225,7 @@ USA. constructor)))) (define-integrable (%restarts-argument restarts operator) - (cond ((eq? 'BOUND-RESTARTS restarts) + (cond ((eq? 'bound-restarts restarts) (param:bound-restarts)) ((condition? restarts) (%condition/restarts restarts)) @@ -234,11 +234,11 @@ USA. (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) @@ -246,39 +246,39 @@ USA. (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) @@ -288,8 +288,8 @@ USA. (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))) @@ -309,7 +309,7 @@ USA. (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))) @@ -328,13 +328,13 @@ USA. (guarantee-list-of-type object restart? "list of restarts" caller)) (define (with-restart name reporter effector interactor thunk) - (if name (guarantee symbol? name 'WITH-RESTART)) + (if name (guarantee symbol? name 'with-restart)) (if (not (or (string? reporter) (procedure-of-arity? reporter 1))) - (error:wrong-type-argument reporter "reporter" 'WITH-RESTART)) + (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) @@ -348,36 +348,36 @@ USA. 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))) @@ -387,11 +387,11 @@ USA. (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))) @@ -402,7 +402,7 @@ USA. (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)) @@ -410,16 +410,16 @@ USA. (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)))))) @@ -445,52 +445,52 @@ USA. (loop (cdr restarts)))))) (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)) @@ -505,16 +505,16 @@ USA. (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)))) @@ -524,7 +524,7 @@ USA. (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) @@ -534,7 +534,7 @@ USA. (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? @@ -551,7 +551,7 @@ USA. (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))) @@ -579,7 +579,7 @@ USA. (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)))) @@ -595,10 +595,10 @@ USA. (if (condition-type? datum) (make-condition datum continuation - 'BOUND-RESTARTS + 'bound-restarts arguments) (make-simple-condition continuation - 'BOUND-RESTARTS + 'bound-restarts datum arguments)))) (begin @@ -615,7 +615,7 @@ USA. (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 @@ -639,7 +639,7 @@ USA. (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 @@ -647,7 +647,7 @@ USA. (let ((condition (apply make-condition (cons* continuation - 'BOUND-RESTARTS + 'bound-restarts field-values)))) (signal-condition condition) (default-handler condition))))))) @@ -662,7 +662,7 @@ USA. 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 @@ -677,9 +677,9 @@ USA. (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)) @@ -691,7 +691,7 @@ USA. (lambda () (values (prompt-for-evaluated-expression prompt)))) (lambda () - (with-restart 'RETRY + (with-restart 'retry (if (string? retry-message) retry-message (retry-message condition)) @@ -763,11 +763,11 @@ USA. (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) @@ -789,51 +789,51 @@ USA. (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)))) (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) @@ -848,8 +848,8 @@ USA. (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 @@ -868,39 +868,39 @@ USA. (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))))) (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) @@ -908,13 +908,13 @@ USA. (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) @@ -934,25 +934,25 @@ USA. (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 @@ -963,65 +963,65 @@ USA. (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))) (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 ") @@ -1033,37 +1033,37 @@ USA. (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)) (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 @@ -1072,12 +1072,12 @@ USA. (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) @@ -1098,132 +1098,132 @@ USA. " 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)))) (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")))) (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) @@ -1243,7 +1243,7 @@ USA. (else (error:wrong-type-argument map-error "map-error procedure" - 'IGNORE-ERRORS))) + 'ignore-errors))) thunk)))) (define warn-errors? @@ -1279,7 +1279,7 @@ USA. (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")) diff --git a/src/runtime/events.scm b/src/runtime/events.scm index 2e3018d83..89e3f10af 100644 --- a/src/runtime/events.scm +++ b/src/runtime/events.scm @@ -30,8 +30,8 @@ USA. (declare (usual-integrations)) (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 @@ -43,7 +43,7 @@ USA. (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) @@ -70,13 +70,13 @@ USA. (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))) @@ -84,7 +84,7 @@ USA. (set-event-distributor/receivers! event-distributor (append! receivers (list receiver)))))) - ((REMOVE-RECEIVER) + ((remove-receiver) (set-event-distributor/receivers! event-distributor (delv! (cdr event) diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm index 29364bc43..43b8a4a55 100644 --- a/src/runtime/ffi.scm +++ b/src/runtime/ffi.scm @@ -639,27 +639,27 @@ USA. #;(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)) diff --git a/src/runtime/file-io.scm b/src/runtime/file-io.scm index d453b4ac7..8090e1246 100644 --- a/src/runtime/file-io.scm +++ b/src/runtime/file-io.scm @@ -34,19 +34,19 @@ USA. (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) @@ -109,8 +109,8 @@ USA. (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) diff --git a/src/runtime/floenv.scm b/src/runtime/floenv.scm index 1c23fa385..1a1df9cfa 100644 --- a/src/runtime/floenv.scm +++ b/src/runtime/floenv.scm @@ -64,14 +64,14 @@ USA. (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 @@ -80,12 +80,12 @@ USA. (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 @@ -99,7 +99,7 @@ USA. thread (if (or (default-object? fp-env) (eqv? #t fp-env)) - ((ucode-primitive FLOAT-ENVIRONMENT 0)) + ((ucode-primitive float-environment 0)) fp-env)))) (define (use-floating-point-environment!) @@ -108,7 +108,7 @@ USA. (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. @@ -125,7 +125,7 @@ USA. ;; 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) @@ -143,7 +143,7 @@ USA. (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) @@ -155,17 +155,17 @@ USA. (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) @@ -181,7 +181,7 @@ USA. (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)) @@ -195,7 +195,7 @@ USA. names)))) (define (flo:default-rounding-mode) - 'TO-NEAREST) + 'to-nearest) (define (flo:rounding-mode) (let ((m (get-float-rounding-mode))) @@ -205,10 +205,10 @@ USA. (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!) @@ -244,31 +244,31 @@ USA. (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))) (define (flo:default-trapped-exceptions) ;; By default, we trap the standard IEEE 754 exceptions that Scheme @@ -294,26 +294,26 @@ USA. (if (fix:zero? (fix:and bits exceptions)) tail (cons name tail))) - (guarantee index-fixnum? exceptions 'FLO:EXCEPTIONS->NAMES) + (guarantee index-fixnum? exceptions 'flo:exceptions->names) (if (not (fix:zero? (fix:andc exceptions (flo:supported-exceptions)))) - (error:bad-range-argument exceptions 'FLO:EXCEPTIONS->NAMES)) - (n 'DIVIDE-BY-ZERO (flo:exception:divide-by-zero) - (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))) ;;;; Floating-point environment utilities diff --git a/src/runtime/framex.scm b/src/runtime/framex.scm index 3c15a9e90..986abe904 100644 --- a/src/runtime/framex.scm +++ b/src/runtime/framex.scm @@ -221,14 +221,14 @@ USA. 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) @@ -238,13 +238,13 @@ USA. (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 @@ -265,39 +265,39 @@ USA. (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) diff --git a/src/runtime/gc.scm b/src/runtime/gc.scm index f3bba52e6..37fab3f8a 100644 --- a/src/runtime/gc.scm +++ b/src/runtime/gc.scm @@ -75,7 +75,7 @@ USA. (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 diff --git a/src/runtime/gcfinal.scm b/src/runtime/gcfinal.scm index 501eb147e..4c80fd4d8 100644 --- a/src/runtime/gcfinal.scm +++ b/src/runtime/gcfinal.scm @@ -49,9 +49,9 @@ USA. 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? @@ -65,28 +65,28 @@ USA. 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)))) @@ -97,10 +97,10 @@ USA. (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 @@ -117,11 +117,11 @@ USA. (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)) (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))) @@ -142,7 +142,7 @@ USA. (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))) @@ -153,7 +153,7 @@ USA. (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 '())) @@ -170,7 +170,7 @@ USA. ;; 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) diff --git a/src/runtime/gcstat.scm b/src/runtime/gcstat.scm index 56a5e95a0..0e0035cb8 100644 --- a/src/runtime/gcstat.scm +++ b/src/runtime/gcstat.scm @@ -31,10 +31,10 @@ USA. (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!) @@ -156,7 +156,7 @@ USA. (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)))) @@ -175,7 +175,7 @@ USA. (define (none:record-in-history! item) item - 'DONE) + 'done) (define (none:get-history) '()) diff --git a/src/runtime/gdbm.scm b/src/runtime/gdbm.scm index 8467df2ac..31290e6bc 100644 --- a/src/runtime/gdbm.scm +++ b/src/runtime/gdbm.scm @@ -48,11 +48,11 @@ USA. ;; 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?)) @@ -68,57 +68,57 @@ USA. (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 diff --git a/src/runtime/generic-io.scm b/src/runtime/generic-io.scm index b864c2539..21e56c92d 100644 --- a/src/runtime/generic-io.scm +++ b/src/runtime/generic-io.scm @@ -425,8 +425,8 @@ USA. (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)) @@ -602,18 +602,18 @@ USA. 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) @@ -622,10 +622,10 @@ USA. 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) @@ -811,14 +811,14 @@ USA. ;;;; 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)) @@ -829,16 +829,16 @@ USA. (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)) (define-syntax define-8-bit-codecs (sc-macro-transformer @@ -858,9 +858,9 @@ USA. (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))) @@ -868,15 +868,15 @@ USA. (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))))) @@ -922,8 +922,8 @@ USA. #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 @@ -939,8 +939,8 @@ USA. #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 @@ -956,8 +956,8 @@ USA. #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 @@ -973,8 +973,8 @@ USA. #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)) (define-8-bit-codecs iso-8859-6 #xA1 #f #f #f #x00A4 #f #f #f #f @@ -990,9 +990,9 @@ USA. #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 @@ -1008,9 +1008,9 @@ USA. #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 @@ -1026,8 +1026,8 @@ USA. #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)) (define-8-bit-codecs iso-8859-9 #xA1 #x00A1 #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7 #x00A8 @@ -1043,8 +1043,8 @@ USA. #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 @@ -1060,8 +1060,8 @@ USA. #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 @@ -1105,8 +1105,8 @@ USA. #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 @@ -1122,8 +1122,8 @@ USA. #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 @@ -1139,8 +1139,8 @@ USA. #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)) (define-8-bit-codecs windows-1250 #x80 #x20ac #f #x201a #f #x201e #x2026 #x2020 #x2021 @@ -1324,19 +1324,19 @@ USA. ;;;; 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) @@ -1358,17 +1358,17 @@ USA. (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) @@ -1380,43 +1380,43 @@ USA. (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))) ;;;; 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) @@ -1427,26 +1427,26 @@ USA. 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)))) -(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) @@ -1457,18 +1457,18 @@ USA. #\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) @@ -1477,17 +1477,17 @@ USA. (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) ;;;; Conditions @@ -1504,27 +1504,27 @@ USA. (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 diff --git a/src/runtime/global.scm b/src/runtime/global.scm index 21e871065..a9e5b09c6 100644 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@ -99,7 +99,7 @@ USA. (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) ;;;; Potpourri @@ -157,7 +157,7 @@ USA. (lambda (port) (write object port))))) (define (pa procedure) - (guarantee procedure? procedure 'PA) + (guarantee procedure? procedure 'pa) (cond ((procedure-lambda procedure) => (lambda (scode) (pp (unsyntax-lambda-list scode)))) @@ -297,14 +297,14 @@ USA. (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)))) @@ -312,8 +312,8 @@ USA. (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)))) @@ -321,14 +321,14 @@ USA. (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) @@ -357,7 +357,7 @@ USA. (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))) @@ -388,7 +388,7 @@ USA. (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))) @@ -432,7 +432,7 @@ USA. (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))) @@ -455,7 +455,7 @@ USA. (%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) @@ -472,7 +472,7 @@ USA. (set-hook-list-hooks! hook-list tail)))))) (define (remove-hook-from-list hook-list key) - (guarantee hook-list? hook-list 'REMOVE-HOOK-FROM-LIST) + (guarantee hook-list? hook-list 'remove-hook-from-list) (let loop ((alist (hook-list-hooks hook-list)) (prev #f)) (if (pair? alist) (loop (cdr alist) @@ -485,11 +485,11 @@ USA. alist))))) (define (hook-in-list? hook-list key) - (guarantee hook-list? hook-list 'HOOK-IN-LIST?) + (guarantee hook-list? hook-list 'hook-in-list?) (if (assq key (hook-list-hooks hook-list)) #t #f)) (define (run-hooks-in-list hook-list . arguments) - (guarantee hook-list? hook-list 'RUN-HOOKS-IN-LIST) + (guarantee hook-list? hook-list 'run-hooks-in-list) (for-each (lambda (p) (apply (cdr p) arguments)) (hook-list-hooks hook-list))) @@ -679,7 +679,7 @@ USA. ;;; . for ;;; . GC -(define canonical-false (list 'FALSE)) +(define canonical-false (list 'false)) (define (canonicalize object) (if (eq? object #f) @@ -692,7 +692,7 @@ USA. 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)) @@ -700,27 +700,27 @@ USA. (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 diff --git a/src/runtime/graphics.scm b/src/runtime/graphics.scm index 4eaca985c..d1f244004 100644 --- a/src/runtime/graphics.scm +++ b/src/runtime/graphics.scm @@ -53,7 +53,7 @@ USA. 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) @@ -224,11 +224,11 @@ USA. ((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) @@ -258,12 +258,12 @@ USA. (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) @@ -419,7 +419,7 @@ USA. (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:" diff --git a/src/runtime/hash-table.scm b/src/runtime/hash-table.scm index 808db3e32..b50161857 100644 --- a/src/runtime/hash-table.scm +++ b/src/runtime/hash-table.scm @@ -87,13 +87,13 @@ USA. (%make-hash-table type initial-size)) (define (%make-hash-table type #!optional initial-size) - (guarantee hash-table-type? type '%MAKE-HASH-TABLE) + (guarantee hash-table-type? type '%make-hash-table) (let ((initial-size (if (or (default-object? initial-size) (not initial-size)) #f (begin (guarantee exact-nonnegative-integer? initial-size - '%MAKE-HASH-TABLE) + '%make-hash-table) initial-size)))) (let ((table (make-table type))) (if (and initial-size (> initial-size minimum-size)) @@ -129,19 +129,19 @@ USA. (set-table-needs-rehash?! table #t)))) (define (hash-table/type table) - (guarantee hash-table? table 'HASH-TABLE/TYPE) + (guarantee hash-table? table 'hash-table/type) (table-type table)) (define (hash-table/key-hash table) - (guarantee hash-table? table 'HASH-TABLE/KEY-HASH) + (guarantee hash-table? table 'hash-table/key-hash) (table-type-key-hash (table-type table))) (define (hash-table/key=? table) - (guarantee hash-table? table 'HASH-TABLE/KEY=?) + (guarantee hash-table? table 'hash-table/key=?) (table-type-key=? (table-type table))) (define (hash-table/get table key default) - (guarantee hash-table? table 'HASH-TABLE/GET) + (guarantee hash-table? table 'hash-table/get) ((table-type-method:get (table-type table)) table key default)) (define (hash-table/lookup table key if-found if-not-found) @@ -151,11 +151,11 @@ USA. (if-found datum)))) (define (hash-table/put! table key datum) - (guarantee hash-table? table 'HASH-TABLE/PUT!) + (guarantee hash-table? table 'hash-table/put!) ((table-type-method:put! (table-type table)) table key datum)) (define (hash-table/modify! table key default procedure) - (guarantee hash-table? table 'HASH-TABLE/MODIFY!) + (guarantee hash-table? table 'hash-table/modify!) ((table-type-method:modify! (table-type table)) table key default procedure)) (define (hash-table/intern! table key generator) @@ -164,11 +164,11 @@ USA. (if (eq? datum default-marker) (generator) datum)))) (define (hash-table/remove! table key) - (guarantee hash-table? table 'HASH-TABLE/REMOVE!) + (guarantee hash-table? table 'hash-table/remove!) ((table-type-method:remove! (table-type table)) table key)) (define (hash-table/clean! table) - (guarantee hash-table? table 'HASH-TABLE/CLEAN!) + (guarantee hash-table? table 'hash-table/clean!) (without-interruption (lambda () ((table-type-method:clean! (table-type table)) table) @@ -182,19 +182,19 @@ USA. (hash-table->alist table))) (define (hash-table->alist table) - (guarantee hash-table? table 'HASH-TABLE->ALIST) + (guarantee hash-table? table 'hash-table->alist) (%hash-table-fold table (lambda (key datum alist) (cons (cons key datum) alist)) '())) (define (hash-table/key-list table) - (guarantee hash-table? table 'HASH-TABLE/KEY-LIST) + (guarantee hash-table? table 'hash-table/key-list) (%hash-table-fold table (lambda (key datum alist) datum (cons key alist)) '())) (define (hash-table/datum-list table) - (guarantee hash-table? table 'HASH-TABLE/DATUM-LIST) + (guarantee hash-table? table 'hash-table/datum-list) (%hash-table-fold table (lambda (key datum alist) key (cons datum alist)) '())) @@ -203,11 +203,11 @@ USA. ((table-type-method:fold (table-type table)) table procedure initial-value)) (define (hash-table/rehash-threshold table) - (guarantee hash-table? table 'HASH-TABLE/REHASH-THRESHOLD) + (guarantee hash-table? table 'hash-table/rehash-threshold) (table-rehash-threshold table)) (define (set-hash-table/rehash-threshold! table threshold) - (guarantee hash-table? table 'SET-HASH-TABLE/REHASH-THRESHOLD!) + (guarantee hash-table? table 'set-hash-table/rehash-threshold!) (let ((threshold (check-arg threshold default-rehash-threshold @@ -216,18 +216,18 @@ USA. (< 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 @@ -236,7 +236,7 @@ USA. ((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) @@ -244,7 +244,7 @@ USA. (maybe-shrink-table! table))))) (define (hash-table/count table) - (guarantee hash-table? table 'HASH-TABLE/COUNT) + (guarantee hash-table? table 'hash-table/count) (let loop () (let ((count (table-count table))) (if (table-needs-rehash? table) @@ -254,11 +254,11 @@ USA. count)))) (define (hash-table/size table) - (guarantee hash-table? table 'HASH-TABLE/SIZE) + (guarantee hash-table? table 'hash-table/size) (table-grow-size table)) (define (hash-table/clear! table) - (guarantee hash-table? table 'HASH-TABLE/CLEAR!) + (guarantee hash-table? table 'hash-table/clear!) (without-interruption (lambda () (if (not (table-initial-size-in-effect? table)) @@ -342,7 +342,7 @@ USA. (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))) ;;;; Entries of various flavours @@ -1140,15 +1140,15 @@ USA. (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)) @@ -1255,8 +1255,8 @@ USA. (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) @@ -1308,7 +1308,7 @@ USA. hash-table-entry-type:strong)) (define (alist->hash-table alist #!optional key=? key-hash) - (guarantee alist? alist 'ALIST->HASH-TABLE) + (guarantee alist? alist 'alist->hash-table) (let ((table (make-hash-table key=? key-hash))) (for-each (lambda (p) (hash-table/put! table (car p) (cdr p))) @@ -1338,7 +1338,7 @@ USA. (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))) @@ -1351,14 +1351,14 @@ USA. 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)) @@ -1371,8 +1371,8 @@ USA. table*)))) (define (hash-table-merge! table1 table2) - (guarantee hash-table? table1 'HASH-TABLE-MERGE!) - (guarantee hash-table? table2 'HASH-TABLE-MERGE!) + (guarantee hash-table? table1 'hash-table-merge!) + (guarantee hash-table? table2 'hash-table-merge!) (if (not (eq? table2 table1)) (%hash-table-fold table2 (lambda (key datum ignore) @@ -1396,7 +1396,7 @@ USA. (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) diff --git a/src/runtime/hash.scm b/src/runtime/hash.scm index 21a078dc9..77969b6b5 100644 --- a/src/runtime/hash.scm +++ b/src/runtime/hash.scm @@ -90,7 +90,7 @@ USA. 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) @@ -111,7 +111,7 @@ USA. (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) @@ -137,7 +137,7 @@ USA. (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 () diff --git a/src/runtime/histry.scm b/src/runtime/histry.scm index 5daab32c5..933b5fc23 100644 --- a/src/runtime/histry.scm +++ b/src/runtime/histry.scm @@ -188,7 +188,7 @@ USA. (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) @@ -229,6 +229,6 @@ USA. (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 diff --git a/src/runtime/http-client.scm b/src/runtime/http-client.scm index 242d5c621..28d53b18f 100644 --- a/src/runtime/http-client.scm +++ b/src/runtime/http-client.scm @@ -108,38 +108,38 @@ USA. (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 diff --git a/src/runtime/http-io.scm b/src/runtime/http-io.scm index 5304dc98d..c4595fa5a 100644 --- a/src/runtime/http-io.scm +++ b/src/runtime/http-io.scm @@ -42,15 +42,15 @@ USA. (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)))))) @@ -65,15 +65,15 @@ USA. (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))))) @@ -89,7 +89,7 @@ USA. (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)))) @@ -102,7 +102,7 @@ USA. (define-guarantee simple-http-request "simple HTTP request") (define (make-simple-http-request uri) - (guarantee simple-http-request-uri? uri 'MAKE-HTTP-REQUEST) + (guarantee simple-http-request-uri? uri 'make-http-request) (%make-http-request '|GET| uri #f '() "")) (define (simple-http-response? object) @@ -124,12 +124,12 @@ USA. (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) @@ -150,12 +150,12 @@ USA. ;;;; 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) @@ -253,11 +253,11 @@ USA. (car b.t)))))))) (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 () @@ -305,11 +305,11 @@ USA. (%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) @@ -368,7 +368,7 @@ USA. ;;;; Status descriptions (define (http-status-description code) - (guarantee http-status? code 'HTTP-STATUS-DESCRIPTION) + (guarantee http-status? code 'http-status-description) (let loop ((low 0) (high (vector-length known-status-codes))) (if (< low high) (let ((index (quotient (+ low high) 2))) @@ -445,38 +445,38 @@ USA. (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))) diff --git a/src/runtime/http-syntax.scm b/src/runtime/http-syntax.scm index f914a8a79..14154b1c2 100644 --- a/src/runtime/http-syntax.scm +++ b/src/runtime/http-syntax.scm @@ -148,7 +148,7 @@ USA. (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) @@ -518,7 +518,7 @@ USA. (define (qparam? object) (and (parameter? object) - (eq? (car object) 'Q))) + (eq? (car object) 'q))) (define lp:token+qparam (list-parser diff --git a/src/runtime/ieee754.scm b/src/runtime/ieee754.scm index a2a51b2ff..debcb48d2 100644 --- a/src/runtime/ieee754.scm +++ b/src/runtime/ieee754.scm @@ -114,9 +114,9 @@ USA. (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 diff --git a/src/runtime/infstr.scm b/src/runtime/infstr.scm index 1c6b459cf..dfd51d497 100644 --- a/src/runtime/infstr.scm +++ b/src/runtime/infstr.scm @@ -55,7 +55,7 @@ USA. (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))) @@ -70,7 +70,7 @@ USA. (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) @@ -82,7 +82,7 @@ USA. (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)) @@ -205,8 +205,8 @@ USA. ((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)) @@ -286,7 +286,7 @@ USA. (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) @@ -314,7 +314,7 @@ USA. (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) @@ -340,7 +340,7 @@ USA. (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) @@ -348,7 +348,7 @@ USA. (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) diff --git a/src/runtime/infutl.scm b/src/runtime/infutl.scm index 1805be592..8a684db80 100644 --- a/src/runtime/infutl.scm +++ b/src/runtime/infutl.scm @@ -250,7 +250,7 @@ USA. (merge-pathnames (pathname-new-directory (file-pathname pathname) - (cons 'RELATIVE + (cons 'relative (list-tail (pathname-directory pathname) (length (pathname-directory (car rule)))))) (cdr rule)) @@ -281,7 +281,7 @@ USA. (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)))) diff --git a/src/runtime/input-port.scm b/src/runtime/input-port.scm index 5f08a2ff7..23ae90266 100644 --- a/src/runtime/input-port.scm +++ b/src/runtime/input-port.scm @@ -52,7 +52,7 @@ USA. 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))) @@ -69,7 +69,7 @@ USA. (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))) @@ -87,7 +87,7 @@ USA. (loop))))))))) (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 () @@ -110,24 +110,24 @@ USA. (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)))) ;;;; 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))) @@ -138,23 +138,23 @@ USA. (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) @@ -166,7 +166,7 @@ USA. (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) @@ -181,11 +181,11 @@ USA. (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))) @@ -194,7 +194,7 @@ USA. (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!)) diff --git a/src/runtime/integer-bits.scm b/src/runtime/integer-bits.scm index 5281391da..d2ba787ad 100644 --- a/src/runtime/integer-bits.scm +++ b/src/runtime/integer-bits.scm @@ -173,7 +173,7 @@ USA. (bits '() (cons (odd? integer) bits))) ((zero? integer) bits)) (begin - (guarantee index-fixnum? length 'INTEGER->LIST) + (guarantee index-fixnum? length 'integer->list) (do ((length length (- length 1)) (integer integer (shift-right integer 1)) (bits '() (cons (odd? integer) bits))) diff --git a/src/runtime/interrupt.scm b/src/runtime/interrupt.scm index 185978977..dfca0db5e 100644 --- a/src/runtime/interrupt.scm +++ b/src/runtime/interrupt.scm @@ -31,28 +31,28 @@ USA. (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)) @@ -151,10 +151,10 @@ USA. (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 @@ -165,26 +165,26 @@ USA. (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)) @@ -264,7 +264,7 @@ USA. 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) diff --git a/src/runtime/keyword.scm b/src/runtime/keyword.scm index 865463d0a..ebb64120a 100644 --- a/src/runtime/keyword.scm +++ b/src/runtime/keyword.scm @@ -38,7 +38,7 @@ USA. (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) @@ -51,5 +51,5 @@ USA. (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 diff --git a/src/runtime/lambda-list.scm b/src/runtime/lambda-list.scm index 9c1dd84ed..d74c53f60 100644 --- a/src/runtime/lambda-list.scm +++ b/src/runtime/lambda-list.scm @@ -183,7 +183,7 @@ USA. (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))) diff --git a/src/runtime/lambda.scm b/src/runtime/lambda.scm index 0d6ab36e4..d5a9ae790 100644 --- a/src/runtime/lambda.scm +++ b/src/runtime/lambda.scm @@ -195,7 +195,7 @@ USA. (eq? (vector-ref text 0) wrapper-tag))))) (define wrapper-tag - '(LAMBDA-WRAPPER)) + '(lambda-wrapper)) (define-integrable (wrapper-body wrapper) (scode-comment-expression wrapper)) -- 2.25.1