From: Chris Hanson Date: Sun, 22 Apr 2018 04:58:12 +0000 (-0700) Subject: Downcase remaining symbols in the runtime system. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~121 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e2d2043eb158132db77c43700f469e11a7a7dbb8;p=mit-scheme.git Downcase remaining symbols in the runtime system. Only remaining such symbols are those that have explicit case. --- diff --git a/src/runtime/textual-port.scm b/src/runtime/textual-port.scm index 80589a171..6d1c8f72b 100644 --- a/src/runtime/textual-port.scm +++ b/src/runtime/textual-port.scm @@ -65,11 +65,11 @@ USA. (lambda (type) (if (port-type-supports-input? type) (if (port-type-supports-output? type) - 'TEXTUAL-I/O-PORT-TYPE - 'TEXTUAL-INPUT-PORT-TYPE) + 'textual-i/o-port-type + 'textual-input-port-type) (if (port-type-supports-output? type) - 'TEXTUAL-OUTPUT-PORT-TYPE - 'TEXTUAL-PORT-TYPE))) + 'textual-output-port-type + 'textual-port-type))) #f)) (define (port-type-supports-input? type) @@ -159,10 +159,10 @@ USA. (append operations (remove (let ((excluded (append - (if (assq 'READ-CHAR operations) + (if (assq 'read-char operations) standard-input-operation-names '()) - (if (assq 'WRITE-CHAR operations) + (if (assq 'write-char operations) standard-output-operation-names '())))) (lambda (p) @@ -182,17 +182,17 @@ USA. (values (reverse! standard) (reverse! custom))))) (define standard-input-operation-names - '(CHAR-READY? - PEEK-CHAR - READ-CHAR - READ-SUBSTRING - UNREAD-CHAR)) + '(char-ready? + peek-char + read-char + read-substring + unread-char)) (define standard-output-operation-names - '(WRITE-CHAR - WRITE-SUBSTRING - FLUSH-OUTPUT - DISCRETIONARY-FLUSH-OUTPUT)) + '(write-char + write-substring + flush-output + discretionary-flush-output)) ;;;; Default I/O operations @@ -201,22 +201,22 @@ USA. (error "Missing required operation:" name))) (define (provide-default-input-operations op) - (required-operation op 'READ-CHAR) - (if (and (or (op 'UNREAD-CHAR) - (op 'PEEK-CHAR)) - (not (and (op 'UNREAD-CHAR) - (op 'PEEK-CHAR)))) + (required-operation op 'read-char) + (if (and (or (op 'unread-char) + (op 'peek-char)) + (not (and (op 'unread-char) + (op 'peek-char)))) (error "Must provide both UNREAD-CHAR and PEEK-CHAR operations.")) (let ((char-ready? - (or (op 'CHAR-READY?) + (or (op 'char-ready?) (lambda (port) port #t))) (read-substring - (or (op 'READ-SUBSTRING) + (or (op 'read-substring) generic-port-operation:read-substring))) (lambda (name) (case name - ((CHAR-READY?) char-ready?) - ((READ-SUBSTRING) read-substring) + ((char-ready?) char-ready?) + ((read-substring) read-substring) (else (op name)))))) (define (generic-port-operation:read-substring port string start end) @@ -239,21 +239,21 @@ USA. (- index start)))))))) (define (provide-default-output-operations op) - (required-operation op 'WRITE-CHAR) + (required-operation op 'write-char) (let ((write-substring - (or (op 'WRITE-SUBSTRING) + (or (op 'write-substring) generic-port-operation:write-substring)) (flush-output - (or (op 'FLUSH-OUTPUT) + (or (op 'flush-output) no-flush)) (discretionary-flush-output - (or (op 'DISCRETIONARY-FLUSH-OUTPUT) + (or (op 'discretionary-flush-output) no-flush))) (lambda (name) (case name - ((WRITE-SUBSTRING) write-substring) - ((FLUSH-OUTPUT) flush-output) - ((DISCRETIONARY-FLUSH-OUTPUT) discretionary-flush-output) + ((write-substring) write-substring) + ((flush-output) flush-output) + ((discretionary-flush-output) discretionary-flush-output) (else (op name)))))) (define (no-flush port) @@ -274,20 +274,20 @@ USA. (define (provide-input-features op) (let ((read-char - (let ((defer (op 'READ-CHAR))) + (let ((defer (op 'read-char))) (lambda (port) (let ((char (defer port))) (transcribe-input-char char port) (set-textual-port-unread?! port #f) char)))) (unread-char - (let ((defer (op 'UNREAD-CHAR))) + (let ((defer (op 'unread-char))) (and defer (lambda (port char) (defer port char) (set-textual-port-unread?! port #t))))) (peek-char - (let ((defer (op 'PEEK-CHAR))) + (let ((defer (op 'peek-char))) (and defer (lambda (port) (let ((char (defer port))) @@ -295,7 +295,7 @@ USA. (set-textual-port-unread?! port #t) char))))) (read-substring - (let ((defer (op 'READ-SUBSTRING))) + (let ((defer (op 'read-substring))) (lambda (port string start end) (let ((n (defer port string start end))) (transcribe-input-substring string start n port) @@ -303,10 +303,10 @@ USA. n))))) (lambda (name) (case name - ((READ-CHAR) read-char) - ((UNREAD-CHAR) unread-char) - ((PEEK-CHAR) peek-char) - ((READ-SUBSTRING) read-substring) + ((read-char) read-char) + ((unread-char) unread-char) + ((peek-char) peek-char) + ((read-substring) read-substring) (else (op name)))))) (define (transcribe-input-char char port) @@ -325,7 +325,7 @@ USA. (define (provide-output-features op) (let ((write-char - (let ((defer (op 'WRITE-CHAR))) + (let ((defer (op 'write-char))) (lambda (port char) (let ((n (defer port char))) (if (and n (fix:> n 0)) @@ -334,7 +334,7 @@ USA. (transcribe-char char port))) n)))) (write-substring - (let ((defer (op 'WRITE-SUBSTRING))) + (let ((defer (op 'write-substring))) (lambda (port string start end) (let ((n (defer port string start end))) (if (and n (> n 0)) @@ -344,12 +344,12 @@ USA. (transcribe-substring string start end port))) n)))) (flush-output - (let ((defer (op 'FLUSH-OUTPUT))) + (let ((defer (op 'flush-output))) (lambda (port) (defer port) (flush-transcript port)))) (discretionary-flush-output - (let ((defer (op 'DISCRETIONARY-FLUSH-OUTPUT))) + (let ((defer (op 'discretionary-flush-output))) (lambda (port) (defer port) (discretionary-flush-transcript port)))) @@ -357,7 +357,7 @@ USA. (lambda (port) (if (textual-port-previous port) (char=? (textual-port-previous port) #\newline) - 'UNKNOWN)))) + 'unknown)))) (let ((fresh-line (lambda (port) (if (and (textual-port-previous port) @@ -366,12 +366,12 @@ USA. 0)))) (lambda (name) (case name - ((WRITE-CHAR) write-char) - ((WRITE-SUBSTRING) write-substring) - ((FRESH-LINE) fresh-line) - ((LINE-START?) line-start?) - ((FLUSH-OUTPUT) flush-output) - ((DISCRETIONARY-FLUSH-OUTPUT) discretionary-flush-output) + ((write-char) write-char) + ((write-substring) write-substring) + ((fresh-line) fresh-line) + ((line-start?) line-start?) + ((flush-output) flush-output) + ((discretionary-flush-output) discretionary-flush-output) (else (op name))))))) ;;;; Textual ports @@ -419,17 +419,17 @@ USA. (define-unparser-method textual-port? (standard-unparser-method (lambda (port) - (cond ((textual-i/o-port? port) 'TEXTUAL-I/O-PORT) - ((textual-input-port? port) 'TEXTUAL-INPUT-PORT) - ((textual-output-port? port) 'TEXTUAL-OUTPUT-PORT) - (else 'TEXTUAL-PORT))) + (cond ((textual-i/o-port? port) 'textual-i/o-port) + ((textual-input-port? port) 'textual-input-port) + ((textual-output-port? port) 'textual-output-port) + (else 'textual-port))) (lambda (port output-port) - (cond ((textual-port-operation port 'WRITE-SELF) + (cond ((textual-port-operation port 'write-self) => (lambda (operation) (operation port output-port))))))) (define (close-textual-port port) - (let ((close (textual-port-operation port 'CLOSE))) + (let ((close (textual-port-operation port 'close))) (if close (close port) (begin @@ -437,17 +437,17 @@ USA. (close-textual-input-port port))))) (define (close-textual-input-port port) - (let ((close-input (textual-port-operation port 'CLOSE-INPUT))) + (let ((close-input (textual-port-operation port 'close-input))) (if close-input (close-input port)))) (define (close-textual-output-port port) - (let ((close-output (textual-port-operation port 'CLOSE-OUTPUT))) + (let ((close-output (textual-port-operation port 'close-output))) (if close-output (close-output port)))) (define (textual-port-open? port) - (let ((open? (textual-port-operation port 'OPEN?))) + (let ((open? (textual-port-operation port 'open?))) (if open? (open? port) (and (if (textual-input-port? port) @@ -458,13 +458,13 @@ USA. #t))))) (define (textual-input-port-open? port) - (let ((open? (textual-port-operation port 'INPUT-OPEN?))) + (let ((open? (textual-port-operation port 'input-open?))) (if open? (open? port) #t))) (define (textual-output-port-open? port) - (let ((open? (textual-port-operation port 'OUTPUT-OPEN?))) + (let ((open? (textual-port-operation port 'output-open?))) (if open? (open? port) #t))) @@ -489,9 +489,9 @@ USA. (sc-macro-transformer (lambda (form environment) (let ((name (cadr form))) - `(DEFINE (,(symbol 'TEXTUAL-PORT-OPERATION/ name) PORT) - (,(close-syntax (symbol 'PORT-TYPE-OPERATION: name) environment) - (TEXTUAL-PORT-TYPE PORT))))))) + `(define (,(symbol 'textual-port-operation/ name) port) + (,(close-syntax (symbol 'port-type-operation: name) environment) + (textual-port-type port))))))) (define-port-operation char-ready?) (define-port-operation read-char) @@ -545,55 +545,55 @@ USA. (output-port/discretionary-flush tport)))) (define (textual-port-char-set port) - (let ((operation (textual-port-operation port 'CHAR-SET))) + (let ((operation (textual-port-operation port 'char-set))) (if operation (operation port) char-set:iso-8859-1))) (define (port/supports-coding? port) - (let ((operation (textual-port-operation port 'SUPPORTS-CODING?))) + (let ((operation (textual-port-operation port 'supports-coding?))) (if operation (operation port) #f))) (define (port/coding port) - ((or (textual-port-operation port 'CODING) - (error:bad-range-argument port 'PORT/CODING)) + ((or (textual-port-operation port 'coding) + (error:bad-range-argument port 'port/coding)) port)) (define (port/set-coding port name) - ((or (textual-port-operation port 'SET-CODING) - (error:bad-range-argument port 'PORT/SET-CODING)) + ((or (textual-port-operation port 'set-coding) + (error:bad-range-argument port 'port/set-coding)) port name)) (define (port/known-coding? port name) - ((or (textual-port-operation port 'KNOWN-CODING?) - (error:bad-range-argument port 'PORT/KNOWN-CODING?)) + ((or (textual-port-operation port 'known-coding?) + (error:bad-range-argument port 'port/known-coding?)) port name)) (define (port/known-codings port) - ((or (textual-port-operation port 'KNOWN-CODINGS) - (error:bad-range-argument port 'PORT/KNOWN-CODINGS)) + ((or (textual-port-operation port 'known-codings) + (error:bad-range-argument port 'port/known-codings)) port)) (define (port/line-ending port) - ((or (textual-port-operation port 'LINE-ENDING) - (error:bad-range-argument port 'PORT/LINE-ENDING)) + ((or (textual-port-operation port 'line-ending) + (error:bad-range-argument port 'port/line-ending)) port)) (define (port/set-line-ending port name) - ((or (textual-port-operation port 'SET-LINE-ENDING) - (error:bad-range-argument port 'PORT/SET-LINE-ENDING)) + ((or (textual-port-operation port 'set-line-ending) + (error:bad-range-argument port 'port/set-line-ending)) port name)) (define (port/known-line-ending? port name) - ((or (textual-port-operation port 'KNOWN-LINE-ENDING?) - (error:bad-range-argument port 'PORT/KNOWN-LINE-ENDING?)) + ((or (textual-port-operation port 'known-line-ending?) + (error:bad-range-argument port 'port/known-line-ending?)) port name)) (define (port/known-line-endings port) - ((or (textual-port-operation port 'KNOWN-LINE-ENDINGS) - (error:bad-range-argument port 'PORT/KNOWN-LINE-ENDINGS)) + ((or (textual-port-operation port 'known-line-endings) + (error:bad-range-argument port 'port/known-line-endings)) port)) ;;;; Generic ports diff --git a/src/runtime/thread-barrier.scm b/src/runtime/thread-barrier.scm index be418072a..852212c6a 100644 --- a/src/runtime/thread-barrier.scm +++ b/src/runtime/thread-barrier.scm @@ -39,7 +39,7 @@ USA. (generation 0)) (define (make-thread-barrier count #!optional name) - (guarantee exact-positive-integer? count 'MAKE-THREAD-BARRIER) + (guarantee exact-positive-integer? count 'make-thread-barrier) (let ((current count) (condvar (make-condition-variable @@ -47,7 +47,7 @@ USA. (%make-thread-barrier count current condvar))) (define (thread-barrier-wait barrier) - (guarantee thread-barrier? barrier 'THREAD-BARRIER-WAIT) + (guarantee thread-barrier? barrier 'thread-barrier-wait) (let ((lock (thread-barrier.lock barrier)) (condvar (thread-barrier.condvar barrier))) (with-thread-mutex-lock lock diff --git a/src/runtime/thread-queue.scm b/src/runtime/thread-queue.scm index b5b5fd560..03e6f1130 100644 --- a/src/runtime/thread-queue.scm +++ b/src/runtime/thread-queue.scm @@ -61,14 +61,14 @@ USA. (define-syntax %assert (syntax-rules () - ((_ CONDITION) + ((_ condition) #f))) #;(define-syntax %assert (syntax-rules () - ((_ CONDITION) - (if (not CONDITION) - (error "Assertion failed:" 'CONDITION))))) + ((_ condition) + (if (not condition) + (error "Assertion failed:" 'condition))))) (define-integrable (%locked? queue) (thread-mutex-owner (%thread-queue/mutex queue))) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 89d3557bf..3f6f82672 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -51,7 +51,7 @@ USA. (block-events? #f) ;; If #t, events may not run in this thread and should be queued. - ;; If 'SUSPENDED, events were blocked when the thread suspended. + ;; If 'suspended, events were blocked when the thread suspended. ;; Events should wake the thread and %resume-current-thread should ;; run them but then it should continue with events blocked (#t). @@ -821,10 +821,10 @@ USA. (search descriptor (case mode - ((READ) (lambda (mode) (memq mode '(read read/write)))) - ((WRITE) (lambda (mode) (memq mode '(write read/write)))) - ((READ/WRITE) (lambda (mode) mode)) - ((ERROR HANGUP) (lambda (mode) mode #t)) + ((read) (lambda (mode) (memq mode '(read read/write)))) + ((write) (lambda (mode) (memq mode '(write read/write)))) + ((read/write) (lambda (mode) mode)) + ((error hangup) (lambda (mode) mode #t)) (else (error "Illegal mode:" mode)))))) (if (not dentry) (loop (fix:+ i 1) events) diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm index 42da226e6..472d8fe80 100644 --- a/src/runtime/unpars.scm +++ b/src/runtime/unpars.scm @@ -294,36 +294,36 @@ USA. (vector-set! dispatch-table (microcode-type (car entry)) (cadr entry))) - `((ASSIGNMENT ,unparse/assignment) - (BIGNUM ,unparse/number) - (BYTEVECTOR ,unparse/bytevector) - (CHARACTER ,unparse/character) - (COMPILED-ENTRY ,unparse/compiled-entry) - (COMPLEX ,unparse/number) - (CONSTANT ,unparse/constant) - (DEFINITION ,unparse/definition) - (ENTITY ,unparse/entity) - (EXTENDED-PROCEDURE ,unparse/compound-procedure) - (FLONUM ,unparse/flonum) - (INTERNED-SYMBOL ,unparse/interned-symbol) - (LAMBDA ,unparse/lambda) - (LIST ,unparse/pair) - (NEGATIVE-FIXNUM ,unparse/number) - (FALSE ,unparse/false) - (POSITIVE-FIXNUM ,unparse/number) - (PRIMITIVE ,unparse/primitive-procedure) - (PROCEDURE ,unparse/compound-procedure) - (PROMISE ,unparse/promise) - (RATNUM ,unparse/number) - (RECORD ,unparse/record) - (RETURN-ADDRESS ,unparse/return-address) - (STRING ,unparse/string) - (TAGGED-OBJECT ,unparse/tagged-object) - (UNICODE-STRING ,unparse/string) - (UNINTERNED-SYMBOL ,unparse/uninterned-symbol) - (VARIABLE ,unparse/variable) - (VECTOR ,unparse/vector) - (VECTOR-1B ,unparse/bit-string))))) + `((assignment ,unparse/assignment) + (bignum ,unparse/number) + (bytevector ,unparse/bytevector) + (character ,unparse/character) + (compiled-entry ,unparse/compiled-entry) + (complex ,unparse/number) + (constant ,unparse/constant) + (definition ,unparse/definition) + (entity ,unparse/entity) + (extended-procedure ,unparse/compound-procedure) + (flonum ,unparse/flonum) + (interned-symbol ,unparse/interned-symbol) + (lambda ,unparse/lambda) + (list ,unparse/pair) + (negative-fixnum ,unparse/number) + (false ,unparse/false) + (positive-fixnum ,unparse/number) + (primitive ,unparse/primitive-procedure) + (procedure ,unparse/compound-procedure) + (promise ,unparse/promise) + (ratnum ,unparse/number) + (record ,unparse/record) + (return-address ,unparse/return-address) + (string ,unparse/string) + (tagged-object ,unparse/tagged-object) + (unicode-string ,unparse/string) + (uninterned-symbol ,unparse/uninterned-symbol) + (variable ,unparse/variable) + (vector ,unparse/vector) + (vector-1b ,unparse/bit-string))))) ;;;; Low Level Operations @@ -380,9 +380,9 @@ USA. (define (unparse/default object context) (let ((type (user-object-type object))) (case (object-gc-type object) - ((CELL PAIR TRIPLE QUADRUPLE VECTOR COMPILED-ENTRY) + ((cell pair triple quadruple vector compiled-entry) (*unparse-with-brackets type object context #f)) - ((NON-POINTER) + ((non-pointer) (*unparse-with-brackets type object context (lambda (context*) (*unparse-datum object context*)))) @@ -406,17 +406,17 @@ USA. type-name))) (define renamed-user-object-types - '((NEGATIVE-FIXNUM . NUMBER) - (POSITIVE-FIXNUM . NUMBER) - (BIGNUM . NUMBER) - (FLONUM . NUMBER) - (COMPLEX . NUMBER) - (INTERNED-SYMBOL . SYMBOL) - (UNINTERNED-SYMBOL . SYMBOL) - (EXTENDED-PROCEDURE . PROCEDURE) - (PRIMITIVE . PRIMITIVE-PROCEDURE) - (LEXPR . LAMBDA) - (EXTENDED-LAMBDA . LAMBDA))) + '((negative-fixnum . number) + (positive-fixnum . number) + (bignum . number) + (flonum . number) + (complex . number) + (interned-symbol . symbol) + (uninterned-symbol . symbol) + (extended-procedure . procedure) + (primitive . primitive-procedure) + (lexpr . lambda) + (extended-lambda . lambda))) (define (unparse/false object context) (if (eq? object #f) @@ -445,7 +445,7 @@ USA. (define (unparse/uninterned-symbol symbol context) (if (get-param:unparse-uninterned-symbols-by-name?) (unparse-symbol-name (symbol->string symbol) context) - (*unparse-with-brackets 'UNINTERNED-SYMBOL symbol context + (*unparse-with-brackets 'uninterned-symbol symbol context (lambda (context*) (*unparse-string (symbol->string symbol) context*))))) @@ -456,10 +456,10 @@ USA. (define (unparse-keyword-name s context) (case (param:parser-keyword-style) - ((PREFIX) + ((prefix) (*unparse-char #\: context) (unparse-symbol-name s context)) - ((SUFFIX) + ((suffix) (unparse-symbol-name s context) (*unparse-char #\: context)) (else @@ -474,8 +474,8 @@ USA. (char-in-set? (string-ref s 0) char-set:symbol-initial) (string-every (symbol-name-no-quoting-predicate context) s) (not (case (param:parser-keyword-style) - ((PREFIX) (string-prefix? ":" s)) - ((SUFFIX) (string-suffix? ":" s)) + ((prefix) (string-prefix? ":" s)) + ((suffix) (string-suffix? ":" s)) (else #f))) (not (string->number s))) (*unparse-string s context) @@ -682,10 +682,10 @@ USA. (pair? (safe-cdr object)) (null? (safe-cdr (safe-cdr object))) (case (safe-car object) - ((QUOTE) "'") - ((QUASIQUOTE) "`") - ((UNQUOTE) ",") - ((UNQUOTE-SPLICING) ",@") + ((quote) "'") + ((quasiquote) "`") + ((unquote) ",") + ((unquote-splicing) ",@") (else #f)))) (define (unparse-list/stream-pair stream-pair context) @@ -726,7 +726,7 @@ USA. ;;;; Procedures (define (unparse/compound-procedure procedure context) - (*unparse-with-brackets 'COMPOUND-PROCEDURE procedure context + (*unparse-with-brackets 'compound-procedure procedure context (and (get-param:unparse-compound-procedure-names?) (lambda-components* (procedure-lambda procedure) (lambda (name required optional rest body) @@ -744,17 +744,17 @@ USA. ((get-param:unparse-with-maximum-readability?) (*unparse-readable-hash procedure context)) (else - (*unparse-with-brackets 'PRIMITIVE-PROCEDURE #f context + (*unparse-with-brackets 'primitive-procedure #f context unparse-name))))) (define (unparse/compiled-entry entry context) (let* ((type (compiled-entry-type entry)) - (procedure? (eq? type 'COMPILED-PROCEDURE)) + (procedure? (eq? type 'compiled-procedure)) (closure? (and procedure? (compiled-code-block/manifest-closure? (compiled-code-address->block entry))))) - (*unparse-with-brackets (if closure? 'COMPILED-CLOSURE type) + (*unparse-with-brackets (if closure? 'compiled-closure type) entry context (lambda (context*) @@ -787,27 +787,27 @@ USA. ;;;; Miscellaneous (define (unparse/return-address return-address context) - (*unparse-with-brackets 'RETURN-ADDRESS return-address context + (*unparse-with-brackets 'return-address return-address context (lambda (context*) (*unparse-object (return-address/name return-address) context*)))) (define (unparse/assignment assignment context) - (*unparse-with-brackets 'ASSIGNMENT assignment context + (*unparse-with-brackets 'assignment assignment context (lambda (context*) (*unparse-object (scode-assignment-name assignment) context*)))) (define (unparse/definition definition context) - (*unparse-with-brackets 'DEFINITION definition context + (*unparse-with-brackets 'definition definition context (lambda (context*) (*unparse-object (scode-definition-name definition) context*)))) (define (unparse/lambda lambda-object context) - (*unparse-with-brackets 'LAMBDA lambda-object context + (*unparse-with-brackets 'lambda lambda-object context (lambda (context*) (*unparse-object (scode-lambda-name lambda-object) context*)))) (define (unparse/variable variable context) - (*unparse-with-brackets 'VARIABLE variable context + (*unparse-with-brackets 'variable variable context (lambda (context*) (*unparse-object (scode-variable-name variable) context*)))) @@ -861,27 +861,27 @@ USA. (*unparse-with-brackets name entity context #f)) (define (named-arity-dispatched-procedure name) - (*unparse-with-brackets 'ARITY-DISPATCHED-PROCEDURE entity context + (*unparse-with-brackets 'arity-dispatched-procedure entity context (lambda (context*) (*unparse-string name context*)))) (cond ((continuation? entity) - (plain 'CONTINUATION)) + (plain 'continuation)) ((apply-hook? entity) - (plain 'APPLY-HOOK)) + (plain 'apply-hook)) ((arity-dispatched-procedure? entity) (let ((proc (%entity-procedure entity))) (cond ((and (compiled-code-address? proc) (compiled-procedure? proc) (compiled-procedure/name proc)) => named-arity-dispatched-procedure) - (else (plain 'ARITY-DISPATCHED-PROCEDURE))))) + (else (plain 'arity-dispatched-procedure))))) ((get-param:unparse-with-maximum-readability?) (*unparse-readable-hash entity context)) - (else (plain 'ENTITY)))) + (else (plain 'entity)))) (define (unparse/promise promise context) - (*unparse-with-brackets 'PROMISE promise context + (*unparse-with-brackets 'promise promise context (if (promise-forced? promise) (lambda (context*) (*unparse-string "(evaluated) " context*) diff --git a/src/runtime/unsyn.scm b/src/runtime/unsyn.scm index 4a60e7dd8..00fa6b2a8 100644 --- a/src/runtime/unsyn.scm +++ b/src/runtime/unsyn.scm @@ -44,7 +44,7 @@ USA. (define (unsyntax-with-substitutions scode alist) (if (not (alist? alist)) - (error:wrong-type-argument alist "alist" 'UNSYNTAX-WITH-SUBSTITUTIONS)) + (error:wrong-type-argument alist "alist" 'unsyntax-with-substitutions)) (parameterize* (list (cons substitutions alist)) (lambda () (unsyntax scode)))) @@ -113,24 +113,24 @@ USA. (symbol? object) (vector? object)) ;; R4RS quoted data (in addition to above) - `(QUOTE ,object)) + `(quote ,object)) ((compiled-expression? object) (let ((scode (compiled-expression/scode object))) (if (eq? scode object) - `(SCODE-QUOTE ,object) + `(scode-quote ,object) (unsyntax-object environment scode)))) (else object))) -(define (unsyntax-QUOTATION environment quotation) - `(SCODE-QUOTE +(define (unsyntax-quotation environment quotation) + `(scode-quote ,(unsyntax-object environment (scode-quotation-expression quotation)))) (define (unsyntax-variable-object environment object) (declare (ignore environment)) (scode-variable-name object)) -(define (unsyntax-ACCESS-object environment object) +(define (unsyntax-access-object environment object) (or (and (unsyntaxer:elide-global-accesses?) (unsyntaxer:macroize?) (let ((access-environment (scode-access-environment object)) @@ -141,7 +141,7 @@ USA. 'system-global-environment))) (not (is-bound? name environment)) name))) - `(ACCESS ,@(unexpand-access environment object)))) + `(access ,@(unexpand-access environment object)))) (define (unexpand-access environment object) (let loop ((object object) (separate? #t)) @@ -210,7 +210,7 @@ USA. (else #f))))))) (define (unsyntax-assignment-object environment assignment) - `(SET! ,(scode-assignment-name assignment) + `(set! ,(scode-assignment-name assignment) ,@(unexpand-binding-value environment (scode-assignment-value assignment)))) @@ -219,15 +219,15 @@ USA. '() `(,(unsyntax-object environment value)))) -(define (unsyntax-COMMENT-object environment comment) +(define (unsyntax-comment-object environment comment) (let ((expression (unsyntax-object environment (scode-comment-expression comment)))) (if (unsyntaxer:show-comments?) - `(COMMENT ,(scode-comment-text comment) ,expression) + `(comment ,(scode-comment-text comment) ,expression) expression))) -(define (unsyntax-DECLARATION-object environment declaration) - `(LOCAL-DECLARE +(define (unsyntax-declaration-object environment declaration) + `(local-declare ,(scode-declaration-text declaration) ,(unsyntax-object environment (scode-declaration-expression declaration)))) @@ -235,10 +235,10 @@ USA. (let ((actions (scode-sequence-actions seq))) (if (and (scode-block-declaration? (car actions)) (pair? (cdr actions))) - `(BEGIN - (DECLARE ,@(scode-block-declaration-text (car actions))) + `(begin + (declare ,@(scode-block-declaration-text (car actions))) ,@(unsyntax-sequence-actions environment (cdr actions))) - `(BEGIN + `(begin ,@(unsyntax-sequence-actions environment actions))))) (define (unsyntax-sequence-for-splicing environment seq) @@ -248,7 +248,7 @@ USA. (scode-sequence-actions seq)))) (if (eq? #t (unsyntaxer:macroize?)) actions - `((BEGIN ,@actions)))) + `((begin ,@actions)))) (list (unsyntax-object environment seq)))) (define (unsyntax-sequence-actions environment actions) @@ -265,14 +265,14 @@ USA. (unscan-defines (scode-open-block-names open-block) (scode-open-block-declarations open-block) (scode-open-block-actions open-block))) - (unsyntax-SEQUENCE-object environment open-block))) + (unsyntax-sequence-object environment open-block))) -(define (unsyntax-DELAY-object environment object) - `(DELAY ,(unsyntax-object environment (scode-delay-expression object)))) +(define (unsyntax-delay-object environment object) + `(delay ,(unsyntax-object environment (scode-delay-expression object)))) -(define (unsyntax-THE-ENVIRONMENT-object environment object) +(define (unsyntax-the-environment-object environment object) (declare (ignore environment object)) - `(THE-ENVIRONMENT)) + `(the-environment)) (define (unsyntax-disjunction-object environment object) `(or ,@(let ((predicate (scode-disjunction-predicate object)) @@ -301,22 +301,22 @@ USA. (define (unsyntax-conditional/default environment predicate consequent alternative) - `(IF ,(unsyntax-object environment predicate) + `(if ,(unsyntax-object environment predicate) ,(unsyntax-object environment consequent) ,(unsyntax-object environment alternative))) (define (unsyntax-conditional environment predicate consequent alternative) (cond ((not alternative) - `(AND ,@(unexpand-conjunction environment predicate consequent))) + `(and ,@(unexpand-conjunction environment predicate consequent))) ((eq? alternative undefined-scode-conditional-branch) - `(IF ,(unsyntax-object environment predicate) + `(if ,(unsyntax-object environment predicate) ,(unsyntax-object environment consequent))) ((eq? consequent undefined-scode-conditional-branch) - `(IF (,(ucode-primitive not) ,(unsyntax-object environment predicate)) + `(if (,(ucode-primitive not) ,(unsyntax-object environment predicate)) ,(unsyntax-object environment alternative))) ((and (scode-conditional? alternative) (not (has-substitution? alternative))) - `(COND ,@(unsyntax-cond-conditional environment predicate + `(cond ,@(unsyntax-cond-conditional environment predicate consequent alternative))) (else @@ -339,7 +339,7 @@ USA. ((has-substitution? alternative) => (lambda (substitution) - `((ELSE ,substitution)))) + `((else ,substitution)))) ((scode-disjunction? alternative) (unsyntax-cond-disjunction environment @@ -352,7 +352,7 @@ USA. (scode-conditional-consequent alternative) (scode-conditional-alternative alternative))) (else - `((ELSE ,@(unsyntax-sequence-for-splicing environment alternative)))))) + `((else ,@(unsyntax-sequence-for-splicing environment alternative)))))) (define (unexpand-conjunction environment predicate consequent) (if (and (scode-conditional? consequent) @@ -371,15 +371,15 @@ USA. ;;;; Lambdas -(define (unsyntax-EXTENDED-LAMBDA-object environment expression) +(define (unsyntax-extended-lambda-object environment expression) (if (unsyntaxer:macroize?) (unsyntax-lambda environment expression) - `(&XLAMBDA (,(scode-lambda-name expression) + `(&xlambda (,(scode-lambda-name expression) ,@(scode-lambda-interface expression)) ,(unsyntax-object environment (lambda-immediate-body expression))))) -(define (unsyntax-LAMBDA-object environment expression) +(define (unsyntax-lambda-object environment expression) (if (unsyntaxer:macroize?) (unsyntax-lambda environment expression) (collect-lambda (scode-lambda-name expression) @@ -398,13 +398,13 @@ USA. (define (collect-lambda name bvl body) (if (eq? name scode-lambda-name:unnamed) - `(LAMBDA ,bvl ,@body) - `(NAMED-LAMBDA (,name . ,bvl) ,@body))) + `(lambda ,bvl ,@body) + `(named-lambda (,name . ,bvl) ,@body))) (define (unsyntax-lambda-list expression) (if (not (scode-lambda? expression)) (error:wrong-type-argument expression "SCode lambda" - 'UNSYNTAX-LAMBDA-LIST)) + 'unsyntax-lambda-list)) (lambda-components* expression (lambda (name required optional rest body) name body @@ -424,7 +424,7 @@ USA. (let ((actions (scode-sequence-actions body))) (if (and (scode-block-declaration? (car actions)) (pair? (cdr actions))) - `((DECLARE ,@(scode-block-declaration-text (car actions))) + `((declare ,@(scode-block-declaration-text (car actions))) ,@(unsyntax-sequence-for-splicing environment (make-scode-sequence (cdr actions)))) @@ -451,7 +451,7 @@ USA. (= (length operands) 2) (scode-delay? (cadr operands)) (not (has-substitution? (cadr operands)))) - `(CONS-STREAM ,(unsyntax-object environment (car operands)) + `(cons-stream ,(unsyntax-object environment (car operands)) ,(unsyntax-object environment (scode-delay-expression (cadr operands))))) ((scode-lambda? operator) @@ -462,7 +462,7 @@ USA. (= (length required) (length operands))) (if (or (eq? name scode-lambda-name:unnamed) (eq? name scode-lambda-name:let)) - `(LET ,(unsyntax-let-bindings environment + `(let ,(unsyntax-let-bindings environment required operands) ,@(with-bindings environment operator @@ -486,17 +486,17 @@ USA. (let ((expression (car expression))) (and (list? expression) (= 4 (length expression)) - (eq? 'LET (car expression)) + (eq? 'let (car expression)) (eq? '() (cadr expression)) (symbol? (cadddr expression)) (let ((definition (caddr expression))) (and (pair? definition) - (eq? 'DEFINE (car definition)) + (eq? 'define (car definition)) (pair? (cadr definition)) (eq? (caadr definition) (cadddr expression)) (list? (cdadr definition)) (every symbol? (cdadr definition))))))) - `(LET ,(cadddr (car expression)) + `(let ,(cadddr (car expression)) ,(map (lambda (name value) `(,name ,@(if (unassigned-reference-trap? value) diff --git a/src/runtime/unxprm.scm b/src/runtime/unxprm.scm index 90744cb75..ec76207de 100644 --- a/src/runtime/unxprm.scm +++ b/src/runtime/unxprm.scm @@ -54,7 +54,7 @@ USA. (if (or (default-object? transformer) (not transformer)) identity-procedure (begin - (guarantee unary-procedure? transformer 'TEMPORARY-FILE-PATHNAME) + (guarantee unary-procedure? transformer 'temporary-file-pathname) transformer)))) (let loop ((ext 0)) (let ((pathname @@ -125,7 +125,7 @@ USA. (define (file-length filename) (let ((attrs (file-attributes-direct filename))) (if (not attrs) - (error:bad-range-argument filename 'FILE-LENGTH)) + (error:bad-range-argument filename 'file-length)) (file-attributes/length attrs))) (define (file-modification-time-direct filename) @@ -163,9 +163,9 @@ USA. (define environment-variables) (define (get-environment-variable name) - (guarantee string? name 'GET-ENVIRONMENT-VARIABLE) - (let ((value (hash-table/get environment-variables name 'NONE))) - (if (eq? value 'NONE) + (guarantee string? name 'get-environment-variable) + (let ((value (hash-table/get environment-variables name 'none))) + (if (eq? value 'none) (let ((value ((ucode-primitive get-environment-variable 1) (string-for-primitive name)))) @@ -174,13 +174,13 @@ USA. value))) (define (set-environment-variable! name value) - (guarantee string? name 'SET-ENVIRONMENT-VARIABLE!) + (guarantee string? name 'set-environment-variable!) (if value - (guarantee string? value 'SET-ENVIRONMENT-VARIABLE!)) + (guarantee string? value 'set-environment-variable!)) (hash-table/put! environment-variables name value)) (define (delete-environment-variable! name) - (guarantee string? name 'DELETE-ENVIRONMENT-VARIABLE!) + (guarantee string? name 'delete-environment-variable!) (hash-table/remove! environment-variables name)) (define (reset-environment-variables!) @@ -358,11 +358,11 @@ USA. (string-ci=? "iso9660" type) (string-ci=? "ntfs" type) (string-ci=? "smb" type)) - 'CRLF - 'LF))) + 'crlf + 'lf))) (define (default-line-ending) - 'LF) + 'lf) (define (copy-file from to) (let ((input-filename (->namestring (merge-pathnames from))) @@ -410,7 +410,7 @@ USA. (set-file-modes! output-filename (file-modes input-filename)))) (define (init-file-specifier->pathname specifier) - (guarantee init-file-specifier? specifier 'INIT-FILE-SPECIFIER->PATHNAME) + (guarantee init-file-specifier? specifier 'init-file-specifier->pathname) (merge-pathnames (apply string-append (cons ".mit-scheme" (append-map (lambda (string) (list "/" string)) diff --git a/src/runtime/url.scm b/src/runtime/url.scm index 0057a8933..3a2ca8b89 100644 --- a/src/runtime/url.scm +++ b/src/runtime/url.scm @@ -967,10 +967,10 @@ USA. (define (partial-uri-state-name puri) (let ((name (%partial-uri-state-name puri))) (case name - ((START-REFERENCE START-ABSOLUTE) 'start) - ((SCHEME-REFERENCE SCHEME-ABSOLUTE) 'scheme) - ((SEGMENT-NZ-NC) 'path) - ((HIER-PART INIT-SLASH) + ((start-reference start-absolute) 'start) + ((scheme-reference scheme-absolute) 'scheme) + ((segment-nz-nc) 'path) + ((hier-part init-slash) (if (partial-uri-scheme puri) 'hier-part 'relative-part)) (else name)))) @@ -1079,7 +1079,7 @@ USA. (segment-nc (push) segment-nz-nc) (? (set path) query) (|#| (set path) fragment) - (EOF)) + (eof)) (define-ppu-state scheme-reference (scheme (push) scheme-reference) @@ -1088,57 +1088,57 @@ USA. (/ (push) path) (? (set path) query) (|#| (set path) fragment) - (EOF)) + (eof)) (define-ppu-state segment-nz-nc (segment-nc (push) segment-nz-nc) (/ (push) path) (? (set path) query) (|#| (set path) fragment) - (EOF (set path))) + (eof (set path))) (define-ppu-state start-absolute (alpha (push) scheme-absolute) - (EOF)) + (eof)) (define-ppu-state scheme-absolute (scheme (push) scheme-absolute) (: (set scheme) hier-part) - (EOF)) + (eof)) (define-ppu-state hier-part (segment (push) path) (/ init-slash) (? (set path) query) (|#| (set path) fragment) - (EOF)) + (eof)) (define-ppu-state init-slash (segment (push /) (push) path) (/ authority) (? (push /) (set path) query) (|#| (push /) (set path) fragment) - (EOF)) + (eof)) (define-ppu-state authority (sloppy-auth (push) authority) (/ (set authority) (push) path) (? (set authority) query) (|#| (set authority) fragment) - (EOF (set authority))) + (eof (set authority))) (define-ppu-state path (segment (push) path) (/ (push) path) (? (set path) query) (|#| (set path) fragment) - (EOF (set path))) + (eof (set path))) (define-ppu-state query (query (push) query) (|#| (set query) fragment) - (EOF (set query))) + (eof (set query))) (define-ppu-state fragment (fragment (push) fragment) - (EOF (set fragment))) \ No newline at end of file + (eof (set fragment))) \ No newline at end of file diff --git a/src/runtime/urtrap.scm b/src/runtime/urtrap.scm index ccb851d05..b830ef75a 100644 --- a/src/runtime/urtrap.scm +++ b/src/runtime/urtrap.scm @@ -33,7 +33,7 @@ USA. (type vector) (named '|#[(runtime reference-trap)reference-trap]|) (print-procedure - (simple-unparser-method 'REFERENCE-TRAP + (simple-unparser-method 'reference-trap (lambda (trap) (list (let ((kind (reference-trap-kind trap))) (or (reference-trap-kind-name kind) @@ -70,11 +70,11 @@ USA. (define (reference-trap-kind-name kind) (case kind - ((0) 'UNASSIGNED) - ((2) 'UNBOUND) - ((6) 'EXPENSIVE) - ((14) 'COMPILER-CACHED) - ((15) 'MACRO) + ((0) 'unassigned) + ((2) 'unbound) + ((6) 'expensive) + ((14) 'compiler-cached) + ((15) 'macro) (else #f))) (define (make-immediate-reference-trap kind) @@ -121,7 +121,7 @@ USA. (define (cached-reference-trap-value trap) (if (not (cached-reference-trap? trap)) (error:wrong-type-argument trap "cached reference trap" - 'CACHED-REFERENCE-TRAP-VALUE)) + 'cached-reference-trap-value)) (map-reference-trap (let ((cache (reference-trap-extra trap))) (lambda () @@ -143,7 +143,7 @@ USA. (define (macro-reference-trap-transformer trap) (if (not (macro-reference-trap? trap)) (error:wrong-type-argument trap "macro reference trap" - 'MACRO-REFERENCE-TRAP-TRANSFORMER)) + 'macro-reference-trap-transformer)) (reference-trap-extra trap)) (define (make-unmapped-macro-reference-trap transformer) diff --git a/src/runtime/usrint.scm b/src/runtime/usrint.scm index 59f0305c7..63c4f6c54 100644 --- a/src/runtime/usrint.scm +++ b/src/runtime/usrint.scm @@ -33,53 +33,53 @@ USA. (define (prompt-for-command-expression prompt #!optional port environment) (let ((prompt (canonicalize-command-prompt prompt)) - (port (optional-port port 'PROMPT-FOR-COMMAND-EXPRESSION)) + (port (optional-port port 'prompt-for-command-expression)) (environment - (optional-environment environment 'PROMPT-FOR-COMMAND-EXPRESSION)) + (optional-environment environment 'prompt-for-command-expression)) (level (nearest-cmdl/level))) (let ((operation - (textual-port-operation port 'PROMPT-FOR-COMMAND-EXPRESSION))) + (textual-port-operation port 'prompt-for-command-expression))) (if operation (operation port environment prompt level) (begin - (guarantee textual-i/o-port? port 'PROMPT-FOR-COMMAND-EXPRESSION) + (guarantee textual-i/o-port? port 'prompt-for-command-expression) (write-command-prompt port prompt level) - (with-input-port-terminal-mode port 'COOKED + (with-input-port-terminal-mode port 'cooked (lambda () (read port environment)))))))) (define (prompt-for-expression prompt #!optional port environment) (%prompt-for-expression - (optional-port port 'PROMPT-FOR-EXPRESSION) - (optional-environment environment 'PROMPT-FOR-EXPRESSION) + (optional-port port 'prompt-for-expression) + (optional-environment environment 'prompt-for-expression) prompt - 'PROMPT-FOR-EXPRESSION)) + 'prompt-for-expression)) (define (prompt-for-evaluated-expression prompt #!optional environment port) (let ((environment - (optional-environment environment 'PROMPT-FOR-EVALUATED-EXPRESSION)) - (port (optional-port port 'PROMPT-FOR-EVALUATED-EXPRESSION))) + (optional-environment environment 'prompt-for-evaluated-expression)) + (port (optional-port port 'prompt-for-evaluated-expression))) (repl-eval (%prompt-for-expression port environment prompt - 'PROMPT-FOR-EVALUATED-EXPRESSION) + 'prompt-for-evaluated-expression) environment))) (define (%prompt-for-expression port environment prompt caller) (let ((prompt (canonicalize-prompt prompt ": "))) - (let ((operation (textual-port-operation port 'PROMPT-FOR-EXPRESSION))) + (let ((operation (textual-port-operation port 'prompt-for-expression))) (if operation (operation port environment prompt) (begin (guarantee textual-i/o-port? port caller) - (with-output-port-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'cooked (lambda () (fresh-line port) (newline port) (write-string prompt port) (flush-output-port port))) - (with-input-port-terminal-mode port 'COOKED + (with-input-port-terminal-mode port 'cooked (lambda () (read port environment)))))))) @@ -97,7 +97,7 @@ USA. (let ((prompt (canonicalize-command-prompt prompt)) (port (if (default-object? port) (interaction-i/o-port) port)) (level (nearest-cmdl/level))) - (let ((operation (textual-port-operation port 'PROMPT-FOR-COMMAND-CHAR))) + (let ((operation (textual-port-operation port 'prompt-for-command-char))) (if operation (operation port prompt level) (default/prompt-for-command-char port prompt level))))) @@ -106,12 +106,12 @@ USA. (write-command-prompt port prompt level) (let loop () (let ((char - (with-input-port-terminal-mode port 'RAW + (with-input-port-terminal-mode port 'raw (lambda () (read-char port))))) (if (char-graphic? char) (begin - (with-output-port-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'cooked (lambda () (write-char char port) (flush-output-port port))) @@ -121,34 +121,34 @@ USA. (define (prompt-for-confirmation prompt #!optional port) (let ((prompt (canonicalize-prompt prompt " (y or n)? ")) (port (if (default-object? port) (interaction-i/o-port) port))) - (let ((operation (textual-port-operation port 'PROMPT-FOR-CONFIRMATION))) + (let ((operation (textual-port-operation port 'prompt-for-confirmation))) (if operation (operation port prompt) (default/prompt-for-confirmation port prompt))))) (define (default/prompt-for-confirmation port prompt) - (with-output-port-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'cooked (lambda () (fresh-line port))) (let loop () - (with-output-port-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'cooked (lambda () (newline port) (write-string prompt port) (flush-output-port port))) (let ((char - (with-input-port-terminal-mode port 'RAW + (with-input-port-terminal-mode port 'raw (lambda () (read-char port))))) (case char ((#\y #\Y #\space) - (with-output-port-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'cooked (lambda () (write-string "Yes" port) (flush-output-port port))) true) ((#\n #\N #\rubout) - (with-output-port-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'cooked (lambda () (write-string "No" port) (flush-output-port port))) @@ -156,7 +156,7 @@ USA. ((#\newline) (loop)) (else - (with-output-port-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'cooked (lambda () (write char port) (beep port) @@ -166,19 +166,19 @@ USA. (define (prompt-for-string prompt #!optional port) ;; Returns a string (the normal, "cooked" input line) or eof-object. (let ((port (if (default-object? port) (interaction-i/o-port) port))) - (let ((operation (textual-port-operation port 'PROMPT-FOR-STRING))) + (let ((operation (textual-port-operation port 'prompt-for-string))) (if operation (operation port prompt) (default/prompt-for-string port prompt))))) (define (default/prompt-for-string port prompt) - (with-output-port-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'cooked (lambda () (fresh-line port) (newline port) (write-string prompt port) (flush-output-port port))) - (with-input-port-terminal-mode port 'COOKED + (with-input-port-terminal-mode port 'cooked (lambda () (read-line port)))) @@ -268,7 +268,7 @@ USA. (cond ((string? prompt) prompt) ((and (pair? prompt) - (eq? 'STANDARD (car prompt)) + (eq? 'standard (car prompt)) (string? (cdr prompt))) (cons (car prompt) (canonicalize-prompt (cdr prompt) " "))) (else @@ -276,12 +276,12 @@ USA. (define (write-command-prompt port prompt level) (if (not (nearest-cmdl/batch-mode?)) - (with-output-port-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'cooked (lambda () (fresh-line port) (newline port) (if (and (pair? prompt) - (eq? 'STANDARD (car prompt))) + (eq? 'standard (car prompt))) (begin (write level port) (write-string " " port) @@ -292,7 +292,7 @@ USA. ;;;; Debugger Support (define (port/debugger-failure port message) - (let ((operation (textual-port-operation port 'DEBUGGER-FAILURE))) + (let ((operation (textual-port-operation port 'debugger-failure))) (if operation (operation port message) (default/debugger-failure port message)))) @@ -302,7 +302,7 @@ USA. (default/debugger-message port message)) (define (port/debugger-message port message) - (let ((operation (textual-port-operation port 'DEBUGGER-MESSAGE))) + (let ((operation (textual-port-operation port 'debugger-message))) (if operation (operation port message) (default/debugger-message port message)))) @@ -312,7 +312,7 @@ USA. (write-string message port)) (define (port/debugger-presentation port thunk) - (let ((operation (textual-port-operation port 'DEBUGGER-PRESENTATION))) + (let ((operation (textual-port-operation port 'debugger-presentation))) (if operation (operation port thunk) (default/debugger-presentation port thunk)))) @@ -325,11 +325,11 @@ USA. (define (port/write-result port expression value hash-number #!optional environment) - (let ((operation (textual-port-operation port 'WRITE-RESULT)) + (let ((operation (textual-port-operation port 'write-result)) (environment (if (default-object? environment) (nearest-repl/environment) - (guarantee environment? environment 'PORT/WRITE-RESULT)))) + (guarantee environment? environment 'port/write-result)))) (if operation (operation port expression value hash-number environment) (default/write-result port expression value hash-number environment)))) @@ -337,7 +337,7 @@ USA. (define (default/write-result port expression object hash-number environment) expression (if (not (nearest-cmdl/batch-mode?)) - (with-output-port-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'cooked (lambda () (fresh-line port) (write-string ";" port) @@ -356,32 +356,32 @@ USA. (define write-result:undefined-value-is-special? true) (define (port/set-default-directory port directory) - (let ((operation (textual-port-operation port 'SET-DEFAULT-DIRECTORY))) + (let ((operation (textual-port-operation port 'set-default-directory))) (if operation (operation port directory)))) (define (port/set-default-environment port environment) - (let ((operation (textual-port-operation port 'SET-DEFAULT-ENVIRONMENT))) + (let ((operation (textual-port-operation port 'set-default-environment))) (if operation (operation port environment)))) (define (port/gc-start port) - (let ((operation (textual-port-operation port 'GC-START))) + (let ((operation (textual-port-operation port 'gc-start))) (if (and operation (not (*within-restore-window?*))) (operation port)))) (define (port/gc-finish port) - (let ((operation (textual-port-operation port 'GC-FINISH))) + (let ((operation (textual-port-operation port 'gc-finish))) (if (and operation (not (*within-restore-window?*))) (operation port)))) (define (port/read-start port) - (let ((operation (textual-port-operation port 'READ-START))) + (let ((operation (textual-port-operation port 'read-start))) (if operation (operation port)))) (define (port/read-finish port) - (let ((operation (textual-port-operation port 'READ-FINISH))) + (let ((operation (textual-port-operation port 'read-finish))) (if operation (operation port)))) @@ -428,11 +428,11 @@ USA. (make-textual-port wrapped-notification-port-type port)) (define (make-wrapped-notification-port-type) - (make-textual-port-type `((WRITE-CHAR ,operation/write-char) - (X-SIZE ,operation/x-size) - (COLUMN ,operation/column) - (FLUSH-OUTPUT ,operation/flush-output) - (DISCRETIONARY-FLUSH-OUTPUT + (make-textual-port-type `((write-char ,operation/write-char) + (x-size ,operation/x-size) + (column ,operation/column) + (flush-output ,operation/flush-output) + (discretionary-flush-output ,operation/discretionary-flush-output)) #f)) @@ -445,7 +445,7 @@ USA. (define (operation/x-size port) (let ((port* (textual-port-state port))) - (let ((op (textual-port-operation port* 'X-SIZE))) + (let ((op (textual-port-operation port* 'x-size))) (and op (let ((n (op port*))) (and n @@ -454,7 +454,7 @@ USA. (define (operation/column port) (let ((port* (textual-port-state port))) - (let ((op (textual-port-operation port* 'COLUMN))) + (let ((op (textual-port-operation port* 'column))) (and op (let ((n (op port*))) (and n diff --git a/src/runtime/vector.scm b/src/runtime/vector.scm index 460cc2af7..15c6bdd85 100644 --- a/src/runtime/vector.scm +++ b/src/runtime/vector.scm @@ -100,7 +100,7 @@ USA. value)) (define (subvector vector start end) - (guarantee-subvector vector start end 'SUBVECTOR) + (guarantee-subvector vector start end 'subvector) (let ((result (make-vector (fix:- end start)))) (subvector-move-right! vector start end result 0) result)) @@ -109,7 +109,7 @@ USA. (subvector vector 0 end)) (define (vector-head! vector end) - (guarantee-subvector vector 0 end 'VECTOR-HEAD!) + (guarantee-subvector vector 0 end 'vector-head!) (if (fix:< end (vector-length vector)) (primitive-object-set! vector 0 (primitive-make-object (ucode-type false) @@ -117,13 +117,13 @@ USA. vector) (define (vector-tail vector start) - (guarantee vector? vector 'VECTOR-TAIL) + (guarantee vector? vector 'vector-tail) (subvector vector start (vector-length vector))) (define (vector-copy vector #!optional start end) (let ((start (if (default-object? start) 0 start)) (end (if (default-object? end) (vector-length vector) end))) - (guarantee-subvector vector start end 'VECTOR-COPY) + (guarantee-subvector vector start end 'vector-copy) (let ((result (make-vector (fix:- end start)))) (subvector-move-right! vector start end result 0) result))) @@ -134,7 +134,7 @@ USA. (let loop ((vectors vectors) (length 0)) (if (pair? vectors) (begin - (guarantee vector? (car vectors) 'VECTOR-APPEND) + (guarantee vector? (car vectors) 'vector-append) (loop (cdr vectors) (fix:+ (vector-length (car vectors)) length))) length))))) @@ -146,11 +146,11 @@ USA. result)))) (define (vector-grow vector length #!optional value) - (guarantee vector? vector 'VECTOR-GROW) + (guarantee vector? vector 'vector-grow) (if (not (index-fixnum? length)) - (error:wrong-type-argument length "vector length" 'VECTOR-GROW)) + (error:wrong-type-argument length "vector length" 'vector-grow)) (if (fix:< length (vector-length vector)) - (error:bad-range-argument length 'VECTOR-GROW)) + (error:bad-range-argument length 'vector-grow)) (let ((vector* (make-vector length value))) (subvector-move-right! vector 0 (vector-length vector) vector* 0) vector*)) @@ -166,12 +166,12 @@ USA. vector)) (define (vector-map procedure vector . vectors) - (guarantee vector? vector 'VECTOR-MAP) - (for-each (lambda (v) (guarantee vector? v 'VECTOR-MAP)) vectors) + (guarantee vector? vector 'vector-map) + (for-each (lambda (v) (guarantee vector? v 'vector-map)) vectors) (let ((n (vector-length vector))) (for-each (lambda (v) (if (not (fix:= (vector-length v) n)) - (error:bad-range-argument v 'VECTOR-MAP))) + (error:bad-range-argument v 'vector-map))) vectors) (let ((result (make-vector n))) (do ((i 0 (fix:+ i 1))) @@ -184,12 +184,12 @@ USA. result))) (define (vector-for-each procedure vector . vectors) - (guarantee vector? vector 'VECTOR-FOR-EACH) - (for-each (lambda (v) (guarantee vector? v 'VECTOR-FOR-EACH)) vectors) + (guarantee vector? vector 'vector-for-each) + (for-each (lambda (v) (guarantee vector? v 'vector-for-each)) vectors) (let ((n (vector-length vector))) (for-each (lambda (v) (if (not (fix:= (vector-length v) n)) - (error:bad-range-argument v 'VECTOR-FOR-EACH))) + (error:bad-range-argument v 'vector-for-each))) vectors) (do ((i 0 (fix:+ i 1))) ((not (fix:< i n)) unspecific) @@ -201,7 +201,7 @@ USA. (vector-for-each procedure vector)) (define (subvector-find-next-element vector start end item) - (guarantee-subvector vector start end 'SUBVECTOR-FIND-NEXT-ELEMENT) + (guarantee-subvector vector start end 'subvector-find-next-element) (let loop ((index start)) (and (fix:< index end) (if (eqv? (vector-ref vector index) item) @@ -209,7 +209,7 @@ USA. (loop (fix:+ index 1)))))) (define (subvector-find-next-element-not vector start end item) - (guarantee-subvector vector start end 'SUBVECTOR-FIND-NEXT-ELEMENT-NOT) + (guarantee-subvector vector start end 'subvector-find-next-element-not) (let loop ((index start)) (and (fix:< index end) (if (eqv? (vector-ref vector index) item) @@ -217,7 +217,7 @@ USA. index)))) (define (subvector-find-previous-element vector start end item) - (guarantee-subvector vector start end 'SUBVECTOR-FIND-PREVIOUS-ELEMENT) + (guarantee-subvector vector start end 'subvector-find-previous-element) (let loop ((index (fix:- end 1))) (and (fix:<= start index) (if (eqv? (vector-ref vector index) item) @@ -225,7 +225,7 @@ USA. (loop (fix:- index 1)))))) (define (subvector-find-previous-element-not vector start end item) - (guarantee-subvector vector start end 'SUBVECTOR-FIND-PREVIOUS-ELEMENT-NOT) + (guarantee-subvector vector start end 'subvector-find-previous-element-not) (let loop ((index (fix:- end 1))) (and (fix:<= start index) (if (eqv? (vector-ref vector index) item) @@ -233,15 +233,15 @@ USA. index)))) (define-integrable (vector-find-next-element vector item) - (guarantee vector? vector 'VECTOR-FIND-NEXT-ELEMENT) + (guarantee vector? vector 'vector-find-next-element) (subvector-find-next-element vector 0 (vector-length vector) item)) (define-integrable (vector-find-previous-element vector item) - (guarantee vector? vector 'VECTOR-FIND-PREVIOUS-ELEMENT) + (guarantee vector? vector 'vector-find-previous-element) (subvector-find-previous-element vector 0 (vector-length vector) item)) (define (vector-binary-search vector keystring copyright-years))) @@ -75,7 +75,7 @@ USA. (let ((port (if (default-object? port) (current-output-port) - (guarantee textual-output-port? port 'WRITE-MIT-SCHEME-LICENSE))) + (guarantee textual-output-port? port 'write-mit-scheme-license))) (line-prefix (if (default-object? line-prefix) "" line-prefix)) (short? (if (default-object? short?) #f short?))) (let loop diff --git a/src/runtime/where.scm b/src/runtime/where.scm index b42b582c7..be3f48cb9 100644 --- a/src/runtime/where.scm +++ b/src/runtime/where.scm @@ -30,7 +30,7 @@ USA. (declare (usual-integrations)) (define (where #!optional environment) - (with-simple-restart 'CONTINUE "Return from WHERE." + (with-simple-restart 'continue "Return from WHERE." (lambda () (let ((wstate (make-wstate @@ -57,7 +57,7 @@ USA. (set! command-set (make-command-set - 'WHERE-COMMANDS + 'where-commands `((#\? ,standard-help-command "help, list command letters") (#\A ,show-all diff --git a/src/runtime/win32-registry.scm b/src/runtime/win32-registry.scm index c57bfbc43..ebfd49269 100644 --- a/src/runtime/win32-registry.scm +++ b/src/runtime/win32-registry.scm @@ -37,9 +37,9 @@ USA. (let ((parent (loop prefix))) (and parent (get-subkey parent name - (eq? 'CREATE-IF-NEEDED mode)))) - (get-root-key name 'WIN32-REGISTRY/OPEN-KEY)))))) - (if (and (not key) (eq? 'MUST-EXIST mode)) + (eq? 'create-if-needed mode)))) + (get-root-key name 'win32-registry/open-key)))))) + (if (and (not key) (eq? 'must-exist mode)) (error "Unable to open registry key:" name)) key)) @@ -67,20 +67,20 @@ USA. key)))) (define (win32-registry/add-subkey parent name) - (guarantee-registry-key parent 'WIN32-REGISTRY/ADD-SUBKEY) + (guarantee-registry-key parent 'win32-registry/add-subkey) (get-subkey parent name #t)) (define (win32-registry/delete-subkey parent name) - (guarantee-registry-key parent 'WIN32-REGISTRY/DELETE-SUBKEY) + (guarantee-registry-key parent 'win32-registry/delete-subkey) (win32-delete-registry-key (guarantee-handle parent) name) (delete-subkey! parent name)) (define (win32-registry/key-name key) - (guarantee-registry-key key 'WIN32-REGISTRY/KEY-NAME) + (guarantee-registry-key key 'win32-registry/key-name) (registry-key-name key)) (define (win32-registry/key-full-name key) - (guarantee-registry-key key 'WIN32-REGISTRY/KEY-FULL-NAME) + (guarantee-registry-key key 'win32-registry/key-full-name) (if (registry-key-parent key) (string-append (win32-registry/key-name (registry-key-parent key)) "\\" @@ -88,39 +88,39 @@ USA. (registry-key-name key))) (define (win32-registry/key-parent key) - (guarantee-registry-key key 'WIN32-REGISTRY/KEY-PARENT) + (guarantee-registry-key key 'win32-registry/key-parent) (registry-key-parent key)) (define (win32-registry/subkeys key) - (guarantee-registry-key key 'WIN32-REGISTRY/SUBKEYS) + (guarantee-registry-key key 'win32-registry/subkeys) (guarantee-subkeys key) (map (lambda (k.n) (guarantee-subkey key k.n)) (registry-key-subkeys key))) (define (win32-registry/subkey key name) - (guarantee-registry-key key 'WIN32-REGISTRY/SUBKEY) + (guarantee-registry-key key 'win32-registry/subkey) (find-subkey key name)) (define (win32-registry/value-names key) - (guarantee-registry-key key 'WIN32-REGISTRY/VALUE-NAMES) + (guarantee-registry-key key 'win32-registry/value-names) (guarantee-values key) (map registry-value-name (registry-key-values key))) (define (win32-registry/get-value key name) - (guarantee-registry-key key 'WIN32-REGISTRY/GET-VALUE) + (guarantee-registry-key key 'win32-registry/get-value) (let ((data (win32-query-registry-value (guarantee-handle key) name))) (if data (values (number->value-type (car data)) (cdr data)) (values #f #f)))) (define (win32-registry/set-value key name type data) - (guarantee-registry-key key 'WIN32-REGISTRY/SET-VALUE) + (guarantee-registry-key key 'win32-registry/set-value) (win32-set-registry-value (guarantee-handle key) name (value-type->number type) data) (add-value! key name type)) (define (win32-registry/delete-value key name) - (guarantee-registry-key key 'WIN32-REGISTRY/DELETE-VALUE) + (guarantee-registry-key key 'win32-registry/delete-value) (win32-delete-registry-value (guarantee-handle key) name) (delete-value! key name)) @@ -139,21 +139,21 @@ USA. (constructor %make-registry-key (parent name handle)) (predicate win32-registry/key?) (print-procedure - (simple-unparser-method 'REGISTRY-KEY + (simple-unparser-method 'registry-key (lambda (key) (list (registry-key-name key)))))) (name #f read-only #t) (parent #f read-only #t) (handle #f) - (subkeys 'UNKNOWN) - (values 'UNKNOWN)) + (subkeys 'unknown) + (values 'unknown)) (define (guarantee-registry-key object procedure) (if (not (win32-registry/key? object)) (error:wrong-type-argument object "registry key" procedure))) (define (guarantee-handle key) - (if (eq? 'DELETED (registry-key-handle key)) + (if (eq? 'deleted (registry-key-handle key)) (error "Registry key has been deleted:" key)) (or (registry-key-handle key) (begin @@ -163,7 +163,7 @@ USA. (define-structure (registry-value (print-procedure - (simple-unparser-method 'REGISTRY-VALUE + (simple-unparser-method 'registry-value (lambda (key) (list (registry-value-name key)))))) (name #f read-only #t) @@ -181,7 +181,7 @@ USA. #f))) (define (guarantee-subkeys key) - (if (eq? 'UNKNOWN (registry-key-subkeys key)) + (if (eq? 'unknown (registry-key-subkeys key)) (set-registry-key-subkeys! key (map (lambda (key) (%weak-cons key @@ -202,7 +202,7 @@ USA. key))) (define (add-subkey! parent name key) - (if (not (eq? 'UNKNOWN (registry-key-subkeys parent))) + (if (not (eq? 'unknown (registry-key-subkeys parent))) (let loop ((subkeys (registry-key-subkeys parent))) (if (pair? subkeys) (if (not (string-ci=? name (%weak-cdr (car subkeys)))) @@ -212,7 +212,7 @@ USA. (cons (%weak-cons key name) (registry-key-subkeys parent))))))) (define (delete-subkey! parent name) - (if (not (eq? 'UNKNOWN (registry-key-subkeys parent))) + (if (not (eq? 'unknown (registry-key-subkeys parent))) (let loop ((subkeys (registry-key-subkeys parent)) (prev #f)) (if (pair? subkeys) (if (string-ci=? name (%weak-cdr (car subkeys))) @@ -222,7 +222,7 @@ USA. (if key (begin (close-registry-handle key) - (set-registry-key-handle! key 'DELETED)))) + (set-registry-key-handle! key 'deleted)))) (if prev (set-cdr! prev (cdr subkeys)) (set-registry-key-subkeys! parent (cdr subkeys))))) @@ -231,7 +231,7 @@ USA. ;;;; Value Manipulation (define (guarantee-values key) - (if (eq? 'UNKNOWN (registry-key-values key)) + (if (eq? 'unknown (registry-key-values key)) (set-registry-key-values! key (generate-values key)))) (define (generate-values key) @@ -253,7 +253,7 @@ USA. #f))) (define (add-value! key name type) - (if (not (eq? 'UNKNOWN (registry-key-values key))) + (if (not (eq? 'unknown (registry-key-values key))) (let loop ((vs (registry-key-values key))) (if (pair? vs) (if (string-ci=? name (registry-value-name (car vs))) @@ -265,7 +265,7 @@ USA. (registry-key-values key))))))) (define (delete-value! key name) - (if (not (eq? 'UNKNOWN (registry-key-values key))) + (if (not (eq? 'unknown (registry-key-values key))) (let loop ((vs (registry-key-values key)) (prev #f)) (if (pair? vs) (if (string-ci=? name (registry-value-name (car vs))) @@ -316,7 +316,7 @@ USA. (map (lambda (n.h) (%make-registry-key #f (car n.h) (cdr n.h))) (win32-predefined-registry-keys))) - (set! open-handles-list (list 'OPEN-HANDLES-LIST)) + (set! open-handles-list (list 'open-handles-list)) (add-gc-daemon! close-lost-open-keys-daemon)) (define (close-lost-open-keys-daemon) @@ -356,20 +356,20 @@ USA. ;;; Value types: (define value-types - '#((REG_NONE) ; No value type - (REG_SZ) ; Unicode null-terminated string - (REG_EXPAND_SZ) ; Unicode null-terminated + '#((reg_none) ; No value type + (reg_sz) ; Unicode null-terminated string + (reg_expand_sz) ; Unicode null-terminated ; string (with environment ; variable references) - (REG_BINARY) ; Free form binary - (REG_DWORD REG_DWORD_LITTLE_ENDIAN) ; 32-bit number - (REG_DWORD_BIG_ENDIAN) ; 32-bit number - (REG_LINK) ; Symbolic Link (unicode) - (REG_MULTI_SZ) ; Multiple Unicode strings - (REG_RESOURCE_LIST) ; Resource list in the resource map - (REG_FULL_RESOURCE_DESCRIPTOR) ; Resource list in the + (reg_binary) ; Free form binary + (reg_dword reg_dword_little_endian) ; 32-bit number + (reg_dword_big_endian) ; 32-bit number + (reg_link) ; Symbolic Link (unicode) + (reg_multi_sz) ; Multiple Unicode strings + (reg_resource_list) ; Resource list in the resource map + (reg_full_resource_descriptor) ; Resource list in the ; hardware description - (REG_RESOURCE_REQUIREMENTS_LIST) + (reg_resource_requirements_list) )) (define (number->value-type n) diff --git a/src/runtime/wind.scm b/src/runtime/wind.scm index a48f00145..44e447d40 100644 --- a/src/runtime/wind.scm +++ b/src/runtime/wind.scm @@ -113,7 +113,7 @@ USA. (set-state-point/from-nearer! new-root #f) (set-state-space/nearest-point! space new-root) (with-stack-marker from-nearer - 'SET-INTERRUPT-ENABLES! interrupt-mask)) + 'set-interrupt-enables! interrupt-mask)) ;; Disable interrupts again in case FROM-NEARER ;; re-enabled them. ((ucode-primitive set-interrupt-enables! 1) interrupt-mask) @@ -142,19 +142,19 @@ USA. (procedure (fix:and interrupt-mask interrupt-mask/gc-ok))))) (define (current-state-point space) - (guarantee-state-space space 'CURRENT-STATE-POINT) + (guarantee-state-space space 'current-state-point) (state-space/nearest-point space)) (define (execute-at-new-state-point space before during after) - (guarantee-state-space space 'EXECUTE-AT-NEW-STATE-POINT) + (guarantee-state-space space 'execute-at-new-state-point) (%execute-at-new-state-point space before during after)) (define (translate-to-state-point point) - (guarantee-state-point point 'TRANSLATE-TO-STATE-POINT) + (guarantee-state-point point 'translate-to-state-point) (%translate-to-state-point point)) (define (state-point/space point) - (guarantee-state-point point 'STATE-POINT/SPACE) + (guarantee-state-point point 'state-point/space) (let ((interrupt-mask (limit-interrupts! interrupt-mask/gc-ok))) (let loop ((point point)) (let ((nearer-point (state-point/nearer-point point))) @@ -202,7 +202,7 @@ USA. (define (set-dynamic-state! state global-only?) (if (not (dynamic-state? state)) - (error:wrong-type-argument state "dynamic state" 'SET-DYNAMIC-STATE!)) + (error:wrong-type-argument state "dynamic state" 'set-dynamic-state!)) (if (not global-only?) (%translate-to-state-point (dynamic-state/local state))) (%translate-to-state-point (dynamic-state/global state))) diff --git a/src/runtime/world-report.scm b/src/runtime/world-report.scm index 2edea1b64..153b1b768 100644 --- a/src/runtime/world-report.scm +++ b/src/runtime/world-report.scm @@ -33,7 +33,7 @@ USA. (let ((port (if (default-object? port) (current-output-port) - (guarantee textual-output-port? port 'WORLD-REPORT))) + (guarantee textual-output-port? port 'world-report))) (flags (cons (cons (console-thread) "console") (if (default-object? thread-flags) '() @@ -175,11 +175,11 @@ USA. (define (write-state thread port) (write-string (case (thread-execution-state thread) - ((RUNNING) "running") - ((DEAD) " dead ") - ((WAITING) "waiting") - ((STOPPED) "stopped") - ((RUNNING-WITHOUT-PREEMPTION) "RUNNING") + ((running) "running") + ((dead) " dead ") + ((waiting) "waiting") + ((stopped) "stopped") + ((running-without-preemption) "RUNNING") (else " ????")) port)) diff --git a/src/runtime/wrkdir.scm b/src/runtime/wrkdir.scm index 10825ccb1..862c3fddf 100644 --- a/src/runtime/wrkdir.scm +++ b/src/runtime/wrkdir.scm @@ -66,7 +66,7 @@ USA. (directory-pathname-as-file pathname)) "not a directory" "no such directory") - 'SET-WORKING-DIRECTORY-PATHNAME! + 'set-working-directory-pathname! (list name))) (working-directory-pathname pathname) (cmdl/set-default-directory (nearest-cmdl) pathname) diff --git a/src/runtime/x11graph.scm b/src/runtime/x11graph.scm index a7817aa5d..2e554011a 100644 --- a/src/runtime/x11graph.scm +++ b/src/runtime/x11graph.scm @@ -143,7 +143,7 @@ USA. (define (initialize-package!) (set! x-graphics-device-type (make-graphics-device-type - 'X + 'x `((available? ,x-graphics/available?) (clear ,x-graphics/clear) (close ,x-graphics/close-window) @@ -223,7 +223,7 @@ USA. (conc-name x-display/) (constructor make-x-display (name xd)) (print-procedure - (simple-unparser-method 'X-DISPLAY + (simple-unparser-method 'x-display (lambda (display) (list (x-display/name display)))))) (name #f read-only #t) @@ -283,7 +283,7 @@ USA. (set! registration (permanently-register-io-thread-event (x-display-descriptor (x-display/xd display)) - 'READ + 'read (current-thread) (lambda (mode) mode @@ -325,11 +325,11 @@ USA. (define (%read-and-process-event display) (let ((event (or (x-display-process-events (x-display/xd display) 2) - (and (eq? 'READ + (and (eq? 'read (test-for-io-on-descriptor (x-display-descriptor (x-display/xd display)) #t - 'READ)) + 'read)) (x-display-process-events (x-display/xd display) 1))))) (if (and event (not (eq? #t event))) (process-event display event)))) @@ -384,7 +384,7 @@ USA. (x-graphics-reconfigure (vector-ref event 1) (vector-ref event 2) (vector-ref event 3)) - (if (eq? 'NEVER (x-window/mapped? window)) + (if (eq? 'never (x-window/mapped? window)) (set-x-window/mapped?! window #t)))) (define-event-handler event-type:delete-window @@ -405,9 +405,9 @@ USA. (define-event-handler event-type:visibility (lambda (window event) (case (vector-ref event 2) - ((0) (set-x-window/visibility! window 'UNOBSCURED)) - ((1) (set-x-window/visibility! window 'PARTIALLY-OBSCURED)) - ((2) (set-x-window/visibility! window 'OBSCURED))))) + ((0) (set-x-window/visibility! window 'unobscured)) + ((1) (set-x-window/visibility! window 'partially-obscured)) + ((2) (set-x-window/visibility! window 'obscured))))) (let ((mouse-event-handler (lambda (window event) @@ -432,7 +432,7 @@ USA. (constructor make-x-window (xw display))) xw (display #f read-only #t) - (mapped? 'NEVER) + (mapped? 'never) (visibility #f) (user-event-mask user-event-mask:default)) @@ -493,7 +493,7 @@ USA. (lambda () (decode-suppress-map-arg (and (not (default-object? suppress-map?)) suppress-map?) - 'MAKE-GRAPHICS-DEVICE)) + 'make-graphics-device)) (lambda (map? resource class) (let ((xw (x-graphics-open-window @@ -595,7 +595,7 @@ USA. (define (x-graphics/flush device) (if (and x-graphics:auto-raise? (x-graphics-device/mapped? device) - (not (eq? 'UNOBSCURED (x-graphics-device/visibility device)))) + (not (eq? 'unobscured (x-graphics-device/visibility device)))) (x-graphics/raise-window device)) ((ucode-primitive x-display-flush 1) (x-graphics-device/xd device))) @@ -627,7 +627,7 @@ USA. (define (x-graphics/set-line-style device line-style) (if (not (and (exact-nonnegative-integer? line-style) (< line-style 8))) (error:wrong-type-argument line-style "graphics line style" - 'SET-LINE-STYLE)) + 'set-line-style)) (let ((xw (x-graphics-device/xw device))) (if (zero? line-style) (x-graphics-set-line-style xw 0) @@ -846,7 +846,7 @@ USA. (define (initialize-image-datatype) (1d-table/put! (graphics-type-properties x-graphics-device-type) - 'IMAGE-TYPE + 'image-type (make-image-type `((create ,create-x-image) (destroy ,x-graphics-image/destroy) diff --git a/src/runtime/xeval.scm b/src/runtime/xeval.scm index 4d2fdf597..b2e6a09e4 100644 --- a/src/runtime/xeval.scm +++ b/src/runtime/xeval.scm @@ -97,18 +97,18 @@ USA. (set! rewrite-walker (make-scode-walker rewrite/constant - `((ACCESS ,rewrite/access) - (ASSIGNMENT ,rewrite/assignment) - (COMBINATION ,rewrite/combination) - (COMMENT ,rewrite/comment) - (CONDITIONAL ,rewrite/conditional) - (DELAY ,rewrite/delay) - (DISJUNCTION ,rewrite/disjunction) - (LAMBDA ,rewrite/lambda) - (SEQUENCE ,rewrite/sequence) - (THE-ENVIRONMENT ,rewrite/the-environment) - (UNASSIGNED? ,rewrite/unassigned?) - (VARIABLE ,rewrite/variable)))) + `((access ,rewrite/access) + (assignment ,rewrite/assignment) + (combination ,rewrite/combination) + (comment ,rewrite/comment) + (conditional ,rewrite/conditional) + (delay ,rewrite/delay) + (disjunction ,rewrite/disjunction) + (lambda ,rewrite/lambda) + (sequence ,rewrite/sequence) + (the-environment ,rewrite/the-environment) + (unassigned? ,rewrite/unassigned?) + (variable ,rewrite/variable)))) (set! hook/extended-scode-eval default/extended-scode-eval) unspecific) diff --git a/src/runtime/ystep.scm b/src/runtime/ystep.scm index db15814d7..87b73d008 100644 --- a/src/runtime/ystep.scm +++ b/src/runtime/ystep.scm @@ -69,14 +69,14 @@ USA. (define (step-form expression environment) ;; start a new evaluation - (step-start (make-ynode #f 'TOP ynode-exp:top-level) + (step-start (make-ynode #f 'top ynode-exp:top-level) (lambda () (eval expression environment)) (if (stepper-compiled?) 0 6) (if (stepper-compiled?) 1 5))) (define (step-proceed) ;; proceed from breakpoint - (step-start (make-ynode #f 'PROCEED ynode-exp:proceed) + (step-start (make-ynode #f 'proceed ynode-exp:proceed) (lambda () (continue)) (if (stepper-compiled?) 0 4) (if (stepper-compiled?) 5 7))) @@ -124,15 +124,15 @@ USA. (step-over-1 state)) (define (step-until-visibly state) - (set-stepper-step-until?! state 'ANIMATE) + (set-stepper-step-until?! state 'animate) (step-over-1 state)) (define (step-over-1 state) - (if (not (eq? (car (stepper-last-event state)) 'CALL)) + (if (not (eq? (car (stepper-last-event state)) 'call)) (error "Last event was not a call:" (stepper-last-event state))) (set-stepper-step-over! state (stack-top state)) (new-ynode-type! (stack-top state) - (if (stepper-step-until? state) 'EVAL 'STEP-OVER)) + (if (stepper-step-until? state) 'eval 'step-over)) (raw-step state)) (define (raw-step state) @@ -171,12 +171,12 @@ USA. (hunk3-cons (lambda (expr env) (hook-record state - (list 'EVAL (map-reference-trap (lambda () expr)) env)) + (list 'eval (map-reference-trap (lambda () expr)) env)) (process-eval state (map-reference-trap (lambda () expr))) (primitive-eval-step expr env hooks)) (lambda (proc . args) (hook-record state - (list 'APPLY + (list 'apply proc (map (lambda (arg) (map-reference-trap (lambda () arg))) @@ -185,7 +185,7 @@ USA. (primitive-apply-step proc args hooks)) (lambda (value) (hook-record state - (list 'RETURN (map-reference-trap (lambda () value)))) + (list 'return (map-reference-trap (lambda () value)))) (process-return state (map-reference-trap (lambda () value))) (primitive-return-step value hooks))))) hooks)) @@ -199,7 +199,7 @@ USA. ((system-hunk3-cxr0 (stepper-hooks state)) expr env) (begin (set! skip-evals (- skip-evals 1)) - (hook-record state (list 'EVAL expr env)) + (hook-record state (list 'eval expr env)) (primitive-eval-step expr env hooks)))) #f (lambda (result) @@ -207,7 +207,7 @@ USA. ((system-hunk3-cxr2 (stepper-hooks state)) result) (begin (set! skip-returns (- skip-returns 1)) - (hook-record state (list 'RESULT result)) + (hook-record state (list 'result result)) (primitive-return-step result hooks))))))) hooks)) @@ -233,11 +233,11 @@ USA. (stack-top state)) (if (and (stepper-step-over state) (not (stepper-step-until? state))) - 'STEPPED-OVER - 'EVAL) + 'stepped-over + 'eval) exp))) (stack-push! state node) - (set-stepper-last-event! state `(CALL ,node)) + (set-stepper-last-event! state `(call ,node)) (maybe-redisplay state))) (define (process-apply state proc) @@ -249,7 +249,7 @@ USA. (maybe-end-step-over state)) (let ((node (let ((node (stack-top state))) - (if (eq? (ynode-type node) 'PROCEED) + (if (eq? (ynode-type node) 'proceed) (ynode-splice-under node) (begin (stack-pop! state) @@ -257,12 +257,12 @@ USA. (new-ynode-result! node result) (if (stack-empty? state) (set-stepper-finished! state node)) - (set-stepper-last-event! state `(RETURN ,node)) + (set-stepper-last-event! state `(return ,node)) (maybe-redisplay state))) (define (maybe-redisplay state) (if (stepper-step-over state) - (if (eq? (stepper-step-until? state) 'ANIMATE) + (if (eq? (stepper-step-until? state) 'animate) (step-output state #t)) (call-with-current-continuation (lambda (k) @@ -300,8 +300,8 @@ USA. (result #f) (redisplay-flags #f read-only #t)) -(define ynode-exp:top-level (list 'STEPPER-TOP-LEVEL)) -(define ynode-exp:proceed (list 'STEPPER-PROCEED)) +(define ynode-exp:top-level (list 'stepper-top-level)) +(define ynode-exp:proceed (list 'stepper-proceed)) (define (ynode-exp-special node) (let ((exp (ynode-exp node))) @@ -309,9 +309,9 @@ USA. (eq? ynode-exp:proceed exp)) (car exp)))) -(define ynode-result:waiting (list 'WAITING)) -(define ynode-result:reduced (list 'REDUCED)) -(define ynode-result:unknown (list 'UNKNOWN)) +(define ynode-result:waiting (list 'waiting)) +(define ynode-result:reduced (list 'reduced)) +(define ynode-result:unknown (list 'unknown)) (define (ynode-result-special node) (let ((result (ynode-result node))) @@ -368,7 +368,7 @@ USA. (define (ynode-splice-under node) (let ((children (ynode-children node))) (set-ynode-children! node '()) - (let ((new-node (make-ynode node 'EVAL ynode-result:unknown))) + (let ((new-node (make-ynode node 'eval ynode-result:unknown))) (set-ynode-children! new-node children) (for-each (lambda (c) (set-ynode-parent! c new-node)) children) (let loop ((node new-node)) @@ -404,7 +404,7 @@ USA. (define (ynode-hidden-children? node) ;; used to control drawing of arrow - (and (eq? (ynode-type node) 'STEP-OVER) + (and (eq? (ynode-type node) 'step-over) (not (null? (ynode-children node))))) (define (ynode-needs-redisplay! ynode) @@ -429,16 +429,16 @@ USA. (ynode-needs-redisplay! ynode)) (define (ynode-expand! node) - (new-ynode-type! node 'EVAL) + (new-ynode-type! node 'eval) (for-each (lambda (dependent) - (if (eq? (ynode-type dependent) 'STEPPED-OVER) - (new-ynode-type! dependent 'STEP-OVER))) + (if (eq? (ynode-type dependent) 'stepped-over) + (new-ynode-type! dependent 'step-over))) (ynode-dependents node))) (define (ynode-contract! node) - (new-ynode-type! node 'STEP-OVER) + (new-ynode-type! node 'step-over) (for-each (lambda (dependent) - (new-ynode-type! dependent 'STEPPED-OVER)) + (new-ynode-type! dependent 'stepped-over)) (ynode-reductions node))) ;;;; Miscellaneous