From 17354b8b6fc5f6a321a2ed29be2585383a542ed7 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 13 Apr 2018 23:38:52 -0700 Subject: [PATCH] Another round of downcasing. --- src/runtime/list.scm | 206 ++++++++--------- src/runtime/load.scm | 24 +- src/runtime/make.scm | 328 +++++++++++++-------------- src/runtime/microcode-errors.scm | 34 +-- src/runtime/microcode-tables.scm | 72 +++--- src/runtime/msort.scm | 2 +- src/runtime/numpar.scm | 20 +- src/runtime/option.scm | 2 +- src/runtime/ordvec.scm | 4 +- src/runtime/output-port.scm | 48 ++-- src/runtime/parser-buffer.scm | 8 +- src/runtime/parser.scm | 8 +- src/runtime/pgsql.scm | 122 +++++----- src/runtime/poplat.scm | 6 +- src/runtime/pp.scm | 80 +++---- src/runtime/prgcop.scm | 68 +++--- src/runtime/primitive-arithmetic.scm | 6 +- src/runtime/primitive-io.scm | 6 +- src/runtime/procedure.scm | 54 ++--- src/runtime/process.scm | 56 ++--- src/runtime/prop1d.scm | 2 +- src/runtime/prop2d.scm | 12 +- src/runtime/qsort.scm | 2 +- src/runtime/queue.scm | 2 +- src/runtime/random.scm | 32 +-- src/runtime/rbtree.scm | 112 ++++----- src/runtime/record.scm | 26 +-- src/runtime/rep.scm | 120 +++++----- src/runtime/rexp.scm | 138 +++++------ src/runtime/rfc2822-headers.scm | 20 +- src/runtime/savres.scm | 4 +- src/runtime/scan.scm | 6 +- src/runtime/sfile.scm | 46 ++-- src/runtime/sha3.scm | 20 +- src/runtime/socket.scm | 12 +- src/runtime/srfi-1.scm | 88 +++---- src/runtime/stack-sample.scm | 10 +- src/runtime/stream.scm | 66 +++--- src/runtime/swank.scm | 46 ++-- src/runtime/syncproc.scm | 26 +-- src/runtime/syntax-check.scm | 20 +- src/runtime/syntax-declaration.scm | 2 +- src/runtime/system.scm | 2 +- 43 files changed, 984 insertions(+), 984 deletions(-) diff --git a/src/runtime/list.scm b/src/runtime/list.scm index 7d7f02df7..fa1c3cfd5 100644 --- a/src/runtime/list.scm +++ b/src/runtime/list.scm @@ -88,7 +88,7 @@ USA. this-element))) (define (make-list length #!optional value) - (guarantee index-fixnum? length 'MAKE-LIST) + (guarantee index-fixnum? length 'make-list) (let ((value (if (default-object? value) '() value))) (let loop ((n length) (result '())) (if (fix:zero? n) @@ -104,7 +104,7 @@ USA. items) (define (make-circular-list length #!optional value) - (guarantee index-fixnum? length 'MAKE-CIRCULAR-LIST) + (guarantee index-fixnum? length 'make-circular-list) (if (fix:> length 0) (let ((value (if (default-object? value) '() value))) (let ((last (cons value '()))) @@ -117,7 +117,7 @@ USA. '())) (define (make-initialized-list length initialization) - (guarantee index-fixnum? length 'MAKE-INITIALIZED-LIST) + (guarantee index-fixnum? length 'make-initialized-list) (let loop ((index (fix:- length 1)) (result '())) (if (fix:< index 0) result @@ -128,18 +128,18 @@ USA. (cons a d)) (define (iota count #!optional start step) - (guarantee index-fixnum? count 'IOTA) + (guarantee index-fixnum? count 'iota) (let ((start (if (default-object? start) 0 (begin - (guarantee number? start 'IOTA) + (guarantee number? start 'iota) start))) (step (if (default-object? step) 1 (begin - (guarantee number? step 'IOTA) + (guarantee number? step 'iota) step)))) (make-initialized-list count (lambda (index) (+ start (* index step)))))) @@ -238,7 +238,7 @@ USA. n)) (define (length list) - (guarantee-list->length list 'LENGTH)) + (guarantee-list->length list 'length)) (define (length=? left right) (define (%length=? n list) @@ -311,7 +311,7 @@ USA. (define (lose) (for-each (lambda (list) - (guarantee list? list 'LIST=)) + (guarantee list? list 'list=)) lists)) (if (and (pair? lists) @@ -322,40 +322,40 @@ USA. (define (list-ref list index) (let ((tail (list-tail list index))) (if (not (pair? tail)) - (error:bad-range-argument index 'LIST-REF)) + (error:bad-range-argument index 'list-ref)) (car tail))) (define (list-set! list index new-value) (let ((tail (list-tail list index))) (if (not (pair? tail)) - (error:bad-range-argument index 'LIST-SET!)) + (error:bad-range-argument index 'list-set!)) (set-car! tail new-value))) (define (list-tail list index) - (guarantee index-fixnum? index 'LIST-TAIL) + (guarantee index-fixnum? index 'list-tail) (let loop ((list list) (index* index)) (if (fix:zero? index*) list (begin (if (not (pair? list)) - (error:bad-range-argument index 'LIST-TAIL)) + (error:bad-range-argument index 'list-tail)) (loop (cdr list) (fix:- index* 1)))))) (define (list-head list index) - (guarantee index-fixnum? index 'LIST-HEAD) + (guarantee index-fixnum? index 'list-head) (let loop ((list list) (index* index)) (if (fix:zero? index*) '() (begin (if (not (pair? list)) - (error:bad-range-argument index 'LIST-HEAD)) + (error:bad-range-argument index 'list-head)) (cons (car list) (loop (cdr list) (fix:- index* 1))))))) (define (sublist list start end) (list-head (list-tail list start) (- end start))) (define (list-copy items) - (let ((lose (lambda () (error:not-a list? items 'LIST-COPY)))) + (let ((lose (lambda () (error:not-a list? items 'list-copy)))) (cond ((pair? items) (let ((head (cons (car items) '()))) (let loop ((list (cdr items)) (previous head)) @@ -466,8 +466,8 @@ USA. (do ((code operation-list (cdr code)) (answer 1 (+ (* answer 2) (case (car code) - ((CAR) 1) - ((CDR) 0) + ((car) 1) + ((cdr) 0) (else (error "encode-general-car-cdr: Invalid operation" (car code))))))) ((not (pair? code)) @@ -480,10 +480,10 @@ USA. (declare (integrate-operator safe-car safe-cdr)) (define (safe-car x) - (if (pair? x) (car x) (error:not-a pair? x 'SAFE-CAR))) + (if (pair? x) (car x) (error:not-a pair? x 'safe-car))) (define (safe-cdr x) - (if (pair? x) (cdr x) (error:not-a pair? x 'SAFE-CDR))) + (if (pair? x) (cdr x) (error:not-a pair? x 'safe-cdr))) (define (caar x) (safe-car (safe-car x))) (define (cadr x) (safe-car (safe-cdr x))) @@ -578,12 +578,12 @@ USA. (set-cdr! cell accum)) (else (error:not-a list? (car rest) - 'APPEND)))) + 'append)))) root)) ((null? l1) accum) (else - (error:not-a list? (car rest) 'APPEND)))) + (error:not-a list? (car rest) 'append)))) (cdr rest)) accum)) '()))) @@ -598,7 +598,7 @@ USA. head) (else (if (not (null? head)) - (error:not-a list? (car lists) 'APPEND!)) + (error:not-a list? (car lists) 'append!)) (loop (car tail) (cdr tail))))) '())) @@ -611,7 +611,7 @@ USA. (loop (cdr rest) (cons (car rest) so-far)) (begin (if (not (null? rest)) - (error:not-a list? l 'REVERSE*)) + (error:not-a list? l 'reverse*)) so-far)))) (define (reverse*! l tail) @@ -622,7 +622,7 @@ USA. (loop next current)) (begin (if (not (null? current)) - (error:not-a list? l 'REVERSE*!)) + (error:not-a list? l 'reverse*!)) new-cdr)))) ;;;; Mapping Procedures @@ -680,7 +680,7 @@ USA. (cdr head))) (define (bad-end) - (mapper-error (cons first rest) 'MAP)) + (mapper-error (cons first rest) 'map)) (if (pair? rest) (if (pair? (cdr rest)) @@ -710,50 +710,50 @@ USA. (extra-vars (list-ref form 2)) (combiner (list-ref form 3)) (initial-value (list-ref form 4))) - `(SET! ,name - (NAMED-LAMBDA (,name ,@extra-vars PROCEDURE FIRST . REST) - - (DEFINE (MAP-1 L) - (IF (PAIR? L) - (,combiner (PROCEDURE (CAR L)) - (MAP-1 (CDR L))) - (BEGIN - (IF (NOT (NULL? L)) - (BAD-END)) + `(set! ,name + (named-lambda (,name ,@extra-vars procedure first . rest) + + (define (map-1 l) + (if (pair? l) + (,combiner (procedure (car l)) + (map-1 (cdr l))) + (begin + (if (not (null? l)) + (bad-end)) ,initial-value))) - (DEFINE (MAP-2 L1 L2) - (IF (AND (PAIR? L1) (PAIR? L2)) - (,combiner (PROCEDURE (CAR L1) (CAR L2)) - (MAP-2 (CDR L1) (CDR L2))) - (BEGIN - (IF (NOT (AND (OR (NULL? L1) (PAIR? L1)) - (OR (NULL? L2) (PAIR? L2)))) - (BAD-END)) + (define (map-2 l1 l2) + (if (and (pair? l1) (pair? l2)) + (,combiner (procedure (car l1) (car l2)) + (map-2 (cdr l1) (cdr l2))) + (begin + (if (not (and (or (null? l1) (pair? l1)) + (or (null? l2) (pair? l2)))) + (bad-end)) ,initial-value))) - (DEFINE (MAP-N LISTS) - (LET SPLIT ((LISTS LISTS) (CARS '()) (CDRS '())) - (IF (PAIR? LISTS) - (IF (PAIR? (CAR LISTS)) - (SPLIT (CDR LISTS) - (CONS (CAR (CAR LISTS)) CARS) - (CONS (CDR (CAR LISTS)) CDRS)) - (BEGIN - (IF (NOT (NULL? (CAR LISTS))) - (BAD-END)) + (define (map-n lists) + (let split ((lists lists) (cars '()) (cdrs '())) + (if (pair? lists) + (if (pair? (car lists)) + (split (cdr lists) + (cons (car (car lists)) cars) + (cons (cdr (car lists)) cdrs)) + (begin + (if (not (null? (car lists))) + (bad-end)) ,initial-value)) - (,combiner (APPLY PROCEDURE (REVERSE! CARS)) - (MAP-N (REVERSE! CDRS)))))) + (,combiner (apply procedure (reverse! cars)) + (map-n (reverse! cdrs)))))) - (DEFINE (BAD-END) - (MAPPER-ERROR (CONS FIRST REST) ',name)) + (define (bad-end) + (mapper-error (cons first rest) ',name)) - (IF (PAIR? REST) - (IF (PAIR? (CDR REST)) - (MAP-N (CONS FIRST REST)) - (MAP-2 FIRST (CAR REST))) - (MAP-1 FIRST))))))))) + (if (pair? rest) + (if (pair? (cdr rest)) + (map-n (cons first rest)) + (map-2 first (car rest))) + (map-1 first))))))))) (mapper for-each () begin unspecific) (mapper map* (initial-value) cons initial-value) @@ -799,8 +799,8 @@ USA. (define (fold-left procedure initial first . rest) (if (pair? rest) - (%fold-left-lists 'FOLD-LEFT procedure initial (cons first rest)) - (%fold-left 'FOLD-LEFT procedure initial first))) + (%fold-left-lists 'fold-left procedure initial (cons first rest)) + (%fold-left 'fold-left procedure initial first))) ;;; Variants of FOLD-LEFT that should probably be avoided. @@ -808,12 +808,12 @@ USA. ;; PROCEDURE takes the arguments with the state at the right-hand end. (define (fold procedure initial first . rest) (if (pair? rest) - (%fold-left-lists 'FOLD + (%fold-left-lists 'fold (lambda (state . arguments) (apply procedure (append arguments (list state)))) initial (cons first rest)) - (%fold-left 'FOLD + (%fold-left 'fold (lambda (state item) (declare (integrate state item)) (procedure item state)) @@ -827,7 +827,7 @@ USA. ;; 4. PROCEDURE takes arguments in the wrong order. (define (reduce procedure default list) (if (pair? list) - (%fold-left 'REDUCE + (%fold-left 'reduce (lambda (state item) (declare (integrate state item)) (procedure item state)) @@ -835,7 +835,7 @@ USA. (cdr list)) (begin (if (not (null? list)) - (error:not-a list? list 'REDUCE)) + (error:not-a list? list 'reduce)) default))) (define (reduce-left procedure initial list) @@ -848,11 +848,11 @@ USA. (procedure first (loop (car rest) (cdr rest))) (begin (if (not (null? rest)) - (error:not-a list? list 'REDUCE-RIGHT)) + (error:not-a list? list 'reduce-right)) first))) (begin (if (not (null? list)) - (error:not-a list? list 'REDUCE-RIGHT)) + (error:not-a list? list 'reduce-right)) initial))) (define (fold-right procedure initial first . rest) @@ -866,7 +866,7 @@ USA. (cons (cdr (car lists)) cdrs)) (begin (if (not (null? (car lists))) - (mapper-error (cons first rest) 'FOLD-RIGHT)) + (mapper-error (cons first rest) 'fold-right)) initial)) (apply procedure (reverse! (cons (loop (reverse! cdrs)) cars)))))) @@ -875,7 +875,7 @@ USA. (procedure (car list) (loop (cdr list))) (begin (if (not (null? list)) - (error:not-a list? first 'FOLD-RIGHT)) + (error:not-a list? first 'fold-right)) initial))))) ;;;; Generalized list operations @@ -888,7 +888,7 @@ USA. (loop (cdr items*))) (begin (if (not (null? items*)) - (error:not-a list? items 'FIND-MATCHING-ITEM)) + (error:not-a list? items 'find-matching-item)) #f)))) (define (find-non-matching-item items predicate) @@ -899,7 +899,7 @@ USA. (car items*)) (begin (if (not (null? items*)) - (error:not-a list? items 'FIND-MATCHING-ITEM)) + (error:not-a list? items 'find-matching-item)) #f)))) (define (find-unique-matching-item items predicate) @@ -912,7 +912,7 @@ USA. (loop (cdr items*))) (begin (if (not (null? items*)) - (error:not-a list? items 'FIND-UNIQUE-MATCHING-ITEM)) + (error:not-a list? items 'find-unique-matching-item)) #f)))) (define (find-unique-non-matching-item items predicate) @@ -925,7 +925,7 @@ USA. #f)) (begin (if (not (null? items*)) - (error:not-a list? items 'FIND-UNIQUE-NON-MATCHING-ITEM)) + (error:not-a list? items 'find-unique-non-matching-item)) #f)))) (define (count-matching-items items predicate) @@ -933,7 +933,7 @@ USA. (n 0 (if (predicate (car items*)) (fix:+ n 1) n))) ((not (pair? items*)) (if (not (null? items*)) - (error:not-a list? items 'COUNT-MATCHING-ITEMS)) + (error:not-a list? items 'count-matching-items)) n))) (define (count-non-matching-items items predicate) @@ -941,11 +941,11 @@ USA. (n 0 (if (predicate (car items*)) n (fix:+ n 1)))) ((not (pair? items*)) (if (not (null? items*)) - (error:not-a list? items 'COUNT-NON-MATCHING-ITEMS)) + (error:not-a list? items 'count-non-matching-items)) n))) (define (keep-matching-items items predicate) - (let ((lose (lambda () (error:not-a list? items 'KEEP-MATCHING-ITEMS)))) + (let ((lose (lambda () (error:not-a list? items 'keep-matching-items)))) (cond ((pair? items) (let ((head (cons (car items) '()))) (let loop ((items* (cdr items)) (previous head)) @@ -963,7 +963,7 @@ USA. (else (lose))))) (define (delete-matching-items items predicate) - (let ((lose (lambda () (error:not-a list? items 'DELETE-MATCHING-ITEMS)))) + (let ((lose (lambda () (error:not-a list? items 'delete-matching-items)))) (cond ((pair? items) (let ((head (cons (car items) '()))) (let loop ((items* (cdr items)) (previous head)) @@ -1004,7 +1004,7 @@ USA. (lose))))) (lose (lambda () - (error:not-a list? items 'DELETE-MATCHING-ITEMS!)))) + (error:not-a list? items 'delete-matching-items!)))) (trim-initial-segment items))) (define (keep-matching-items! items predicate) @@ -1031,7 +1031,7 @@ USA. (lose))))) (lose (lambda () - (error:not-a list? items 'KEEP-MATCHING-ITEMS!)))) + (error:not-a list? items 'keep-matching-items!)))) (trim-initial-segment items))) (define ((list-deletor predicate) items) @@ -1043,14 +1043,14 @@ USA. ;;;; Membership lists (define (memq item items) - (%member item items eq? 'MEMQ)) + (%member item items eq? 'memq)) (define (memv item items) - (%member item items eqv? 'MEMV)) + (%member item items eqv? 'memv)) (define (member item items #!optional =) (let ((= (if (default-object? =) equal? =))) - (%member item items = 'MEMBER))) + (%member item items = 'member))) (define (member-procedure = #!optional caller) (lambda (item items) @@ -1078,14 +1078,14 @@ USA. ((deletor (lambda (match) (predicate match item))) items)) (define (delq item items) - (%delete item items eq? 'DELQ)) + (%delete item items eq? 'delq)) (define (delv item items) - (%delete item items eqv? 'DELV)) + (%delete item items eqv? 'delv)) (define (delete item items #!optional =) (let ((= (if (default-object? =) equal? =))) - (%delete item items = 'DELETE))) + (%delete item items = 'delete))) (define-integrable (%delete item items = caller) (let ((lose (lambda () (error:not-a list? items caller)))) @@ -1109,14 +1109,14 @@ USA. items)))) (define (delq! item items) - (%delete! item items eq? 'DELQ!)) + (%delete! item items eq? 'delq!)) (define (delv! item items) - (%delete! item items eqv? 'DELV!)) + (%delete! item items eqv? 'delv!)) (define (delete! item items #!optional =) (let ((= (if (default-object? =) equal? =))) - (%delete! item items = 'DELETE!))) + (%delete! item items = 'delete!))) (define-integrable (%delete! item items = caller) (letrec @@ -1155,7 +1155,7 @@ USA. (cons (cons key datum) alist)) (define (alist-copy alist) - (let ((lose (lambda () (error:not-a alist? alist 'ALIST-COPY)))) + (let ((lose (lambda () (error:not-a alist? alist 'alist-copy)))) (cond ((pair? alist) (if (pair? (car alist)) (let ((head (cons (car alist) '()))) @@ -1192,14 +1192,14 @@ USA. ((deletor (lambda (entry) (predicate (selector entry) key))) alist)) (define (assq key alist) - (%assoc key alist eq? 'ASSQ)) + (%assoc key alist eq? 'assq)) (define (assv key alist) - (%assoc key alist eqv? 'ASSV)) + (%assoc key alist eqv? 'assv)) (define (assoc key alist #!optional =) (let ((= (if (default-object? =) equal? =))) - (%assoc key alist = 'ASSOC))) + (%assoc key alist = 'assoc))) (define-integrable (%assoc key alist = caller) (let ((lose (lambda () (error:not-a alist? alist caller)))) @@ -1218,17 +1218,17 @@ USA. #f))))) (define (del-assq key alist) - (%alist-delete key alist eq? 'DEL-ASSQ)) + (%alist-delete key alist eq? 'del-assq)) (define (del-assv key alist) - (%alist-delete key alist eqv? 'DEL-ASSV)) + (%alist-delete key alist eqv? 'del-assv)) (define (del-assoc key alist) - (%alist-delete key alist equal? 'DEL-ASSOC)) + (%alist-delete key alist equal? 'del-assoc)) (define (alist-delete key alist #!optional =) (let ((= (if (default-object? =) equal? =))) - (%alist-delete key alist = 'ALIST-DELETE))) + (%alist-delete key alist = 'alist-delete))) (define-integrable (%alist-delete key alist = caller) (let ((lose (lambda () (error:not-a alist? alist caller)))) @@ -1257,17 +1257,17 @@ USA. alist)))) (define (del-assq! key alist) - (%alist-delete! key alist eq? 'DEL-ASSQ!)) + (%alist-delete! key alist eq? 'del-assq!)) (define (del-assv! key alist) - (%alist-delete! key alist eqv? 'DEL-ASSV!)) + (%alist-delete! key alist eqv? 'del-assv!)) (define (del-assoc! key alist) - (%alist-delete! key alist equal? 'DEL-ASSOC!)) + (%alist-delete! key alist equal? 'del-assoc!)) (define (alist-delete! key alist #!optional =) (let ((= (if (default-object? =) equal? =))) - (%alist-delete! key alist = 'ALIST-DELETE!))) + (%alist-delete! key alist = 'alist-delete!))) (define-integrable (%alist-delete! item items = caller) (letrec diff --git a/src/runtime/load.scm b/src/runtime/load.scm index 02f793d4d..9c28901e2 100644 --- a/src/runtime/load.scm +++ b/src/runtime/load.scm @@ -32,7 +32,7 @@ USA. (define (initialize-package!) (set! *purification-root-marker* (intern "#[PURIFICATION-ROOT]")) (set! condition-type:not-loading - (make-condition-type 'NOT-LOADING condition-type:error '() + (make-condition-type 'not-loading condition-type:error '() "No file being loaded.")) (set! param:after-load-hooks (make-settable-parameter '())) @@ -266,7 +266,7 @@ USA. (define (with-eval-unit uri thunk) (parameterize* - (list (cons param:eval-unit (->absolute-uri uri 'WITH-EVAL-UNIT))) + (list (cons param:eval-unit (->absolute-uri uri 'with-eval-unit))) thunk)) (define (current-eval-unit #!optional error?) @@ -287,12 +287,12 @@ USA. env))) (define (set-load-environment! environment) - (guarantee environment? environment 'SET-LOAD-ENVIRONMENT!) + (guarantee environment? environment 'set-load-environment!) (if (not (default-object? (param:current-load-environment))) (param:current-load-environment environment))) (define (with-load-environment environment thunk) - (guarantee environment? environment 'WITH-LOAD-ENVIRONMENT) + (guarantee environment? environment 'with-load-environment) (parameterize* (list (cons param:current-load-environment environment)) thunk)) @@ -426,7 +426,7 @@ USA. (and (pair? pu) (string=? (car pu) (car pl)) (loop (cdr pu) (cdr pl))) - (make-pathname #f #f (cons 'RELATIVE pu) + (make-pathname #f #f (cons 'relative pu) #f #f #f))))))) (if path (with-directory-rewriting-rule directory path thunk) @@ -454,12 +454,12 @@ USA. (begin (set! system-base-uri (string->uri system-base-uri)) unspecific)) - (maybe-merge rel-uri system-base-uri 'SYSTEM-URI)) + (maybe-merge rel-uri system-base-uri 'system-uri)) (define system-base-uri "http://www.gnu.org/software/mit-scheme/") (define (system-library-uri #!optional rel-uri) - (maybe-merge rel-uri (system-uri "lib/") 'SYSTEM-LIBRARY-URI)) + (maybe-merge rel-uri (system-uri "lib/") 'system-library-uri)) (define (maybe-merge rel-uri base-uri caller) (if (default-object? rel-uri) @@ -549,12 +549,12 @@ USA. unspecific) (define (set-command-line-parser! keyword proc #!optional description) - (guarantee string? keyword 'SET-COMMAND-LINE-PARSER!) + (guarantee string? keyword 'set-command-line-parser!) (let ((keyword (strip-leading-hyphens keyword)) (desc (if (default-object? description) "" (begin - (guarantee string? description 'SET-COMMAND-LINE-PARSER!) + (guarantee string? description 'set-command-line-parser!) description)))) (let ((place (assoc keyword *command-line-parsers*))) @@ -593,14 +593,14 @@ USA. (string-append keyword-line "\n (No description.)"))) (define (simple-command-line-parser keyword thunk . description-lines) - (guarantee string? keyword 'SIMPLE-COMMAND-LINE-PARSER) + (guarantee string? keyword 'simple-command-line-parser) (set-command-line-parser! keyword (lambda (command-line) (values (cdr command-line) thunk)) (command-line-option-description (string-append "--" keyword) description-lines - 'SIMPLE-COMMAND-LINE-PARSER))) + 'simple-command-line-parser))) ;; Upwards compatibility. (define simple-option-parser simple-command-line-parser) @@ -622,7 +622,7 @@ USA. (command-line-option-description (string-append "--" keyword " ARG" (if multiple? " ..." "")) description-lines - 'ARGUMENT-COMMAND-LINE-PARSER))) + 'argument-command-line-parser))) (define (for-each-non-keyword command-line processor) (let ((end diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 5740a39d0..a1d61820d 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -37,7 +37,7 @@ USA. ((ucode-primitive local-assignment) #f ;global environment - 'DEFINE-MULTIPLE + 'define-multiple (lambda (env names values) (if (or (not (vector? names)) (not (vector? values)) @@ -175,15 +175,15 @@ USA. (and package (let ((env (package/environment package))) (if (not procedure-name) - (if (lexical-unreferenceable? env 'INITIALIZE-PACKAGE!) + (if (lexical-unreferenceable? env 'initialize-package!) ((access get-boot-init-runner boot-defs) env) - (lexical-reference env 'INITIALIZE-PACKAGE!)) + (lexical-reference env 'initialize-package!)) (and (not (lexical-unreferenceable? env procedure-name)) (lexical-reference env procedure-name)))))) => (lambda (procedure) (print-name "initialize:") (if (not (or (not procedure-name) - (eq? procedure-name 'INITIALIZE-PACKAGE!))) + (eq? procedure-name 'initialize-package!))) (begin (tty-write-string " [") (tty-write-string (system-pair-car procedure-name)) @@ -206,7 +206,7 @@ USA. (do ((specs specs (cdr specs))) ((not (pair? specs)) unspecific) (let ((spec (car specs))) - (cond ((eq? (car spec) 'OPTIONAL) + (cond ((eq? (car spec) 'optional) (package-initialize (cadr spec) (and (pair? (cddr spec)) (caddr spec)) @@ -309,78 +309,78 @@ USA. (intern os-name-string)) (define newline-string - (if (eq? 'UNIX os-name) + (if (eq? 'unix os-name) "\n" "\r\n")) ;; Construct the package structure. ;; Lotta hair here to load the package code before its package is built. (eval (file->object "packag" #t #t) environment-for-package) -((lexical-reference environment-for-package 'INITIALIZE-PACKAGE!)) +((lexical-reference environment-for-package 'initialize-package!)) (let ((export (lambda (name) (link-variables system-global-environment name environment-for-package name)))) - (export '*ALLOW-PACKAGE-REDEFINITION?*) - (export 'CONSTRUCT-PACKAGES-FROM-FILE) - (export 'ENVIRONMENT->PACKAGE) - (export 'FIND-PACKAGE) - (export 'LOAD-PACKAGE-SET) - (export 'LOAD-PACKAGES-FROM-FILE) - (export 'NAME->PACKAGE) - (export 'PACKAGE-SET-PATHNAME) - (export 'PACKAGE/ADD-CHILD!) - (export 'PACKAGE/CHILDREN) - (export 'PACKAGE/ENVIRONMENT) - (export 'PACKAGE/NAME) - (export 'PACKAGE/PARENT) - (export 'PACKAGE/REFERENCE) - (export 'PACKAGE?)) -(package/add-child! (find-package '()) 'PACKAGE environment-for-package) + (export '*allow-package-redefinition?*) + (export 'construct-packages-from-file) + (export 'environment->package) + (export 'find-package) + (export 'load-package-set) + (export 'load-packages-from-file) + (export 'name->package) + (export 'package-set-pathname) + (export 'package/add-child!) + (export 'package/children) + (export 'package/environment) + (export 'package/name) + (export 'package/parent) + (export 'package/reference) + (export 'package?)) +(package/add-child! (find-package '()) 'package environment-for-package) (define packages-file (let ((name (string-append "runtime-" - (cond ((eq? os-name 'NT) "w32") - ((eq? os-name 'UNIX) "unx") + (cond ((eq? os-name 'nt) "w32") + ((eq? os-name 'unix) "unx") (else "unk")) ".pkd"))) (or (initialize-c-compiled-block (string-append runtime-prefix name)) (fasload name #f)))) -((lexical-reference environment-for-package 'CONSTRUCT-PACKAGES-FROM-FILE) +((lexical-reference environment-for-package 'construct-packages-from-file) packages-file) ;;; Global databases. Load, then initialize. (define boot-defs) (let ((files0 - '(("gcdemn" . (RUNTIME GC-DAEMONS)) - ("gc" . (RUNTIME GARBAGE-COLLECTOR)) - ("boot" . (RUNTIME BOOT-DEFINITIONS)) - ("queue" . (RUNTIME SIMPLE-QUEUE)) - ("equals" . (RUNTIME EQUALITY)) - ("list" . (RUNTIME LIST)) + '(("gcdemn" . (runtime gc-daemons)) + ("gc" . (runtime garbage-collector)) + ("boot" . (runtime boot-definitions)) + ("queue" . (runtime simple-queue)) + ("equals" . (runtime equality)) + ("list" . (runtime list)) ("primitive-arithmetic" . (runtime primitive-arithmetic)) ("srfi-1" . (runtime srfi-1)) ("thread-low" . (runtime thread)) - ("vector" . (RUNTIME VECTOR)))) + ("vector" . (runtime vector)))) (files1 '(("string" . (runtime string)) - ("symbol" . (RUNTIME SYMBOL)) + ("symbol" . (runtime symbol)) ("procedure" . (runtime procedure)) - ("random" . (RUNTIME RANDOM-NUMBER)) + ("random" . (runtime random-number)) ("dispatch-tag" . (runtime tagged-dispatch)) - ("poplat" . (RUNTIME POPULATION)) - ("record" . (RUNTIME RECORD)) + ("poplat" . (runtime population)) + ("record" . (runtime record)) ("bundle" . (runtime bundle)))) (files2 '(("syntax-low" . (runtime syntax low)) - ("thread" . (RUNTIME THREAD)) - ("wind" . (RUNTIME STATE-SPACE)) - ("prop1d" . (RUNTIME 1D-PROPERTY)) - ("events" . (RUNTIME EVENT-DISTRIBUTOR)) - ("gdatab" . (RUNTIME GLOBAL-DATABASE)) - ("gcfinal" . (RUNTIME GC-FINALIZER)))) + ("thread" . (runtime thread)) + ("wind" . (runtime state-space)) + ("prop1d" . (runtime 1d-property)) + ("events" . (runtime event-distributor)) + ("gdatab" . (runtime global-database)) + ("gcfinal" . (runtime gc-finalizer)))) (load-files (lambda (files) (do ((files files (cdr files))) @@ -400,33 +400,33 @@ USA. (load-files files0) (set! boot-defs - (package/environment (name->package '(RUNTIME BOOT-DEFINITIONS)))) + (package/environment (name->package '(runtime boot-definitions)))) (load-files-with-boot-inits files1) - (package-initialize '(RUNTIME GC-DAEMONS) #f #t) - (package-initialize '(RUNTIME GARBAGE-COLLECTOR) #f #t) - (package-initialize '(RUNTIME RANDOM-NUMBER) #f #t) + (package-initialize '(runtime gc-daemons) #f #t) + (package-initialize '(runtime garbage-collector) #f #t) + (package-initialize '(runtime random-number) #f #t) (package-initialize '(runtime tagged-dispatch) #f #t) - (package-initialize '(RUNTIME POPULATION) #f #t) + (package-initialize '(runtime population) #f #t) (package-initialize '(runtime record) #f #t) (package-initialize '(runtime bundle) #f #t) (load-files-with-boot-inits files2) - (package-initialize '(RUNTIME 1D-PROPERTY) #f #t) ;First population. - (package-initialize '(RUNTIME STATE-SPACE) #f #t) - (package-initialize '(RUNTIME THREAD) 'INITIALIZE-LOW! #t) ;First 1d-table. - (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) #f #t) - (package-initialize '(RUNTIME GLOBAL-DATABASE) #f #t) - (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! #t) - (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! #t) - (package-initialize '(RUNTIME GC-FINALIZER) #f #t) + (package-initialize '(runtime 1d-property) #f #t) ;First population. + (package-initialize '(runtime state-space) #f #t) + (package-initialize '(runtime thread) 'initialize-low! #t) ;First 1d-table. + (package-initialize '(runtime event-distributor) #f #t) + (package-initialize '(runtime global-database) #f #t) + (package-initialize '(runtime population) 'initialize-unparser! #t) + (package-initialize '(runtime 1d-property) 'initialize-unparser! #t) + (package-initialize '(runtime gc-finalizer) #f #t) ;; Load everything else. - ((lexical-reference environment-for-package 'LOAD-PACKAGES-FROM-FILE) + ((lexical-reference environment-for-package 'load-packages-from-file) packages-file - `((SORT-TYPE . MERGE-SORT) - (OS-TYPE . ,os-name) - (OPTIONS . NO-LOAD)) + `((sort-type . merge-sort) + (os-type . ,os-name) + (options . no-load)) (let ((file-member? (lambda (filename files) (let loop ((files files)) @@ -450,123 +450,123 @@ USA. (package-initialization-sequence '( ;; Microcode interface - ((RUNTIME MICROCODE-TABLES) READ-MICROCODE-TABLES!) - (RUNTIME APPLY) - (RUNTIME PRIMITIVE-IO) - (RUNTIME SYSTEM-CLOCK) - ((RUNTIME GC-FINALIZER) INITIALIZE-EVENTS!) + ((runtime microcode-tables) read-microcode-tables!) + (runtime apply) + (runtime primitive-io) + (runtime system-clock) + ((runtime gc-finalizer) initialize-events!) ;; Basic data structures - (RUNTIME NUMBER) - ((RUNTIME NUMBER) INITIALIZE-DRAGON4!) - (RUNTIME MISCELLANEOUS-GLOBAL) - (RUNTIME CHARACTER) - (RUNTIME BYTEVECTOR) - (RUNTIME CHARACTER-SET) - (RUNTIME LAMBDA-ABSTRACTION) + (runtime number) + ((runtime number) initialize-dragon4!) + (runtime miscellaneous-global) + (runtime character) + (runtime bytevector) + (runtime character-set) + (runtime lambda-abstraction) (runtime string) - (RUNTIME STREAM) - (RUNTIME 2D-PROPERTY) - (RUNTIME HASH-TABLE) - (RUNTIME MEMOIZER) - (RUNTIME UCD-TABLES) - (RUNTIME UCD-GLUE) - (RUNTIME BLOWFISH) - (RUNTIME PREDICATE) - (RUNTIME PREDICATE-TAGGING) - (RUNTIME PREDICATE-DISPATCH) - (RUNTIME COMPOUND-PREDICATE) - (RUNTIME PARAMETRIC-PREDICATE) - (RUNTIME HASH) - (RUNTIME DYNAMIC) - (RUNTIME REGULAR-SEXPRESSION) + (runtime stream) + (runtime 2d-property) + (runtime hash-table) + (runtime memoizer) + (runtime ucd-tables) + (runtime ucd-glue) + (runtime blowfish) + (runtime predicate) + (runtime predicate-tagging) + (runtime predicate-dispatch) + (runtime compound-predicate) + (runtime parametric-predicate) + (runtime hash) + (runtime dynamic) + (runtime regular-sexpression) ;; Microcode data structures - (RUNTIME HISTORY) - (RUNTIME SCODE) - (RUNTIME SCODE-WALKER) - (RUNTIME CONTINUATION-PARSER) - (RUNTIME PROGRAM-COPIER) + (runtime history) + (runtime scode) + (runtime scode-walker) + (runtime continuation-parser) + (runtime program-copier) ;; Finish records - ((RUNTIME RECORD) INITIALIZE-RECORD-PROCEDURES!) - ((PACKAGE) FINALIZE-PACKAGE-RECORD-TYPE!) - ((RUNTIME RANDOM-NUMBER) FINALIZE-RANDOM-STATE-TYPE!) + ((runtime record) initialize-record-procedures!) + ((package) finalize-package-record-type!) + ((runtime random-number) finalize-random-state-type!) ;; Condition System - (RUNTIME ERROR-HANDLER) - (RUNTIME MICROCODE-ERRORS) + (runtime error-handler) + (runtime microcode-errors) ((runtime record) initialize-conditions!) - ((RUNTIME STREAM) INITIALIZE-CONDITIONS!) - ((RUNTIME REGULAR-SEXPRESSION) INITIALIZE-CONDITIONS!) + ((runtime stream) initialize-conditions!) + ((runtime regular-sexpression) initialize-conditions!) ;; System dependent stuff - ((RUNTIME OS-PRIMITIVES) INITIALIZE-SYSTEM-PRIMITIVES!) + ((runtime os-primitives) initialize-system-primitives!) ;; Floating-point environment -- needed by threads. - (RUNTIME FLOATING-POINT-ENVIRONMENT) - ((RUNTIME THREAD) INITIALIZE-HIGH!) + (runtime floating-point-environment) + ((runtime thread) initialize-high!) ;; I/O - (RUNTIME PORT) - (RUNTIME OUTPUT-PORT) - (RUNTIME GENERIC-I/O-PORT) - (RUNTIME FILE-I/O-PORT) - (RUNTIME CONSOLE-I/O-PORT) - (RUNTIME SOCKET) - (RUNTIME STRING-I/O-PORT) - (RUNTIME USER-INTERFACE) + (runtime port) + (runtime output-port) + (runtime generic-i/o-port) + (runtime file-i/o-port) + (runtime console-i/o-port) + (runtime socket) + (runtime string-i/o-port) + (runtime user-interface) ;; These MUST be done before (RUNTIME PATHNAME) ;; Typically only one of them is loaded. - (RUNTIME PATHNAME UNIX) - (RUNTIME PATHNAME DOS) - (RUNTIME PATHNAME) - (RUNTIME DIRECTORY) - (RUNTIME WORKING-DIRECTORY) - (RUNTIME LOAD) - (RUNTIME SIMPLE-FILE-OPS) - (OPTIONAL (RUNTIME OS-PRIMITIVES) INITIALIZE-MIME-TYPES!) + (runtime pathname unix) + (runtime pathname dos) + (runtime pathname) + (runtime directory) + (runtime working-directory) + (runtime load) + (runtime simple-file-ops) + (optional (runtime os-primitives) initialize-mime-types!) ;; Syntax - (RUNTIME NUMBER-PARSER) - (RUNTIME OPTIONS) - (RUNTIME PARSER) - (RUNTIME FILE-ATTRIBUTES) - ((RUNTIME PATHNAME) INITIALIZE-PARSER-METHOD!) - (RUNTIME UNPARSER) - (RUNTIME UNSYNTAXER) - (RUNTIME PRETTY-PRINTER) - (RUNTIME EXTENDED-SCODE-EVAL) + (runtime number-parser) + (runtime options) + (runtime parser) + (runtime file-attributes) + ((runtime pathname) initialize-parser-method!) + (runtime unparser) + (runtime unsyntaxer) + (runtime pretty-printer) + (runtime extended-scode-eval) (runtime syntax items) (runtime syntax rename) (runtime syntax top-level) (runtime syntax parser) ;; REP Loops - (RUNTIME INTERRUPT-HANDLER) - (RUNTIME GC-STATISTICS) - (RUNTIME GC-NOTIFICATION) - (RUNTIME REP) + (runtime interrupt-handler) + (runtime gc-statistics) + (runtime gc-notification) + (runtime rep) ;; Debugging - (RUNTIME COMPILER-INFO) - (RUNTIME ADVICE) - (RUNTIME DEBUGGER-COMMAND-LOOP) - (RUNTIME DEBUGGER-UTILITIES) - (RUNTIME ENVIRONMENT-INSPECTOR) - (RUNTIME DEBUGGING-INFO) - (RUNTIME DEBUGGER) + (runtime compiler-info) + (runtime advice) + (runtime debugger-command-loop) + (runtime debugger-utilities) + (runtime environment-inspector) + (runtime debugging-info) + (runtime debugger) ;; Misc (e.g., version) - (RUNTIME) - (RUNTIME CRYPTO) + (runtime) + (runtime crypto) ;; Graphics. The last type initialized is the default for ;; MAKE-GRAPHICS-DEVICE, only the types that are valid for the ;; operating system are actually loaded and initialized. - (OPTIONAL (RUNTIME X-GRAPHICS)) + (optional (runtime x-graphics)) ;; Emacs -- last because it installs hooks everywhere which must be initted. - (RUNTIME EMACS-INTERFACE) + (runtime emacs-interface) ;; More debugging - (OPTIONAL (RUNTIME CONTINUATION-PARSER) INITIALIZE-SPECIAL-FRAMES!) - (RUNTIME URI) - (RUNTIME RFC2822-HEADERS) - (RUNTIME HTTP-SYNTAX) - (RUNTIME HTML-FORM-CODEC) - (OPTIONAL (RUNTIME WIN32-REGISTRY)) - (OPTIONAL (RUNTIME FFI)) - (RUNTIME SAVE/RESTORE) - (RUNTIME STRUCTURE-PARSER) - (RUNTIME SWANK) - (RUNTIME STACK-SAMPLER) + (optional (runtime continuation-parser) initialize-special-frames!) + (runtime uri) + (runtime rfc2822-headers) + (runtime http-syntax) + (runtime html-form-codec) + (optional (runtime win32-registry)) + (optional (runtime ffi)) + (runtime save/restore) + (runtime structure-parser) + (runtime swank) + (runtime stack-sampler) ;; Last since it turns on runtime handling of microcode errors. ((runtime microcode-errors) initialize-error-hooks!))) @@ -574,29 +574,29 @@ USA. (if obj (eval obj system-global-environment))) -(link-variables (->environment '(RUNTIME ENVIRONMENT)) 'PACKAGE-NAME-TAG - (->environment '(PACKAGE)) 'PACKAGE-NAME-TAG) +(link-variables (->environment '(runtime environment)) 'package-name-tag + (->environment '(package)) 'package-name-tag) (let ((roots (list->vector - ((lexical-reference (->environment '(RUNTIME COMPILER-INFO)) - 'WITH-DIRECTORY-REWRITING-RULE) + ((lexical-reference (->environment '(runtime compiler-info)) + 'with-directory-rewriting-rule) (working-directory-pathname) (pathname-as-directory "runtime") (lambda () (let ((fasload/update-debugging-info! - (lexical-reference (->environment '(RUNTIME COMPILER-INFO)) - 'FASLOAD/UPDATE-DEBUGGING-INFO!)) + (lexical-reference (->environment '(runtime compiler-info)) + 'fasload/update-debugging-info!)) (load/purification-root - (lexical-reference (->environment '(RUNTIME LOAD)) - 'LOAD/PURIFICATION-ROOT))) + (lexical-reference (->environment '(runtime load)) + 'load/purification-root))) (map (lambda (entry) (let ((object (cdr entry))) (fasload/update-debugging-info! object (car entry)) (load/purification-root object))) fasload-purification-queue))))))) - (lexical-assignment (->environment '(RUNTIME GARBAGE-COLLECTOR)) - 'GC-BOOT-LOADING? + (lexical-assignment (->environment '(runtime garbage-collector)) + 'gc-boot-loading? #f) (set! fasload-purification-queue) (newline console-output-port) @@ -609,7 +609,7 @@ USA. ) -(package/add-child! (find-package '()) 'USER user-initial-environment) +(package/add-child! (find-package '()) 'user user-initial-environment) ;; Might be better to do this sooner, to trap on floating-point ;; mistakes earlier in the cold load. (flo:set-environment! (flo:default-environment)) diff --git a/src/runtime/microcode-errors.scm b/src/runtime/microcode-errors.scm index 2a5349b71..84f9350f8 100644 --- a/src/runtime/microcode-errors.scm +++ b/src/runtime/microcode-errors.scm @@ -524,18 +524,18 @@ USA. (define (signal-variable-error continuation signal-reference signal-other) (let ((frame (continuation/first-subproblem continuation))) (case (frame/type frame) - ((EVAL-ERROR) + ((eval-error) (let ((expression (eval-frame/expression frame))) (if (scode-variable? expression) (signal-reference (eval-frame/environment frame) (scode-variable-name expression))))) - ((ASSIGNMENT-CONTINUE) + ((assignment-continue) (signal-other (eval-frame/environment frame) (scode-assignment-name (eval-frame/expression frame)))) - ((ACCESS-CONTINUE) + ((access-continue) (signal-reference (pop-return-frame/value continuation) (scode-access-name (eval-frame/expression frame)))) - ((INTERNAL-APPLY INTERNAL-APPLY-VAL) + ((internal-apply internal-apply-val) (let ((operator (apply-frame/operator frame))) (cond ((or (eq? (ucode-primitive lexical-reference) operator) (eq? (ucode-primitive safe-lexical-reference 2) @@ -551,13 +551,13 @@ USA. ((eq? (ucode-primitive lexical-unassigned?) operator) (signal-other (apply-frame/operand frame 0) (apply-frame/operand frame 1)))))) - ((COMPILER-REFERENCE-TRAP-RESTART - COMPILER-SAFE-REFERENCE-TRAP-RESTART) + ((compiler-reference-trap-restart + compiler-safe-reference-trap-restart) (signal-reference (reference-trap-frame/environment frame) (reference-trap-frame/name frame))) - ((COMPILER-ASSIGNMENT-TRAP-RESTART - COMPILER-UNASSIGNED?-TRAP-RESTART - COMPILER-OPERATOR-LOOKUP-TRAP-RESTART) + ((compiler-assignment-trap-restart + compiler-unassigned?-trap-restart + compiler-operator-lookup-trap-restart) (signal-other (reference-trap-frame/environment frame) (reference-trap-frame/name frame)))))) @@ -647,7 +647,7 @@ USA. (write-operator (access-condition condition 'operator) port) (write-string " is not implemented for this operating system." port)))) -(define-primitive-error 'UNDEFINED-PRIMITIVE-OPERATION +(define-primitive-error 'undefined-primitive-operation condition-type:unimplemented-primitive-for-os) (set! condition-type:compiled-code-error @@ -1025,17 +1025,17 @@ USA. (if (string=? "SIGFPE" name) ((case (and (string? code) (normalize-trap-code-name code)) - ((DIVIDE-BY-ZERO) signal-divide-by-zero) - ((FLOATING-POINT-DIVIDE-BY-ZERO) + ((divide-by-zero) signal-divide-by-zero) + ((floating-point-divide-by-zero) signal-floating-point-divide-by-zero) - ((INEXACT-RESULT) + ((inexact-result) signal-inexact-floating-point-result) - ((INTEGER-DIVIDE-BY-ZERO) + ((integer-divide-by-zero) signal-integer-divide-by-zero) - ((INVALID-OPERATION) + ((invalid-operation) signal-invalid-floating-point-operation) - ((OVERFLOW) signal-floating-point-overflow) - ((UNDERFLOW) signal-floating-point-underflow) + ((overflow) signal-floating-point-overflow) + ((underflow) signal-floating-point-underflow) (else signal-arithmetic-error)) k #f '()) (signal-hardware-trap k name code))))))))) diff --git a/src/runtime/microcode-tables.scm b/src/runtime/microcode-tables.scm index 2249cde61..ed5b1eecd 100644 --- a/src/runtime/microcode-tables.scm +++ b/src/runtime/microcode-tables.scm @@ -31,43 +31,43 @@ USA. (define (read-microcode-tables!) (set! identification-vector ((ucode-primitive microcode-identify))) - (set! errors-slot (fixed-object/name->code 'MICROCODE-ERRORS-VECTOR)) + (set! errors-slot (fixed-object/name->code 'microcode-errors-vector)) (set! identifications-slot - (fixed-object/name->code 'MICROCODE-IDENTIFICATION-VECTOR)) - (set! returns-slot (fixed-object/name->code 'MICROCODE-RETURNS-VECTOR)) + (fixed-object/name->code 'microcode-identification-vector)) + (set! returns-slot (fixed-object/name->code 'microcode-returns-vector)) (set! terminations-slot - (fixed-object/name->code 'MICROCODE-TERMINATIONS-VECTOR)) - (set! types-slot (fixed-object/name->code 'MICROCODE-TYPES-VECTOR)) - (set! non-object-slot (fixed-object/name->code 'NON-OBJECT)) - (set! system-call-names-slot (fixed-object/name->code 'SYSTEM-CALL-NAMES)) - (set! system-call-errors-slot (fixed-object/name->code 'SYSTEM-CALL-ERRORS)) + (fixed-object/name->code 'microcode-terminations-vector)) + (set! types-slot (fixed-object/name->code 'microcode-types-vector)) + (set! non-object-slot (fixed-object/name->code 'non-object)) + (set! system-call-names-slot (fixed-object/name->code 'system-call-names)) + (set! system-call-errors-slot (fixed-object/name->code 'system-call-errors)) (set! microcode-version-string - (microcode-identification-item 'MICROCODE-VERSION)) - (set! char:newline (microcode-identification-item 'NEWLINE-CHAR)) + (microcode-identification-item 'microcode-version)) + (set! char:newline (microcode-identification-item 'newline-char)) (set! microcode-id/floating-mantissa-bits - (microcode-identification-item 'FLONUM-MANTISSA-LENGTH)) + (microcode-identification-item 'flonum-mantissa-length)) (set! microcode-id/floating-epsilon - (microcode-identification-item 'FLONUM-EPSILON)) - (let ((name (microcode-identification-item 'OS-NAME-STRING))) + (microcode-identification-item 'flonum-epsilon)) + (let ((name (microcode-identification-item 'os-name-string))) (set! microcode-id/operating-system (intern name)) (set! microcode-id/operating-system-name name)) (set! microcode-id/operating-system-variant - (microcode-identification-item 'OS-VARIANT-STRING)) + (microcode-identification-item 'os-variant-string)) (set! microcode-id/stack-type - (let ((string (microcode-identification-item 'STACK-TYPE-STRING))) + (let ((string (microcode-identification-item 'stack-type-string))) (cond ((string? string) (intern string)) - ((not string) 'STANDARD) + ((not string) 'standard) (else (error "Illegal stack type:" string))))) (set! microcode-id/machine-type - (or (microcode-identification-item 'MACHINE-TYPE-STRING #f) + (or (microcode-identification-item 'machine-type-string #f) "unknown-machine")) (set! microcode-id/compiled-code-type - (intern (or (microcode-identification-item 'CC-ARCH-STRING #f) + (intern (or (microcode-identification-item 'cc-arch-string #f) "unknown"))) (set! microcode-id/tty-x-size - (microcode-identification-item 'CONSOLE-WIDTH)) + (microcode-identification-item 'console-width)) (set! microcode-id/tty-y-size - (microcode-identification-item 'CONSOLE-HEIGHT)) + (microcode-identification-item 'console-height)) unspecific) @@ -103,8 +103,8 @@ USA. (case (if (default-object? os-type) microcode-id/operating-system os-type) - ((NT) "w32") - ((UNIX) "unx") + ((nt) "w32") + ((unix) "unx") (else (error "Unknown operating system:" os-type)))) (define-integrable fixed-objects-slot 15) @@ -229,7 +229,7 @@ USA. (define (microcode-identification-vector-slot name #!optional error?) (let ((v (microcode-table-search identifications-slot name))) (if (and (not v) (if (default-object? error?) #t error?)) - (error:bad-range-argument name 'MICROCODE-IDENTIFICATION-VECTOR-SLOT)) + (error:bad-range-argument name 'microcode-identification-vector-slot)) v)) (define (microcode-identification-item name #!optional error?) @@ -279,16 +279,16 @@ USA. (vector-length (vector-ref (get-fixed-objects-vector) types-slot))) (define type-aliases - '((FALSE MANIFEST-VECTOR GLOBAL-ENVIRONMENT) - (PAIR LIST) - (FLONUM BIG-FLONUM) - (CONSTANT TRUE) - (RETURN-CODE RETURN-ADDRESS) - (BIGNUM BIG-FIXNUM) - (PROMISE DELAYED) - (FIXNUM ADDRESS POSITIVE-FIXNUM NEGATIVE-FIXNUM) - (STRING CHARACTER-STRING VECTOR-8B) - (HUNK3-A UNMARKED-HISTORY) - (TRIPLE HUNK3 HUNK3-B MARKED-HISTORY) - (REFERENCE-TRAP UNASSIGNED) - (RECNUM COMPLEX))) \ No newline at end of file + '((false manifest-vector global-environment) + (pair list) + (flonum big-flonum) + (constant true) + (return-code return-address) + (bignum big-fixnum) + (promise delayed) + (fixnum address positive-fixnum negative-fixnum) + (string character-string vector-8b) + (hunk3-a unmarked-history) + (triple hunk3 hunk3-b marked-history) + (reference-trap unassigned) + (recnum complex))) \ No newline at end of file diff --git a/src/runtime/msort.scm b/src/runtime/msort.scm index 1bb49fc22..2c3e90c7e 100644 --- a/src/runtime/msort.scm +++ b/src/runtime/msort.scm @@ -38,7 +38,7 @@ USA. (define (merge-sort! v pred) (if (not (vector? v)) - (error:wrong-type-argument v "vector" 'MERGE-SORT!)) + (error:wrong-type-argument v "vector" 'merge-sort!)) (let sort-subvector ((v v) (temp (vector-copy v)) diff --git a/src/runtime/numpar.scm b/src/runtime/numpar.scm index 2602d2f08..34fab3e20 100644 --- a/src/runtime/numpar.scm +++ b/src/runtime/numpar.scm @@ -71,9 +71,9 @@ USA. ((or (char=? #\x char) (char=? #\X char)) (do-radix 16)) ((or (char=? #\e char) (char=? #\E char)) - (do-exactness 'EXACT)) + (do-exactness 'exact)) ((or (char=? #\i char) (char=? #\I char)) - (do-exactness 'INEXACT)) + (do-exactness 'inexact)) (else #f)))))) (parse-top-level string start end exactness (or radix default-radix)))))) @@ -89,7 +89,7 @@ USA. ((char=? #\. char) (and (or (not radix) (fix:= 10 radix)) (parse-decimal-1 string start end - (or exactness 'IMPLICIT-INEXACT) #f))) + (or exactness 'implicit-inexact) #f))) ((char->digit char (or radix 10)) => (lambda (digit) (parse-integer string start end digit @@ -108,7 +108,7 @@ USA. ((char=? #\. char) (and (fix:= 10 radix) (parse-decimal-1 string start end - (or exactness 'IMPLICIT-INEXACT) sign))) + (or exactness 'implicit-inexact) sign))) ((i? char) (and (fix:= start end) (make-rectangular 0 (if (eq? #\- sign) -1 1)))) @@ -131,13 +131,13 @@ USA. integer 0 exactness sign) (parse-decimal-2 string start+1 end integer 0 - (or exactness 'IMPLICIT-INEXACT) + (or exactness 'implicit-inexact) sign)))) ((exponent-marker? char) (and (fix:= radix 10) (parse-exponent-1 string start+1 end integer 0 - (or exactness 'IMPLICIT-INEXACT) + (or exactness 'implicit-inexact) sign))) (else (parse-complex string start end @@ -158,7 +158,7 @@ USA. (integer (* integer radix) (* integer radix))) ((not (and (fix:< start end) (char=? #\# (string-ref string start)))) - (k start integer (or exactness 'IMPLICIT-INEXACT) #t)))) + (k start integer (or exactness 'implicit-inexact) #t)))) (else (k start integer exactness #f)))) (k start integer exactness #f)))) @@ -259,7 +259,7 @@ USA. (if (fix:< start end) (let ((char (string-ref string start)) (start+1 (fix:+ start 1)) - (exactness (if (eq? 'IMPLICIT-INEXACT exactness) #f exactness))) + (exactness (if (eq? 'implicit-inexact exactness) #f exactness))) (cond ((sign? char) (let ((imaginary (parse-top-level string start end exactness radix))) @@ -334,7 +334,7 @@ USA. (* (apply-sign sign integer) (expt 10 exponent)))) - (if (or (eq? 'INEXACT exactness) (eq? 'IMPLICIT-INEXACT exactness)) + (if (or (eq? 'inexact exactness) (eq? 'implicit-inexact exactness)) (let ((abs-exponent (if (< exponent 0) (- exponent) exponent)) (powers-of-10 exact-flonum-powers-of-10)) (define-integrable (finish-flonum x power-of-10) @@ -372,7 +372,7 @@ USA. number)) (define (apply-exactness exactness number) - (if (or (eq? 'INEXACT exactness) (eq? 'IMPLICIT-INEXACT exactness)) + (if (or (eq? 'inexact exactness) (eq? 'implicit-inexact exactness)) (exact->inexact number) number)) diff --git a/src/runtime/option.scm b/src/runtime/option.scm index d6c5e28b6..d6b7aff55 100644 --- a/src/runtime/option.scm +++ b/src/runtime/option.scm @@ -128,7 +128,7 @@ USA. (lambda () (load pathname environment - 'DEFAULT + 'default #t)))))))))) files) (flush-purification-queue!) diff --git a/src/runtime/ordvec.scm b/src/runtime/ordvec.scm index af41d1549..42fb027b4 100644 --- a/src/runtime/ordvec.scm +++ b/src/runtime/ordvec.scm @@ -126,7 +126,7 @@ USA. (if (fix:< low high) (let ((index (fix:quotient (fix:+ low high) 2))) (case (order key (item-key (vector-ref vector index))) - ((LESS) (loop low index)) - ((GREATER) (loop (fix:+ index 1) high)) + ((less) (loop low index)) + ((greater) (loop (fix:+ index 1) high)) (else (if-found index)))) (if-not-found low)))) \ No newline at end of file diff --git a/src/runtime/output-port.scm b/src/runtime/output-port.scm index f509b93ee..babe04778 100644 --- a/src/runtime/output-port.scm +++ b/src/runtime/output-port.scm @@ -56,35 +56,35 @@ USA. (unparse-object/top-level object port #t environment)) (define (output-port/x-size port) - (or (let ((operation (textual-port-operation port 'X-SIZE))) + (or (let ((operation (textual-port-operation port 'x-size))) (and operation (operation port))) 80)) (define (output-port/y-size port) - (let ((operation (textual-port-operation port 'Y-SIZE))) + (let ((operation (textual-port-operation port 'y-size))) (and operation (operation port)))) (define (output-port/column port) - (let ((operation (textual-port-operation port 'OUTPUT-COLUMN))) + (let ((operation (textual-port-operation port 'output-column))) (and operation (operation port)))) (define (output-port/bytes-written port) - (let ((operation (textual-port-operation port 'BYTES-WRITTEN))) + (let ((operation (textual-port-operation port 'bytes-written))) (and operation (operation port)))) (define (output-port/synchronize-output port) - (let ((operation (textual-port-operation port 'SYNCHRONIZE-OUTPUT))) + (let ((operation (textual-port-operation port 'synchronize-output))) (if operation (operation port)))) ;;;; High level (define (write-char char #!optional port) - (let ((port (optional-output-port port 'WRITE-CHAR))) + (let ((port (optional-output-port port 'write-char))) (if (let ((n (output-port/write-char port char))) (and n (fix:> n 0))) @@ -125,24 +125,24 @@ USA. (optional-output-port port 'synchronize-output-port))) (define (fresh-line #!optional port) - (let ((port (optional-output-port port 'FRESH-LINE))) + (let ((port (optional-output-port port 'fresh-line))) (if (let ((n (output-port/fresh-line port))) (and n (fix:> n 0))) (output-port/discretionary-flush port)))) (define (display object #!optional port environment) - (let ((port (optional-output-port port 'DISPLAY))) + (let ((port (optional-output-port port 'display))) (unparse-object/top-level object port #f environment) (output-port/discretionary-flush port))) (define (write object #!optional port environment) - (let ((port (optional-output-port port 'WRITE))) + (let ((port (optional-output-port port 'write))) (output-port/write-object port object environment) (output-port/discretionary-flush port))) (define (write-line object #!optional port environment) - (let ((port (optional-output-port port 'WRITE-LINE))) + (let ((port (optional-output-port port 'write-line))) (output-port/write-object port object environment) (output-port/write-char port #\newline) (output-port/discretionary-flush port))) @@ -156,8 +156,8 @@ USA. (operation port) (output-port/discretionary-flush port))))))) -(define beep (wrap-custom-operation-0 'BEEP)) -(define clear (wrap-custom-operation-0 'CLEAR)) +(define beep (wrap-custom-operation-0 'beep)) +(define clear (wrap-custom-operation-0 'clear)) (define (optional-output-port port caller) (let ((port (if (default-object? port) (current-output-port) port))) @@ -172,12 +172,12 @@ USA. left-margin col-sep right-margin) (if (not (list-of-type? strings string?)) (error:wrong-type-argument strings "list of strings" - 'WRITE-STRINGS-IN-COLUMNS)) - (guarantee textual-output-port? port 'WRITE-STRINGS-IN-COLUMNS) - (guarantee exact-positive-integer? min-minor 'WRITE-STRINGS-IN-COLUMNS) - (guarantee string? left-margin 'WRITE-STRINGS-IN-COLUMNS) - (guarantee string? col-sep 'WRITE-STRINGS-IN-COLUMNS) - (guarantee string? right-margin 'WRITE-STRINGS-IN-COLUMNS) + 'write-strings-in-columns)) + (guarantee textual-output-port? port 'write-strings-in-columns) + (guarantee exact-positive-integer? min-minor 'write-strings-in-columns) + (guarantee string? left-margin 'write-strings-in-columns) + (guarantee string? col-sep 'write-strings-in-columns) + (guarantee string? right-margin 'write-strings-in-columns) (let ((n-strings (length strings)) (max-width (output-port/x-size port)) (lm-width (string-length left-margin)) @@ -297,13 +297,13 @@ USA. (if (and (not (list-of-type? strings string?)) (pair? strings)) (error:wrong-type-argument strings "non-empty list of strings" - 'WRITE-STRINGS-IN-PARAGRAPH)) - (guarantee textual-output-port? port 'WRITE-STRINGS-IN-PARAGRAPH) - (guarantee exact-positive-integer? width 'WRITE-STRINGS-IN-PARAGRAPH) - (guarantee exact-nonnegative-integer? indent 'WRITE-STRINGS-IN-PARAGRAPH) - (guarantee exact-nonnegative-integer? first 'WRITE-STRINGS-IN-PARAGRAPH) + 'write-strings-in-paragraph)) + (guarantee textual-output-port? port 'write-strings-in-paragraph) + (guarantee exact-positive-integer? width 'write-strings-in-paragraph) + (guarantee exact-nonnegative-integer? indent 'write-strings-in-paragraph) + (guarantee exact-nonnegative-integer? first 'write-strings-in-paragraph) (if (< width (+ indent first (string-length (car strings)))) - (error:bad-range-argument width 'WRITE-STRINGS-IN-PARAGRAPH)) + (error:bad-range-argument width 'write-strings-in-paragraph)) (fresh-line port) (write-spaces indent port) diff --git a/src/runtime/parser-buffer.scm b/src/runtime/parser-buffer.scm index 6566fe473..34793b468 100644 --- a/src/runtime/parser-buffer.scm +++ b/src/runtime/parser-buffer.scm @@ -127,8 +127,8 @@ USA. (parser-buffer-base-offset buffer)))) (if (<= (parser-buffer-start buffer) p* (parser-buffer-index buffer)) p* - (error:bad-range-argument p 'POINTER->INDEX))) - (error:wrong-type-argument p "parser-buffer pointer" 'POINTER->INDEX))) + (error:bad-range-argument p 'pointer->index))) + (error:wrong-type-argument p "parser-buffer pointer" 'pointer->index))) (define (parser-buffer-position-string object) (let ((pointer @@ -171,7 +171,7 @@ USA. (define (parser-buffer-ref buffer index) (if (not (index-fixnum? index)) - (error:wrong-type-argument index "index" 'PARSER-BUFFER-REF)) + (error:wrong-type-argument index "index" 'parser-buffer-ref)) (and (guarantee-buffer-chars buffer (fix:+ index 1)) (string-ref (parser-buffer-string buffer) (fix:+ (parser-buffer-index buffer) index)))) @@ -361,7 +361,7 @@ USA. (%grow-buffer string end min-end)))) (let ((port (parser-buffer-port buffer)) (string (parser-buffer-string buffer))) - (with-input-port-blocking-mode port 'BLOCKING + (with-input-port-blocking-mode port 'blocking (lambda () (let loop ((end end)) (if (fix:< end min-end) diff --git a/src/runtime/parser.scm b/src/runtime/parser.scm index 0ab805c47..d65c0409f 100644 --- a/src/runtime/parser.scm +++ b/src/runtime/parser.scm @@ -910,7 +910,7 @@ USA. ;;; Look for keyword-style: prefix or keyword-style: suffix (define (process-keyword-attribute file-attribute-alist db) (let ((keyword-entry - (lookup-file-attribute file-attribute-alist 'KEYWORD-STYLE))) + (lookup-file-attribute file-attribute-alist 'keyword-style))) (if (pair? keyword-entry) (let ((value (cdr keyword-entry))) (cond ((and (symbol? value) @@ -930,7 +930,7 @@ USA. (define (process-mode-attribute file-attribute-alist db) (declare (ignore db)) (let ((mode-entry - (lookup-file-attribute file-attribute-alist 'MODE))) + (lookup-file-attribute file-attribute-alist 'mode))) (if (pair? mode-entry) (let ((value (cdr mode-entry))) (if (or (not (symbol? value)) @@ -946,7 +946,7 @@ USA. ;; the attribute and the value don't matter. (define (process-studly-case-attribute file-attribute-alist db) (let ((studly-case-entry - (lookup-file-attribute file-attribute-alist 'STUDLY-CASE))) + (lookup-file-attribute file-attribute-alist 'studly-case))) (if (pair? studly-case-entry) (let ((value (cdr studly-case-entry))) (cond ((or (eq? value #t) @@ -971,7 +971,7 @@ USA. (warn "Unrecognized value for sTuDly-case" value))))))) (define-deferred condition-type:parse-error - (make-condition-type 'PARSE-ERROR condition-type:error '() + (make-condition-type 'parse-error condition-type:error '() (lambda (condition port) condition (write-string "Anonymous parsing error." port)))) diff --git a/src/runtime/pgsql.scm b/src/runtime/pgsql.scm index 658b17145..e6f23affb 100644 --- a/src/runtime/pgsql.scm +++ b/src/runtime/pgsql.scm @@ -71,46 +71,46 @@ USA. (lambda (form environment) environment (if (syntax-match? '(identifier * identifier) (cdr form)) - `(BEGIN + `(begin ,@(let loop ((names (cddr form)) (index 0)) (if (pair? names) - `((DEFINE ,(car names) ,index) + `((define ,(car names) ,index) ,@(loop (cdr names) (+ index 1))) '())) - (DEFINE ,(cadr form) '#(,@(cddr form)))) + (define ,(cadr form) '#(,@(cddr form)))) (ill-formed-syntax form))))) (define (index->name index enum) - (guarantee index-fixnum? index 'INDEX->NAME) + (guarantee index-fixnum? index 'index->name) (if (not (fix:< index (vector-length enum))) - (error:bad-range-argument index 'INDEX->NAME)) + (error:bad-range-argument index 'index->name)) (vector-ref enum index)) (define-enum connection-status - PGSQL-CONNECTION-OK - PGSQL-CONNECTION-BAD - PGSQL-CONNECTION-STARTED - PGSQL-CONNECTION-MADE - PGSQL-CONNECTION-AWAITING-RESPONSE - PGSQL-CONNECTION-AUTH-OK - PGSQL-CONNECTION-SETENV) + pgsql-connection-ok + pgsql-connection-bad + pgsql-connection-started + pgsql-connection-made + pgsql-connection-awaiting-response + pgsql-connection-auth-ok + pgsql-connection-setenv) (define-enum postgres-polling-status - PGSQL-POLLING-FAILED - PGSQL-POLLING-READING - PGSQL-POLLING-WRITING - PGSQL-POLLING-OK - PGSQL-POLLING-ACTIVE) + pgsql-polling-failed + pgsql-polling-reading + pgsql-polling-writing + pgsql-polling-ok + pgsql-polling-active) (define-enum exec-status - PGSQL-EMPTY-QUERY - PGSQL-COMMAND-OK - PGSQL-TUPLES-OK - PGSQL-COPY-OUT - PGSQL-COPY-IN - PGSQL-BAD-RESPONSE - PGSQL-NONFATAL-ERROR - PGSQL-FATAL-ERROR) + pgsql-empty-query + pgsql-command-ok + pgsql-tuples-ok + pgsql-copy-out + pgsql-copy-in + pgsql-bad-response + pgsql-nonfatal-error + pgsql-fatal-error) (define pgsql-initialized? #f) (define connections) @@ -126,20 +126,20 @@ USA. (if (syntax-match? '(symbol expression) (cdr form)) (let ((type (cadr form))) (let ((type? (symbol type '?)) - (guarantee-type (symbol 'GUARANTEE- type)) - (error:not-type (symbol 'ERROR:NOT- type)) - (guarantee-valid-type (symbol 'GUARANTEE-VALID- type)) - (type-handle (symbol type '-HANDLE))) - `(BEGIN - (DEFINE-INTEGRABLE (,guarantee-type OBJECT CALLER) - (IF (NOT (,type? OBJECT)) - (,error:not-type OBJECT CALLER))) - (DEFINE (,error:not-type OBJECT CALLER) - (ERROR:WRONG-TYPE-ARGUMENT OBJECT ,(caddr form) CALLER)) - (DEFINE-INTEGRABLE (,guarantee-valid-type OBJECT CALLER) - (IF (AND (,type? OBJECT) (,type-handle OBJECT)) - (,type-handle OBJECT) - (,error:not-type OBJECT CALLER)))))) + (guarantee-type (symbol 'guarantee- type)) + (error:not-type (symbol 'error:not- type)) + (guarantee-valid-type (symbol 'guarantee-valid- type)) + (type-handle (symbol type '-handle))) + `(begin + (define-integrable (,guarantee-type object caller) + (if (not (,type? object)) + (,error:not-type object caller))) + (define (,error:not-type object caller) + (error:wrong-type-argument object ,(caddr form) caller)) + (define-integrable (,guarantee-valid-type object caller) + (if (and (,type? object) (,type-handle object)) + (,type-handle object) + (,error:not-type object caller)))))) (ill-formed-syntax form))))) (define-guarantee connection "PostgreSQL connection") @@ -169,35 +169,35 @@ USA. (error "This Scheme system was built without PostgreSQL support."))) (define condition-type:pgsql-error - (make-condition-type 'PGSQL-ERROR condition-type:error '() + (make-condition-type 'pgsql-error condition-type:error '() (lambda (condition port) condition (write-string "Unknown PostgreSQL error." port)))) (define condition-type:pgsql-connection-error - (make-condition-type 'PGSQL-CONNECTION-ERROR condition-type:pgsql-error - '(MESSAGE) + (make-condition-type 'pgsql-connection-error condition-type:pgsql-error + '(message) (lambda (condition port) (write-string "Unable to connect to PostgreSQL server" port) - (write-message (access-condition condition 'MESSAGE) port)))) + (write-message (access-condition condition 'message) port)))) (define error:pgsql-connection (condition-signaller condition-type:pgsql-connection-error - '(MESSAGE) + '(message) standard-error-handler)) (define condition-type:pgsql-query-error - (make-condition-type 'PGSQL-QUERY-ERROR condition-type:pgsql-error - '(QUERY RESULT) + (make-condition-type 'pgsql-query-error condition-type:pgsql-error + '(query result) (lambda (condition port) (write-string "PostgreSQL query error" port) (write-message - (pgsql-result-error-message (access-condition condition 'RESULT)) + (pgsql-result-error-message (access-condition condition 'result)) port)))) (define error:pgsql-query (condition-signaller condition-type:pgsql-query-error - '(QUERY RESULT) + '(query result) standard-error-handler)) (define (write-message string port) @@ -234,7 +234,7 @@ USA. (lambda (handle) (cond ((= 0 handle) (error:pgsql-connection #f)) - ((= PGSQL-CONNECTION-BAD (pq-status handle)) + ((= pgsql-connection-bad (pq-status handle)) (let ((msg (pq-error-message handle))) (pq-finish handle) (error:pgsql-connection msg)))) @@ -256,11 +256,11 @@ USA. unspecific)))) (define (pgsql-conn-open? connection) - (guarantee-connection connection 'PGSQL-CONN-OPEN?) + (guarantee-connection connection 'pgsql-conn-open?) (if (connection-handle connection) #t #f)) (define-integrable (connection->handle connection) - (guarantee-valid-connection connection 'CONNECTION->HANDLE)) + (guarantee-valid-connection connection 'connection->handle)) (define (poll-pgsql-conn connection) (index->name (pq-connect-poll (connection->handle connection)) @@ -276,8 +276,8 @@ USA. environment (if (syntax-match? '(symbol) (cdr form)) (let ((field (cadr form))) - `(DEFINE (,(symbol 'PGSQL-CONN- field) OBJECT) - (,(symbol 'PQ- field) (CONNECTION->HANDLE OBJECT)))) + `(define (,(symbol 'pgsql-conn- field) object) + (,(symbol 'pq- field) (connection->handle object)))) (ill-formed-syntax form))))) (define-connection-accessor db) @@ -317,7 +317,7 @@ USA. (pq-unescape-bytea string)) (define (exec-pgsql-query connection query) - (guarantee string? query 'EXEC-PGSQL-QUERY) + (guarantee string? query 'exec-pgsql-query) (let ((result (let ((handle (connection->handle connection))) (make-gc-finalized-object @@ -329,10 +329,10 @@ USA. (error "Unable to execute PostgreSQL query:" query)) (make-result result-handle)))))) (if (not (memq (pgsql-result-status result) - '(PGSQL-COMMAND-OK - PGSQL-TUPLES-OK - PGSQL-COPY-OUT - PGSQL-COPY-IN))) + '(pgsql-command-ok + pgsql-tuples-ok + pgsql-copy-out + pgsql-copy-in))) (error:pgsql-query query result)) result)) @@ -348,7 +348,7 @@ USA. (make-result result-handle))))) (define-integrable (result->handle result) - (guarantee-valid-result result 'RESULT->HANDLE)) + (guarantee-valid-result result 'result->handle)) (define-syntax define-result-accessor (sc-macro-transformer @@ -356,8 +356,8 @@ USA. environment (if (syntax-match? '(symbol) (cdr form)) (let ((field (cadr form))) - `(DEFINE (,(symbol 'PGSQL- field) OBJECT) - (,(symbol 'PQ- field) (RESULT->HANDLE OBJECT)))) + `(define (,(symbol 'pgsql- field) object) + (,(symbol 'pq- field) (result->handle object)))) (ill-formed-syntax form))))) (define-result-accessor result-error-message) diff --git a/src/runtime/poplat.scm b/src/runtime/poplat.scm index 94e2b94bc..f5bdca0ae 100644 --- a/src/runtime/poplat.scm +++ b/src/runtime/poplat.scm @@ -38,10 +38,10 @@ USA. (define (initialize-unparser!) (unparser/set-tagged-pair-method! population-tag - (standard-unparser-method 'POPULATION #f))) + (standard-unparser-method 'population #f))) -(define bogus-false '(BOGUS-FALSE)) -(define population-tag '(POPULATION)) +(define bogus-false '(bogus-false)) +(define population-tag '(population)) (define-integrable (canonicalize object) (if (eq? object false) bogus-false object)) diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm index 19e2a0acb..5bed211dd 100644 --- a/src/runtime/pp.scm +++ b/src/runtime/pp.scm @@ -49,7 +49,7 @@ USA. ;; NAMED: just name if the procedure is a named lambda, like FULL if unnamed ;; SHORT: procedures appear in #[...] unparser syntax (set! param:pp-arity-dispatched-procedure-style - (make-settable-parameter 'FULL)) + (make-settable-parameter 'full)) (set! param:pp-auto-highlighter (make-settable-parameter #f)) (set! param:pp-avoid-circularity? (make-settable-parameter #f)) (set! param:pp-default-as-code? (make-settable-parameter #t)) @@ -70,19 +70,19 @@ USA. (set! print-case-expression (special-printer kernel/print-case-expression)) (set! code-dispatch-list (make-unsettable-parameter - `((COND . ,forced-indentation) - (CASE . ,print-case-expression) - (IF . ,forced-indentation) - (OR . ,forced-indentation) - (AND . ,forced-indentation) - (LET . ,print-let-expression) - (LET* . ,print-let-expression) - (LETREC . ,print-let-expression) - (FLUID-LET . ,print-let-expression) - (DEFINE . ,print-procedure) - (DEFINE-INTEGRABLE . ,print-procedure) - (LAMBDA . ,print-procedure) - (NAMED-LAMBDA . ,print-procedure)))) + `((cond . ,forced-indentation) + (case . ,print-case-expression) + (if . ,forced-indentation) + (or . ,forced-indentation) + (and . ,forced-indentation) + (let . ,print-let-expression) + (let* . ,print-let-expression) + (letrec . ,print-let-expression) + (fluid-let . ,print-let-expression) + (define . ,print-procedure) + (define-integrable . ,print-procedure) + (lambda . ,print-procedure) + (named-lambda . ,print-procedure)))) (set! dispatch-list (make-unsettable-parameter (code-dispatch-list))) (set! dispatch-default (make-unsettable-parameter print-combination)) (set! cocked-object (generate-uninterned-symbol)) @@ -193,18 +193,18 @@ USA. (define-pp-describer weak-pair? (lambda (wp) - `((WEAK-CAR ,(weak-car wp)) - (WEAK-CDR ,(weak-cdr wp))))) + `((weak-car ,(weak-car wp)) + (weak-cdr ,(weak-cdr wp))))) (define-pp-describer cell? (lambda (cell) - `((CONTENTS ,(cell-contents cell))))))) + `((contents ,(cell-contents cell))))))) (define (unsyntax-entity object) (define (unsyntax-entry procedure) (case (get-param:pp-arity-dispatched-procedure-style) - ((FULL) (unsyntax-entity procedure)) - ((NAMED) + ((full) (unsyntax-entity procedure)) + ((named) (let ((text (unsyntax-entity procedure))) (if (and (pair? text) (eq? (car text) 'named-lambda) @@ -212,7 +212,7 @@ USA. (pair? (cadr text))) (caadr text) text))) - ((SHORT) procedure) + ((short) procedure) (else procedure))) (cond ((arity-dispatched-procedure? object) (let* ((default (entity-procedure object)) @@ -227,9 +227,9 @@ USA. (cdr cases))) (else (loop (+ i 1) tests (cdr cases))))))) - `(CASE NUMBER-OF-ARGUMENTS + `(case number-of-arguments ,@cases* - (ELSE + (else ,(unsyntax-entry default))))) ((and (procedure? object) (procedure-lambda object)) => unsyntax) @@ -250,14 +250,14 @@ USA. (unsyntax object)))) (if (and as-code? (pair? sexp) - (eq? (car sexp) 'NAMED-LAMBDA) + (eq? (car sexp) 'named-lambda) (get-param:pp-named-lambda->define?)) - (if (and (eq? 'LAMBDA + (if (and (eq? 'lambda (get-param:pp-named-lambda->define?)) (pair? (cdr sexp)) (pair? (cadr sexp))) - `(LAMBDA ,(cdadr sexp) ,@(cddr sexp)) - `(DEFINE ,@(cdr sexp))) + `(lambda ,(cdadr sexp) ,@(cddr sexp)) + `(define ,@(cdr sexp))) sexp)) (if (default-object? port) (current-output-port) port) as-code? @@ -276,9 +276,9 @@ USA. (object #f read-only #t) (start-string "*=>" read-only #t) (end-string "<=*" read-only #t) - (as-code? 'DEFAULT read-only #t) - (depth-limit 'DEFAULT read-only #t) - (breadth-limit 'DEFAULT read-only #t)) + (as-code? 'default read-only #t) + (depth-limit 'default read-only #t) + (breadth-limit 'default read-only #t)) (define (with-highlight-strings-printed pph thunk) (let ((print-string @@ -392,7 +392,7 @@ USA. (let ((handler (let ((as-code? (pph/as-code? highlight)) (currently-as-code? (not (null? (dispatch-list))))) - (cond ((or (eq? as-code? 'DEFAULT) + (cond ((or (eq? as-code? 'default) (eq? as-code? currently-as-code?)) print-node) (as-code? @@ -846,16 +846,16 @@ USA. (let ((dl (pph/depth-limit object))) (parameterize* (list (cons param:unparser-list-breadth-limit (let ((bl (pph/breadth-limit object))) - (if (eq? bl 'DEFAULT) + (if (eq? bl 'default) (param:unparser-list-breadth-limit) bl))) (cons param:unparser-list-depth-limit - (if (eq? dl 'DEFAULT) + (if (eq? dl 'default) (param:unparser-list-depth-limit) dl))) (lambda () (numerical-walk (pph/object object) - (if (eq? dl 'DEFAULT) + (if (eq? dl 'default) list-depth 0)))))) @@ -895,7 +895,7 @@ USA. prefix (numerical-walk-terminating (cadr object) - (advance half-pointer (update-queue queue '(CDR CAR))) + (advance half-pointer (update-queue queue '(cdr car))) list-depth)) (walk-pair-terminating object half-pointer/queue list-depth)))) @@ -947,7 +947,7 @@ USA. (let ((half-pointer/queue (advance (car half-pointer/queue) - (update-queue (cdr half-pointer/queue) '(CAR))))) + (update-queue (cdr half-pointer/queue) '(car))))) (if (eq? (car half-pointer/queue) (car pair)) (circularity-string (cdr half-pointer/queue)) (numerical-walk-terminating @@ -957,7 +957,7 @@ USA. (let ((half-pointer/queue (advance (car half-pointer/queue) - (update-queue (cdr half-pointer/queue) '(CAR))))) + (update-queue (cdr half-pointer/queue) '(car))))) (if (eq? (car half-pointer/queue) (car pair)) (circularity-string (cdr half-pointer/queue)) (numerical-walk-terminating @@ -968,7 +968,7 @@ USA. (let ((half-pointer/queue (advance (car half-pointer/queue) - (update-queue (cdr half-pointer/queue) '(CDR))))) + (update-queue (cdr half-pointer/queue) '(cdr))))) (if (eq? (car half-pointer/queue) (cdr pair)) (make-singleton-list-node (string-append @@ -988,7 +988,7 @@ USA. (advance (car half-pointer/queue) (update-queue - (cdr half-pointer/queue) '(CDR))))) + (cdr half-pointer/queue) '(cdr))))) (if (eq? (car half-pointer/queue) (cdr pair)) (circularity-string (cdr half-pointer/queue)) (numerical-walk-terminating @@ -1055,9 +1055,9 @@ USA. (define (update-queue queue command-list) (define (uq-iter queue command-list) (cond ((null? command-list) queue) - ((eq? (car command-list) 'CAR) + ((eq? (car command-list) 'car) (uq-iter (add-car queue) (cdr command-list))) - ((eq? (car command-list) 'CDR) + ((eq? (car command-list) 'cdr) (uq-iter (add-cdr queue) (cdr command-list))) (else (uq-iter (add-vector-ref (car command-list) queue) diff --git a/src/runtime/prgcop.scm b/src/runtime/prgcop.scm index a2beac791..2c5a715e3 100644 --- a/src/runtime/prgcop.scm +++ b/src/runtime/prgcop.scm @@ -33,24 +33,24 @@ USA. (object-new-type primitive-object-new-type 2)) (define (initialize-package!) - (set! *copy-constants?* (make-unsettable-parameter 'UNBOUND)) - (set! *object-copies* (make-unsettable-parameter 'UNBOUND)) + (set! *copy-constants?* (make-unsettable-parameter 'unbound)) + (set! *object-copies* (make-unsettable-parameter 'unbound)) (set! copier/scode-walker (make-scode-walker copy-constant - `((ACCESS ,(%copy-pair (ucode-type ACCESS))) - (ASSIGNMENT ,(%copy-triple (ucode-type ASSIGNMENT))) - (COMBINATION ,copy-COMBINATION-object) - (COMMENT ,copy-COMMENT-object) - (CONDITIONAL ,(%copy-triple (ucode-type CONDITIONAL))) - (DEFINITION ,(%copy-pair (ucode-type DEFINITION))) - (DELAY ,(%copy-pair (ucode-type DELAY))) - (DISJUNCTION ,(%copy-pair (ucode-type DISJUNCTION))) - (LAMBDA ,copy-LAMBDA-object) - (QUOTATION ,(%copy-pair (ucode-type QUOTATION))) - (SEQUENCE ,copy-SEQUENCE-object) - (THE-ENVIRONMENT ,copy-constant) - (VARIABLE ,copy-VARIABLE-object)))) + `((access ,(%copy-pair (ucode-type access))) + (assignment ,(%copy-triple (ucode-type assignment))) + (combination ,copy-combination-object) + (comment ,copy-comment-object) + (conditional ,(%copy-triple (ucode-type conditional))) + (definition ,(%copy-pair (ucode-type definition))) + (delay ,(%copy-pair (ucode-type delay))) + (disjunction ,(%copy-pair (ucode-type disjunction))) + (lambda ,copy-lambda-object) + (quotation ,(%copy-pair (ucode-type quotation))) + (sequence ,copy-sequence-object) + (the-environment ,copy-constant) + (variable ,copy-variable-object)))) unspecific) ;;;; Top level @@ -63,7 +63,7 @@ USA. (define copier/scode-walker) (define-integrable (make-object-association-table) - (list '*OBJECT-COPIES*)) + (list '*object-copies*)) (define-integrable (object-association object) (assq object (cdr (*object-copies*)))) @@ -114,12 +114,12 @@ USA. (boolean? obj) (null? obj) (char? obj) - (object-type? (ucode-type REFERENCE-TRAP) obj)) + (object-type? (ucode-type reference-trap) obj)) obj) ((pair? obj) - (%%copy-pair (ucode-type PAIR) obj)) + (%%copy-pair (ucode-type pair) obj)) ((vector? obj) - (%%copy-vector (ucode-type VECTOR) obj)) + (%%copy-vector (ucode-type vector) obj)) ((string? obj) (let ((copy (string-copy obj))) (add-association! obj copy) @@ -149,7 +149,7 @@ USA. (%copy-compiled-code-block obj)))) (define (%copy-compiled-code-block obj) - (let* ((new (vector-copy (object-new-type (ucode-type VECTOR) obj))) + (let* ((new (vector-copy (object-new-type (ucode-type vector) obj))) (typed (object-new-type (ucode-type compiled-code-block) new)) (len (vector-length new))) ((ucode-primitive declare-compiled-code-block 1) typed) @@ -210,14 +210,14 @@ USA. (let ((association (object-association vec))) (if association (cdr association) - (%%copy-vector (ucode-type VECTOR) vec)))) + (%%copy-vector (ucode-type vector) vec)))) (define ((%copy-vector type) obj) (%%copy-vector type obj)) (define (%%copy-vector type obj) (let* ((new (vector-copy - (object-new-type (ucode-type VECTOR) obj))) + (object-new-type (ucode-type vector) obj))) (typed (object-new-type type new)) (len (vector-length new))) (add-association! obj typed) @@ -226,17 +226,17 @@ USA. (vector-set! new i (copy-object (vector-ref new i)))) typed)) -(define (copy-SEQUENCE-object obj) - (if (object-type? (ucode-type SEQUENCE) obj) - (%%copy-pair (ucode-type SEQUENCE) obj) - (error "copy-SEQUENCE-object: Unknown type" obj))) +(define (copy-sequence-object obj) + (if (object-type? (ucode-type sequence) obj) + (%%copy-pair (ucode-type sequence) obj) + (error "copy-sequence-object: Unknown type" obj))) -(define (copy-COMBINATION-object obj) +(define (copy-combination-object obj) (make-scode-combination (copy-object (scode-combination-operator obj)) (map copy-object (scode-combination-operands obj)))) -(define (copy-LAMBDA-object obj) +(define (copy-lambda-object obj) (cond ((object-type? (ucode-type lambda) obj) (%%copy-pair (ucode-type lambda) obj)) ((object-type? (ucode-type extended-lambda) obj) @@ -244,21 +244,21 @@ USA. ((object-type? (ucode-type lexpr) obj) (%%copy-pair (ucode-type lexpr) obj)) (else - (error "COPY-LAMBDA-object: Unknown type" obj)))) + (error "copy-lambda-object: Unknown type" obj)))) -(define (copy-VARIABLE-object obj) +(define (copy-variable-object obj) (let ((var (make-scode-variable (scode-variable-name obj)))) (add-association! obj var) var)) -(define (copy-COMMENT-object obj) +(define (copy-comment-object obj) (let ((the-text (scode-comment-text obj))) (if (not (dbg-info-vector? the-text)) - (%%copy-pair (ucode-type COMMENT) obj) + (%%copy-pair (ucode-type comment) obj) (let ((the-car (system-pair-car obj)) (the-cdr (system-pair-cdr obj))) (let* ((new (cons the-car the-cdr)) - (typed (object-new-type (ucode-type COMMENT) new))) + (typed (object-new-type (ucode-type comment) new))) (add-association! obj typed) (let ((text-copy (copy-dbg-info-vector the-text))) (set-car! new (if (eq? the-car the-text) @@ -274,7 +274,7 @@ USA. (cond (association (cdr association)) ((vector? obj) - (%%copy-vector (ucode-type VECTOR) obj)) + (%%copy-vector (ucode-type vector) obj)) ((pair? obj) ;; Guarantee that top-level vectors are copied. (for-each (lambda (element) diff --git a/src/runtime/primitive-arithmetic.scm b/src/runtime/primitive-arithmetic.scm index 791841809..7f07d52c8 100644 --- a/src/runtime/primitive-arithmetic.scm +++ b/src/runtime/primitive-arithmetic.scm @@ -221,13 +221,13 @@ USA. (cond ((flo:< x y) x) ((flo:> x y) y) ((flo:= x y) x) - (else (error:bad-range-argument (if (flo:finite? x) x y) 'FLO:MIN)))) + (else (error:bad-range-argument (if (flo:finite? x) x y) 'flo:min)))) (define (flo:max x y) (cond ((flo:< x y) y) ((flo:> x y) x) ((flo:= x y) y) - (else (error:bad-range-argument (if (flo:finite? x) x y) 'FLO:MAX)))) + (else (error:bad-range-argument (if (flo:finite? x) x y) 'flo:max)))) ;;; XXX FLO:FINITE?, FLO:NAN?, FLO:EQV?, &c., are cute, but should be ;;; replaced by primitives. @@ -250,7 +250,7 @@ USA. ((ucode-primitive integer->flonum 2) n #b10)) (define (->flonum x) - (guarantee real? x '->FLONUM) + (guarantee real? x '->flonum) (exact->inexact (real-part x))) ;;;; Exact integers diff --git a/src/runtime/primitive-io.scm b/src/runtime/primitive-io.scm index 8d5308ea8..d8c60fc8f 100644 --- a/src/runtime/primitive-io.scm +++ b/src/runtime/primitive-io.scm @@ -562,9 +562,9 @@ USA. (define (encode-select-registry-mode mode) (case mode - ((READ) 1) - ((WRITE) 2) - ((READ/WRITE) 3) + ((read) 1) + ((write) 2) + ((read/write) 3) (else (error:bad-range-argument mode 'encode-select-registry-mode)))) (define (decode-select-registry-mode mode) diff --git a/src/runtime/procedure.scm b/src/runtime/procedure.scm index 9a8ce1c47..41536af7e 100644 --- a/src/runtime/procedure.scm +++ b/src/runtime/procedure.scm @@ -47,22 +47,22 @@ USA. (lambda (procedure) procedure #f) %compound-procedure-lambda compiled-procedure/lambda - 'PROCEDURE-LAMBDA)) + 'procedure-lambda)) (define (procedure-environment procedure) (discriminate-procedure procedure (lambda (procedure) (error:bad-range-argument procedure - 'PROCEDURE-ENVIRONMENT)) + 'procedure-environment)) %compound-procedure-environment compiled-procedure/environment - 'PROCEDURE-ENVIRONMENT)) + 'procedure-environment)) (define (procedure-components procedure receiver) (discriminate-procedure procedure (lambda (procedure) (error:bad-range-argument procedure - 'PROCEDURE-COMPONENTS)) + 'procedure-components)) (lambda (procedure) (receiver (%compound-procedure-lambda procedure) @@ -71,7 +71,7 @@ USA. (receiver (compiled-procedure/lambda procedure) (compiled-procedure/environment procedure))) - 'PROCEDURE-COMPONENTS)) + 'procedure-components)) (declare (integrate-operator discriminate-procedure)) (define (discriminate-procedure procedure if-primitive if-compound if-compiled @@ -131,7 +131,7 @@ USA. (loop (entity-procedure p) (fix:+ e 1)))) (else (error:wrong-type-argument procedure "procedure" - 'PROCEDURE-ARITY))))) + 'procedure-arity))))) (define (procedure-arity-valid? procedure arity) (procedure-arity<= arity (procedure-arity procedure))) @@ -160,17 +160,17 @@ USA. (error:bad-range-argument object caller))) (define (make-procedure-arity min #!optional max simple-ok?) - (guarantee index-fixnum? min 'MAKE-PROCEDURE-ARITY) + (guarantee index-fixnum? min 'make-procedure-arity) (let ((max (if (default-object? max) min (begin (if max (begin - (guarantee index-fixnum? max 'MAKE-PROCEDURE-ARITY) + (guarantee index-fixnum? max 'make-procedure-arity) (if (not (fix:>= max min)) (error:bad-range-argument max - 'MAKE-PROCEDURE-ARITY)))) + 'make-procedure-arity)))) max)))) (if (and (eqv? min max) (if (default-object? simple-ok?) #f simple-ok?)) @@ -187,12 +187,12 @@ USA. (define (procedure-arity-min arity) (cond ((simple-arity? arity) arity) ((general-arity? arity) (car arity)) - (else (error:not-a procedure-arity? arity 'PROCEDURE-ARITY-MIN)))) + (else (error:not-a procedure-arity? arity 'procedure-arity-min)))) (define (procedure-arity-max arity) (cond ((simple-arity? arity) arity) ((general-arity? arity) (cdr arity)) - (else (error:not-a procedure-arity? arity 'PROCEDURE-ARITY-MAX)))) + (else (error:not-a procedure-arity? arity 'procedure-arity-max)))) (define (procedure-arity<= arity1 arity2) (and (fix:<= (procedure-arity-min arity2) @@ -243,11 +243,11 @@ USA. (define (primitive-procedure-name procedure) (%primitive-procedure-name - (%primitive-procedure-arg procedure 'PRIMITIVE-PROCEDURE-NAME))) + (%primitive-procedure-arg procedure 'primitive-procedure-name))) (define (implemented-primitive-procedure? procedure) (%primitive-procedure-implemented? - (%primitive-procedure-arg procedure 'IMPLEMENTED-PRIMITIVE-PROCEDURE?))) + (%primitive-procedure-arg procedure 'implemented-primitive-procedure?))) (define (%primitive-procedure-arg procedure caller) (let ((procedure* (skip-entities procedure))) @@ -296,7 +296,7 @@ USA. (+ (loop (entity-procedure p)) 1))) (else (error:wrong-type-argument procedure "compiled procedure" - 'COMPILED-PROCEDURE-FRAME-SIZE))))) + 'compiled-procedure-frame-size))))) (define (%compiled-closure? object) (and (%compiled-procedure? object) @@ -315,7 +315,7 @@ USA. (let ((closure* (skip-entities closure))) (if (not (%compiled-closure? closure*)) (error:wrong-type-argument closure "compiled closure" - 'COMPILED-CLOSURE->ENTRY)) + 'compiled-closure->entry)) closure*))) ;; In the following two procedures, offset can be #f to support @@ -372,21 +372,21 @@ USA. (%make-entity procedure extra)) (define (entity-procedure entity) - (guarantee-entity entity 'ENTITY-PROCEDURE) + (guarantee-entity entity 'entity-procedure) (%entity-procedure entity)) (define (entity-extra entity) - (guarantee-entity entity 'ENTITY-EXTRA) + (guarantee-entity entity 'entity-extra) (%entity-extra entity)) (define (set-entity-procedure! entity procedure) - (guarantee-entity entity 'SET-ENTITY-PROCEDURE!) + (guarantee-entity entity 'set-entity-procedure!) (if (procedure-chains-to procedure entity) - (error:bad-range-argument procedure 'SET-ENTITY-PROCEDURE!)) + (error:bad-range-argument procedure 'set-entity-procedure!)) (%set-entity-procedure! entity procedure)) (define (set-entity-extra! entity extra) - (guarantee-entity entity 'SET-ENTITY-EXTRA!) + (guarantee-entity entity 'set-entity-extra!) (%set-entity-extra! entity extra)) (define (make-apply-hook procedure extra) @@ -411,21 +411,21 @@ USA. "apply-hook-tag") (define (apply-hook-procedure apply-hook) - (guarantee-apply-hook apply-hook 'APPLY-HOOK-PROCEDURE) + (guarantee-apply-hook apply-hook 'apply-hook-procedure) (system-hunk3-cxr1 (%entity-extra apply-hook))) (define (apply-hook-extra apply-hook) - (guarantee-apply-hook apply-hook 'APPLY-HOOK-EXTRA) + (guarantee-apply-hook apply-hook 'apply-hook-extra) (system-hunk3-cxr2 (%entity-extra apply-hook))) (define (set-apply-hook-procedure! apply-hook procedure) - (guarantee-apply-hook apply-hook 'SET-APPLY-HOOK-PROCEDURE!) + (guarantee-apply-hook apply-hook 'set-apply-hook-procedure!) (if (procedure-chains-to procedure apply-hook) - (error:bad-range-argument procedure 'SET-APPLY-HOOK-PROCEDURE!)) + (error:bad-range-argument procedure 'set-apply-hook-procedure!)) (system-hunk3-set-cxr1! (%entity-extra apply-hook) procedure)) (define (set-apply-hook-extra! apply-hook procedure) - (guarantee-apply-hook apply-hook 'SET-APPLY-HOOK-EXTRA!) + (guarantee-apply-hook apply-hook 'set-apply-hook-extra!) (system-hunk3-set-cxr2! (%entity-extra apply-hook) procedure)) ;;;; Arity dispatched entities @@ -436,7 +436,7 @@ USA. ;; SELF argument. (make-entity default (list->vector - (cons (fixed-objects-item 'ARITY-DISPATCHER-TAG) + (cons (fixed-objects-item 'arity-dispatcher-tag) dispatched-cases)))) (define (arity-dispatched-procedure? object) @@ -444,7 +444,7 @@ USA. (vector? (entity-extra object)) (fix:< 0 (vector-length (entity-extra object))) (eq? (vector-ref (entity-extra object) 0) - (fixed-objects-item 'ARITY-DISPATCHER-TAG)))) + (fixed-objects-item 'arity-dispatcher-tag)))) (define (procedure-chains-to p1 p2) (let loop ((p1 p1)) diff --git a/src/runtime/process.scm b/src/runtime/process.scm index d5a36ff6e..2b02e0d7e 100644 --- a/src/runtime/process.scm +++ b/src/runtime/process.scm @@ -139,22 +139,22 @@ USA. (let ((ctty-allowed? (string? ctty))) (define-integrable (convert-stdio-arg stdio) (cond ((not stdio) #f) - ((eq? stdio 'INHERIT) -1) - ((and ctty-allowed? (eq? stdio 'CTTY)) -2) + ((eq? stdio 'inherit) -1) + ((and ctty-allowed? (eq? stdio 'ctty)) -2) ((channel? stdio) (channel-descriptor stdio)) (else (error:wrong-type-argument stdio "process I/O channel" - 'MAKE-SUBPROCESS)))) + 'make-subprocess)))) (let ((working-directory #f) (ctty - (cond ((eq? ctty 'BACKGROUND) -1) - ((eq? ctty 'FOREGROUND) -2) + (cond ((eq? ctty 'background) -1) + ((eq? ctty 'foreground) -2) ((or (not ctty) (string? ctty)) ctty) (else (error:wrong-type-argument ctty "process controlling terminal" - 'MAKE-SUBPROCESS)))) + 'make-subprocess)))) (stdin (convert-stdio-arg stdin)) (stdout (convert-stdio-arg stdout)) (stderr (convert-stdio-arg stderr))) @@ -185,8 +185,8 @@ USA. (add-to-gc-finalizer! subprocess-finalizer process) (poll-subprocess-status process) process)))))))) - (if (and (eq? ctty 'FOREGROUND) - (eq? (subprocess-status process) 'RUNNING)) + (if (and (eq? ctty 'foreground) + (eq? (subprocess-status process) 'running)) (subprocess-continue-foreground process)) process)) @@ -205,7 +205,7 @@ USA. (lambda () (set! registration (register-subprocess-event - process 'RUNNING (current-thread) + process 'running (current-thread) (named-lambda (subprocess-wait-event status) (set! result status))))) (lambda () @@ -214,7 +214,7 @@ USA. (lambda () (if (eq? result '#f) (suspend-current-thread)) - (if (eq? result 'RUNNING) + (if (eq? result 'running) (set! result #f)))) (if (not result) (loop) @@ -227,7 +227,7 @@ USA. ((ucode-primitive process-continue-foreground 1) (subprocess-index process)) (let ((status (subprocess-status process))) - (if (eq? status 'RUNNING) + (if (eq? status 'running) (loop) status)))) @@ -245,10 +245,10 @@ USA. (define (convert-subprocess-status status) (case status - ((0) 'RUNNING) - ((1) 'STOPPED) - ((2) 'EXITED) - ((3) 'SIGNALLED) + ((0) 'running) + ((1) 'stopped) + ((2) 'exited) + ((3) 'signalled) (else (error "Illegal process status:" status)))) (define (subprocess-job-control-status process) @@ -256,10 +256,10 @@ USA. ((ucode-primitive process-job-control-status 1) (subprocess-index process)))) (case n - ((0) 'NO-CTTY) - ((1) 'UNRELATED-CTTY) - ((2) 'NO-JOB-CONTROL) - ((3) 'JOB-CONTROL) + ((0) 'no-ctty) + ((1) 'unrelated-ctty) + ((2) 'no-job-control) + ((3) 'job-control) (else (error "Illegal process job-control status:" n))))) ;;;; Subprocess Events @@ -302,7 +302,7 @@ USA. (define (deregister-subprocess-event registration) (guarantee-subprocess-registration registration - 'DEREGISTER-SUBPROCESS-EVENT) + 'deregister-subprocess-event) (without-interrupts (lambda () (set! subprocess-registrations @@ -327,9 +327,9 @@ USA. (define (handle-subprocess-status-change) (without-interrupts %handle-subprocess-status-change) - (if (eq? 'NT microcode-id/operating-system) + (if (eq? 'nt microcode-id/operating-system) (for-each (lambda (process) - (if (memq (subprocess-status process) '(EXITED SIGNALLED)) + (if (memq (subprocess-status process) '(exited signalled)) (close-subprocess-i/o process))) (subprocess-list)))) @@ -361,8 +361,8 @@ USA. (filter! (lambda (registration) (let ((status (subprocess-registration/status registration))) - (not (or (eq? status 'EXITED) - (eq? status 'SIGNALLED))))) + (not (or (eq? status 'exited) + (eq? status 'signalled))))) subprocess-registrations)) (if signaled? (%maybe-toggle-thread-timer))))) @@ -390,7 +390,7 @@ USA. (maybe-close-subprocess-i/o process)) (define (maybe-close-subprocess-i/o process) - (if (eq? 'NT microcode-id/operating-system) + (if (eq? 'nt microcode-id/operating-system) (close-subprocess-i/o process))) (define (subprocess-stop process) @@ -403,12 +403,12 @@ USA. (define (start-subprocess-in-background filename arguments environment) (make-subprocess filename arguments environment - 'BACKGROUND 'INHERIT 'INHERIT 'INHERIT + 'background 'inherit 'inherit 'inherit #f #f #f)) (define (run-subprocess-in-foreground filename arguments environment) (make-subprocess filename arguments environment - 'FOREGROUND 'INHERIT 'INHERIT 'INHERIT + 'foreground 'inherit 'inherit 'inherit #f #f #f)) (define (start-pipe-subprocess filename arguments environment) @@ -429,7 +429,7 @@ USA. (lambda (master-channel master-name slave-name) master-name (make-subprocess filename arguments environment - slave-name 'CTTY 'CTTY 'CTTY + slave-name 'ctty 'ctty 'ctty master-channel master-channel master-channel)))) ;;;; Environment Bindings diff --git a/src/runtime/prop1d.scm b/src/runtime/prop1d.scm index c53e31c00..43f46e5fa 100644 --- a/src/runtime/prop1d.scm +++ b/src/runtime/prop1d.scm @@ -35,7 +35,7 @@ USA. (define (initialize-unparser!) (unparser/set-tagged-pair-method! 1d-table-tag - (standard-unparser-method '1D-TABLE #f))) + (standard-unparser-method '1d-table #f))) (define population-of-1d-tables) diff --git a/src/runtime/prop2d.scm b/src/runtime/prop2d.scm index 377d18557..d33675df1 100644 --- a/src/runtime/prop2d.scm +++ b/src/runtime/prop2d.scm @@ -25,7 +25,7 @@ USA. |# ;;;; Two Dimensional Property Tables -;;; package: (runtime 2D-property) +;;; package: (runtime 2d-property) (declare (usual-integrations)) @@ -37,7 +37,7 @@ USA. (define system-properties) -(define (2D-put! x y value) +(define (2d-put! x y value) (let ((x-hash (object-hash x)) (y-hash (object-hash y))) (let ((bucket (assq x-hash system-properties))) @@ -54,7 +54,7 @@ USA. '())) system-properties)))))) -(define (2D-get x y) +(define (2d-get x y) (let ((bucket (assq (object-hash x) system-properties))) (and bucket (let ((entry (assq (object-hash y) (cdr bucket)))) @@ -64,7 +64,7 @@ USA. ;;; Returns TRUE iff an entry was removed. ;;; Removes the bucket if the entry removed was the only entry. -(define (2D-remove! x y) +(define (2d-remove! x y) (let ((bucket (assq (object-hash x) system-properties))) (and bucket (begin (set-cdr! bucket @@ -93,7 +93,7 @@ USA. (define delete-invalid-hash-numbers!) (define delete-invalid-y!) -(define (2D-get-alist-x x) +(define (2d-get-alist-x x) (let ((bucket (assq (object-hash x) system-properties))) (if bucket (let loop ((rest (cdr bucket))) @@ -105,7 +105,7 @@ USA. (else (loop (cdr rest))))) '()))) -(define (2D-get-alist-y y) +(define (2d-get-alist-y y) (let ((y-hash (object-hash y))) (let loop ((rest system-properties)) (cond ((null? rest) '()) diff --git a/src/runtime/qsort.scm b/src/runtime/qsort.scm index 6d17f3c46..3cdcabdbf 100644 --- a/src/runtime/qsort.scm +++ b/src/runtime/qsort.scm @@ -76,6 +76,6 @@ USA. (vector-set! vector j ith-element))) (if (not (vector? vector)) - (error:wrong-type-argument vector "vector" 'QUICK-SORT!)) + (error:wrong-type-argument vector "vector" 'quick-sort!)) (outer-loop 0 (fix:- (vector-length vector) 1)) vector) \ No newline at end of file diff --git a/src/runtime/queue.scm b/src/runtime/queue.scm index d644a0318..246e648af 100644 --- a/src/runtime/queue.scm +++ b/src/runtime/queue.scm @@ -91,7 +91,7 @@ USA. (with-queue-lock queue (lambda () (dequeue!/unsafe queue)))) (define (queue-map! queue procedure) - (let ((empty (list 'EMPTY))) + (let ((empty (list 'empty))) (let loop () (let ((item (with-queue-lock queue diff --git a/src/runtime/random.scm b/src/runtime/random.scm index 47198da5f..e5f1f3e67 100644 --- a/src/runtime/random.scm +++ b/src/runtime/random.scm @@ -138,17 +138,17 @@ USA. ;;;; Operations producing random values (define (random modulus #!optional state) - (let ((state (get-random-state state 'RANDOM))) + (let ((state (get-random-state state 'random))) ;; Kludge: an exact integer modulus means that result is an exact ;; integer. Otherwise, the result is a real number. (cond ((int:integer? modulus) (if (int:> modulus 0) (%random-integer modulus state) - (error:bad-range-argument modulus 'RANDOM))) + (error:bad-range-argument modulus 'random))) ((flo:flonum? modulus) (if (flo:> modulus 0.) (flo:* (flo:random-unit state) modulus) - (error:bad-range-argument modulus 'RANDOM))) + (error:bad-range-argument modulus 'random))) ((real? modulus) ;; I can't think of the correct thing to do here. The old ;; code scaled a random element into the appropriate range, @@ -158,7 +158,7 @@ USA. ;; know. -- cph (error "Unsupported modulus:" modulus)) (else - (error:wrong-type-argument modulus "real number" 'RANDOM))))) + (error:wrong-type-argument modulus "real number" 'random))))) (define (flo:random-unit state) ;; Guarantee that (< 0 returned-value 1) @@ -175,14 +175,14 @@ USA. bytes)) (define (random-source-make-integers source) - (guarantee-random-state source 'RANDOM-SOURCE-MAKE-INTEGERS) + (guarantee-random-state source 'random-source-make-integers) (lambda (modulus) (if (int:> modulus 0) (%random-integer modulus source) (error:bad-range-argument modulus #f)))) (define (random-source-make-reals source #!optional unit) - (guarantee-random-state source 'RANDOM-SOURCE-MAKE-REALS) + (guarantee-random-state source 'random-source-make-reals) (let ((unit (if (default-object? unit) .5 @@ -190,7 +190,7 @@ USA. (if (not (and (real? unit) (< 0 unit 1))) (error:wrong-type-argument unit "real unit" - 'RANDOM-SOURCE-MAKE-REALS)) + 'random-source-make-reals)) unit)))) (if (flo:flonum? unit) ;; Ignore UNIT and return maximum precision. @@ -222,7 +222,7 @@ USA. (else (outer))))))))) (simple-random-state)) (copy-random-state - (get-random-state state 'MAKE-RANDOM-STATE)))) + (get-random-state state 'make-random-state)))) (define (simple-random-state) (initial-random-state @@ -241,7 +241,7 @@ USA. (define (random-source-pseudo-randomize! source i j) source i j - (error "Unimplemented procedure:" 'RANDOM-SOURCE-PSEUDO-RANDOMIZE!)) + (error "Unimplemented procedure:" 'random-source-pseudo-randomize!)) (define (initial-random-state generate-random-seed) ;; The numbers returned by GENERATE-RANDOM-SEED are not critical. @@ -280,11 +280,11 @@ USA. ;;;; External representation of state -(define-integrable ers:tag 'RANDOM-STATE-V1) +(define-integrable ers:tag 'random-state-v1) (define-integrable ers:length (fix:+ r 3)) (define (export-random-state state) - (guarantee-random-state state 'EXPORT-RANDOM-STATE) + (guarantee-random-state state 'export-random-state) (let ((v (make-vector ers:length))) (vector-set! v 0 ers:tag) (vector-set! v 1 (random-state-index state)) @@ -301,7 +301,7 @@ USA. (lambda () (error:wrong-type-argument v "external random state" - 'IMPORT-RANDOM-STATE)))) + 'import-random-state)))) (if (not (and (vector? v) (fix:= (vector-length v) ers:length) (eq? (vector-ref v 0) ers:tag))) @@ -411,11 +411,11 @@ USA. (lambda () (random-source-randomize! default-random-source))) (named-structure/set-tag-description! random-state-tag - (make-define-structure-type 'VECTOR - 'RANDOM-STATE - '#(INDEX BORROW VECTOR) + (make-define-structure-type 'vector + 'random-state + '#(index borrow vector) '#(1 2 3) (make-vector 3 (lambda () #f)) - (standard-unparser-method 'RANDOM-STATE #f) + (standard-unparser-method 'random-state #f) random-state-tag 4))) \ No newline at end of file diff --git a/src/runtime/rbtree.scm b/src/runtime/rbtree.scm index 889293d0d..ead7ccb70 100644 --- a/src/runtime/rbtree.scm +++ b/src/runtime/rbtree.scm @@ -76,28 +76,28 @@ USA. ;;; permit code to be used for either symmetry: (define-integrable (b->d left?) - (if left? 'LEFT 'RIGHT)) + (if left? 'left 'right)) (define-integrable (-d d) - (if (eq? 'LEFT d) 'RIGHT 'LEFT)) + (if (eq? 'left d) 'right 'left)) (define-integrable (get-link+ p d) - (if (eq? 'LEFT d) + (if (eq? 'left d) (node-left p) (node-right p))) (define-integrable (set-link+! p d l) - (if (eq? 'LEFT d) + (if (eq? 'left d) (set-node-left! p l) (set-node-right! p l))) (define-integrable (get-link- p d) - (if (eq? 'RIGHT d) + (if (eq? 'right d) (node-left p) (node-right p))) (define-integrable (set-link-! p d l) - (if (eq? 'RIGHT d) + (if (eq? 'right d) (set-node-left! p l) (set-node-right! p l))) @@ -122,7 +122,7 @@ USA. (rotate+! tree x (-d d))) (define (rb-tree/insert! tree key datum) - (guarantee-rb-tree tree 'RB-TREE/INSERT!) + (guarantee-rb-tree tree 'rb-tree/insert!) (let ((key=? (tree-key=? tree)) (keyd (eq? u (node-left (node-up u)))))) (let ((y (get-link- (node-up u) d))) - (if (and y (eq? 'RED (node-color y))) + (if (and y (eq? 'red (node-color y))) ;; case 1 (begin - (set-node-color! u 'BLACK) - (set-node-color! y 'BLACK) - (set-node-color! (node-up u) 'RED) + (set-node-color! u 'black) + (set-node-color! y 'black) + (set-node-color! (node-up u) 'red) (loop (node-up u))) (let ((x (if (eq? x (get-link- u d)) @@ -164,10 +164,10 @@ USA. x))) ;; case 3 (let ((u (node-up x))) - (set-node-color! u 'BLACK) - (set-node-color! (node-up u) 'RED) + (set-node-color! u 'black) + (set-node-color! (node-up u) 'red) (rotate-! tree (node-up u) d))))))))) - (set-node-color! (tree-root tree) 'BLACK)) + (set-node-color! (tree-root tree) 'black)) (define (alist->rb-tree alist key=? keyd (eq? x (node-left u))))) (let ((w (let ((w (get-link- u d))) - (if (eq? 'RED (node-color w)) + (if (eq? 'red (node-color w)) ;; case 1 (begin - (set-node-color! w 'BLACK) - (set-node-color! u 'RED) + (set-node-color! w 'black) + (set-node-color! u 'red) (rotate+! tree u d) (get-link- u d)) w))) (case-4 (lambda (w) (set-node-color! w (node-color u)) - (set-node-color! u 'BLACK) - (set-node-color! (get-link- w d) 'BLACK) + (set-node-color! u 'black) + (set-node-color! (get-link- w d) 'black) (rotate+! tree u d) - (set-node-color! (tree-root tree) 'BLACK)))) + (set-node-color! (tree-root tree) 'black)))) (if (let ((n- (get-link- w d))) (and n- - (eq? 'RED (node-color n-)))) + (eq? 'red (node-color n-)))) (case-4 w) (let ((n+ (get-link+ w d))) (if (or (not n+) - (eq? 'BLACK (node-color n+))) + (eq? 'black (node-color n+))) ;; case 2 (begin - (set-node-color! w 'RED) + (set-node-color! w 'red) (loop u (node-up u))) ;; case 3 (begin - (set-node-color! n+ 'BLACK) - (set-node-color! w 'RED) + (set-node-color! n+ 'black) + (set-node-color! w 'red) (rotate-! tree w d) (case-4 (get-link- u d))))))))))) (define (rb-tree/lookup tree key default) - (guarantee-rb-tree tree 'RB-TREE/LOOKUP) + (guarantee-rb-tree tree 'rb-tree/lookup) (let ((key=? (tree-key=? tree)) (keyalist tree) - (guarantee-rb-tree tree 'RB-TREE->ALIST) + (guarantee-rb-tree tree 'rb-tree->alist) (let ((node (min-node tree))) (if node (let ((result (list (cons (node-key node) (node-datum node))))) @@ -317,7 +317,7 @@ USA. '()))) (define (rb-tree/key-list tree) - (guarantee-rb-tree tree 'RB-TREE/KEY-LIST) + (guarantee-rb-tree tree 'rb-tree/key-list) (let ((node (min-node tree))) (if node (let ((result (list (node-key node)))) @@ -330,7 +330,7 @@ USA. '()))) (define (rb-tree/datum-list tree) - (guarantee-rb-tree tree 'RB-TREE/DATUM-LIST) + (guarantee-rb-tree tree 'rb-tree/datum-list) (let ((node (min-node tree))) (if node (let ((result (list (node-datum node)))) @@ -343,27 +343,27 @@ USA. '()))) (define (rb-tree/min tree default) - (guarantee-rb-tree tree 'RB-TREE/MIN) + (guarantee-rb-tree tree 'rb-tree/min) (let ((node (min-node tree))) (if node (node-key node) default))) (define (rb-tree/min-datum tree default) - (guarantee-rb-tree tree 'RB-TREE/MIN-DATUM) + (guarantee-rb-tree tree 'rb-tree/min-datum) (let ((node (min-node tree))) (if node (node-datum node) default))) (define (rb-tree/min-pair tree) - (guarantee-rb-tree tree 'RB-TREE/MIN-PAIR) + (guarantee-rb-tree tree 'rb-tree/min-pair) (let ((node (min-node tree))) (and node (node-pair node)))) (define (rb-tree/delete-min! tree default) - (guarantee-rb-tree tree 'RB-TREE/DELETE-MIN!) + (guarantee-rb-tree tree 'rb-tree/delete-min!) (let ((node (min-node tree))) (if node (let ((key (node-key node))) @@ -372,7 +372,7 @@ USA. default))) (define (rb-tree/delete-min-datum! tree default) - (guarantee-rb-tree tree 'RB-TREE/DELETE-MIN-DATUM!) + (guarantee-rb-tree tree 'rb-tree/delete-min-datum!) (let ((node (min-node tree))) (if node (let ((datum (node-datum node))) @@ -381,7 +381,7 @@ USA. default))) (define (rb-tree/delete-min-pair! tree) - (guarantee-rb-tree tree 'RB-TREE/DELETE-MIN-PAIR!) + (guarantee-rb-tree tree 'rb-tree/delete-min-pair!) (let ((node (min-node tree))) (and node (let ((pair (node-pair node))) @@ -389,27 +389,27 @@ USA. pair)))) (define (rb-tree/max tree default) - (guarantee-rb-tree tree 'RB-TREE/MAX) + (guarantee-rb-tree tree 'rb-tree/max) (let ((node (max-node tree))) (if node (node-key node) default))) (define (rb-tree/max-datum tree default) - (guarantee-rb-tree tree 'RB-TREE/MAX-DATUM) + (guarantee-rb-tree tree 'rb-tree/max-datum) (let ((node (max-node tree))) (if node (node-datum node) default))) (define (rb-tree/max-pair tree) - (guarantee-rb-tree tree 'RB-TREE/MAX-PAIR) + (guarantee-rb-tree tree 'rb-tree/max-pair) (let ((node (max-node tree))) (and node (node-pair node)))) (define (rb-tree/delete-max! tree default) - (guarantee-rb-tree tree 'RB-TREE/DELETE-MAX!) + (guarantee-rb-tree tree 'rb-tree/delete-max!) (let ((node (max-node tree))) (if node (let ((key (node-key node))) @@ -418,7 +418,7 @@ USA. default))) (define (rb-tree/delete-max-datum! tree default) - (guarantee-rb-tree tree 'RB-TREE/DELETE-MAX-DATUM!) + (guarantee-rb-tree tree 'rb-tree/delete-max-datum!) (let ((node (max-node tree))) (if node (let ((datum (node-datum node))) @@ -427,7 +427,7 @@ USA. default))) (define (rb-tree/delete-max-pair! tree) - (guarantee-rb-tree tree 'RB-TREE/DELETE-MAX-PAIR!) + (guarantee-rb-tree tree 'rb-tree/delete-max-pair!) (let ((node (max-node tree))) (and node (let ((pair (node-pair node))) diff --git a/src/runtime/record.scm b/src/runtime/record.scm index cd9ba4cf8..f339b6eb1 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -739,7 +739,7 @@ USA. (if (not (vector-ref seen? i)) (let ((init (vector-ref inits i))) (and init (vector-set! v (vector-ref indexes i) (init))))))) - (if (eq? (structure-type/physical-type type) 'LIST) + (if (eq? (structure-type/physical-type type) 'list) (do ((i (fix:- len 1) (fix:- i 1)) (list '() (cons (vector-ref v i) list))) ((not (fix:>= i 0)) list)) @@ -819,35 +819,35 @@ USA. (define (initialize-conditions!) (set! condition-type:slot-error - (make-condition-type 'SLOT-ERROR condition-type:cell-error + (make-condition-type 'slot-error condition-type:cell-error '() (lambda (condition port) (write-string "Anonymous error for slot " port) - (write (access-condition condition 'LOCATION) port) + (write (access-condition condition 'location) port) (write-string "." port)))) (set! condition-type:uninitialized-slot - (make-condition-type 'UNINITIALIZED-SLOT condition-type:slot-error - '(RECORD) + (make-condition-type 'uninitialized-slot condition-type:slot-error + '(record) (lambda (condition port) (write-string "Attempt to reference slot " port) - (write (access-condition condition 'LOCATION) port) + (write (access-condition condition 'location) port) (write-string " in record " port) - (write (access-condition condition 'RECORD) port) + (write (access-condition condition 'record) port) (write-string " failed because the slot is not initialized." port)))) (set! condition-type:no-such-slot - (make-condition-type 'NO-SUCH-SLOT condition-type:slot-error - '(RECORD-TYPE) + (make-condition-type 'no-such-slot condition-type:slot-error + '(record-type) (lambda (condition port) (write-string "No slot named " port) - (write (access-condition condition 'LOCATION) port) + (write (access-condition condition 'location) port) (write-string " in records of type " port) - (write (access-condition condition 'RECORD-TYPE) port) + (write (access-condition condition 'record-type) port) (write-string "." port)))) (set! error:uninitialized-slot (let ((signal (condition-signaller condition-type:uninitialized-slot - '(RECORD LOCATION) + '(record location) standard-error-handler))) (lambda (record index) (let* ((location (%record-field-name record index)) @@ -868,7 +868,7 @@ USA. (set! error:no-such-slot (let ((signal (condition-signaller condition-type:no-such-slot - '(RECORD-TYPE LOCATION) + '(record-type location) standard-error-handler))) (lambda (record-type name) (call-with-current-continuation diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index 5e05cb253..dc020d393 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -49,7 +49,7 @@ USA. console-i/o-port user-initial-environment #f - `((SET-DEFAULT-DIRECTORY + `((set-default-directory ,top-level-repl/set-default-directory)) user-initial-prompt) (cmdl-message/append @@ -83,19 +83,19 @@ USA. (define (make-cmdl parent port driver state operations) (if (not (or (not parent) (cmdl? parent))) - (error:wrong-type-argument parent "cmdl" 'MAKE-CMDL)) + (error:wrong-type-argument parent "cmdl" 'make-cmdl)) (if (not (or parent port)) - (error:bad-range-argument port 'MAKE-CMDL)) + (error:bad-range-argument port 'make-cmdl)) (%make-cmdl (if parent (+ (cmdl/level parent) 1) 1) parent (or port (and parent (cmdl/child-port parent))) driver state - (parse-operations-list operations 'MAKE-CMDL) + (parse-operations-list operations 'make-cmdl) (make-1d-table))) (define (cmdl/child-port cmdl) - (or (let ((operation (cmdl/local-operation cmdl 'CHILD-PORT))) + (or (let ((operation (cmdl/local-operation cmdl 'child-port))) (and operation (operation cmdl))) (cmdl/port cmdl))) @@ -110,7 +110,7 @@ USA. cmdl))) (define (cmdl/set-default-directory cmdl pathname) - (let ((operation (cmdl/local-operation cmdl 'SET-DEFAULT-DIRECTORY))) + (let ((operation (cmdl/local-operation cmdl 'set-default-directory))) (if operation (operation cmdl pathname))) (port/set-default-directory (cmdl/port cmdl) pathname)) @@ -160,7 +160,7 @@ USA. (cond ((and owner (not (eq? thread owner))) (signal-thread-event owner (let ((signaller - (or (cmdl/local-operation cmdl 'START-NON-OWNED) + (or (cmdl/local-operation cmdl 'start-non-owned) (lambda (cmdl thread) cmdl (error "Non-owner thread can't start CMDL:" @@ -171,7 +171,7 @@ USA. (stop-current-thread)) ((let ((parent (cmdl/parent cmdl))) (and parent - (cmdl/local-operation parent 'START-CHILD))) + (cmdl/local-operation parent 'start-child))) => (lambda (operation) (operation cmdl thunk))) (else (with-thread-mutex-locked mutex thunk))))))) @@ -179,7 +179,7 @@ USA. (define (bind-abort-restart cmdl thunk) (call-with-current-continuation (lambda (continuation) - (with-restart 'ABORT + (with-restart 'abort (string-append "Return to " (if (repl? cmdl) "read-eval-print" @@ -285,7 +285,7 @@ USA. (define ((cmdl-message/strings . strings) cmdl) (let ((port (cmdl/port cmdl))) - (with-output-port-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'cooked (lambda () (for-each (lambda (string) (fresh-line port) @@ -295,7 +295,7 @@ USA. (define ((cmdl-message/active actor) cmdl) (let ((port (cmdl/port cmdl))) - (with-output-port-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'cooked (lambda () (actor port))))) @@ -321,42 +321,42 @@ USA. ;;;; Interrupts (define (cmdl-interrupt/breakpoint) - ((or (cmdl/operation (nearest-cmdl) 'INTERRUPT/BREAKPOINT) + ((or (cmdl/operation (nearest-cmdl) 'interrupt/breakpoint) breakpoint))) (define (cmdl-interrupt/abort-nearest) - ((or (cmdl/operation (nearest-cmdl) 'INTERRUPT/ABORT-NEAREST) + ((or (cmdl/operation (nearest-cmdl) 'interrupt/abort-nearest) abort->nearest))) (define (cmdl-interrupt/abort-previous) - ((or (cmdl/operation (nearest-cmdl) 'INTERRUPT/ABORT-PREVIOUS) + ((or (cmdl/operation (nearest-cmdl) 'interrupt/abort-previous) abort->previous))) (define (cmdl-interrupt/abort-top-level) - ((or (cmdl/operation (nearest-cmdl) 'INTERRUPT/ABORT-TOP-LEVEL) + ((or (cmdl/operation (nearest-cmdl) 'interrupt/abort-top-level) abort->top-level))) (define (abort->nearest #!optional message) - (invoke-abort (let ((restart (find-restart 'ABORT))) + (invoke-abort (let ((restart (find-restart 'abort))) (if (not restart) - (error:no-such-restart 'ABORT)) + (error:no-such-restart 'abort)) restart) (if (default-object? message) "Abort!" message))) (define (abort->previous #!optional message) - (invoke-abort (let ((restarts (find-restarts 'ABORT (bound-restarts)))) - (let ((next (find-restarts 'ABORT (cdr restarts)))) + (invoke-abort (let ((restarts (find-restarts 'abort (bound-restarts)))) + (let ((next (find-restarts 'abort (cdr restarts)))) (cond ((pair? next) (car next)) ((pair? restarts) (car restarts)) - (else (error:no-such-restart 'ABORT))))) + (else (error:no-such-restart 'abort))))) (if (default-object? message) "Up!" message))) (define (abort->top-level #!optional message) - (invoke-abort (let loop ((restarts (find-restarts 'ABORT (bound-restarts)))) - (let ((next (find-restarts 'ABORT (cdr restarts)))) + (invoke-abort (let loop ((restarts (find-restarts 'abort (bound-restarts)))) + (let ((next (find-restarts 'abort (cdr restarts)))) (cond ((pair? next) (loop next)) ((pair? restarts) (car restarts)) - (else (error:no-such-restart 'ABORT))))) + (else (error:no-such-restart 'abort))))) (if (default-object? message) "Quit!" message))) (define (find-restarts name restarts) @@ -373,7 +373,7 @@ USA. (effector)))) (define cmdl-abort-restart-tag - (list 'CMDL-ABORT-RESTART-TAG)) + (list 'cmdl-abort-restart-tag)) ;;;; REP Loops @@ -385,17 +385,17 @@ USA. (let ((inherit (let ((repl (and parent (skip-non-repls parent)))) (lambda (argument default name check-arg) - (if (eq? 'INHERIT argument) + (if (eq? 'inherit argument) (begin (if (not repl) (error "Can't inherit -- no REPL ancestor:" name)) (default repl)) - (check-arg argument 'MAKE-REPL)))))) + (check-arg argument 'make-repl)))))) (make-repl-state - (inherit (if (default-object? prompt) 'INHERIT prompt) + (inherit (if (default-object? prompt) 'inherit prompt) repl/prompt - 'PROMPT + 'prompt (lambda (object procedure) (if (not (string? object)) (error:wrong-type-argument object @@ -404,15 +404,15 @@ USA. object)) (inherit environment repl/environment - 'ENVIRONMENT + 'environment ->environment) (if (default-object? condition) #f condition))) (append (if (default-object? operations) '() operations) default-repl-operations))) (define default-repl-operations - `((START-CHILD ,(lambda (cmdl thunk) cmdl (with-history-disabled thunk))) - (START-NON-OWNED + `((start-child ,(lambda (cmdl thunk) cmdl (with-history-disabled thunk))) + (start-non-owned ,(lambda (repl thread) (let ((condition (repl/condition repl))) (if condition @@ -427,12 +427,12 @@ USA. environment (if (default-object? condition) #f condition) (if (default-object? operations) '() operations) - (if (default-object? prompt) 'INHERIT prompt)))) + (if (default-object? prompt) 'inherit prompt)))) (define (repl-driver repl) (let ((condition (repl/condition repl))) (if (and condition (condition/error? condition)) - (cond ((cmdl/operation repl 'ERROR-DECISION) + (cond ((cmdl/operation repl 'error-decision) => (lambda (operation) (operation repl condition))) (hook/error-decision @@ -452,17 +452,17 @@ USA. (enqueue! (repl/input-queue (nearest-repl)) procedure)) (define (repl-read #!optional environment repl) - (receive (environment repl) (optional-er environment repl 'REPL-READ) + (receive (environment repl) (optional-er environment repl 'repl-read) (hook/repl-read environment repl))) (define hook/repl-read) (define (default/repl-read environment repl) - (prompt-for-command-expression (cons 'STANDARD (repl/prompt repl)) + (prompt-for-command-expression (cons 'standard (repl/prompt repl)) (cmdl/port repl) environment)) (define (repl-eval s-expression #!optional environment repl) - (receive (environment repl) (optional-er environment repl 'REPL-EVAL) + (receive (environment repl) (optional-er environment repl 'repl-eval) (%repl-eval s-expression environment repl))) (define (%repl-eval s-expression environment repl) @@ -474,13 +474,13 @@ USA. (define hook/repl-eval) (define (default/repl-eval s-expression environment repl) (if (and (pair? s-expression) - (eq? 'UNQUOTE (car s-expression))) + (eq? 'unquote (car s-expression))) (let ((env (->environment '(user)))) (%repl-scode-eval (syntax (cadr s-expression) env) env repl)) (%repl-scode-eval (syntax s-expression environment) environment repl))) (define (repl-scode-eval scode #!optional environment repl) - (receive (environment repl) (optional-er environment repl 'REPL-SCODE-EVAL) + (receive (environment repl) (optional-er environment repl 'repl-scode-eval) (%repl-scode-eval scode environment repl))) (define (%repl-scode-eval scode environment repl) @@ -495,7 +495,7 @@ USA. repl)) (define (repl-write value s-expression #!optional environment repl) - (receive (environment repl) (optional-er environment repl 'REPL-WRITE) + (receive (environment repl) (optional-er environment repl 'repl-write) (hook/repl-write value s-expression environment repl))) (define hook/repl-write) @@ -511,7 +511,7 @@ USA. environment)) (define (repl-eval/write s-expression #!optional environment repl) - (receive (environment repl) (optional-er environment repl 'REPL-EVAL/WRITE) + (receive (environment repl) (optional-er environment repl 'repl-eval/write) (%repl-eval/write s-expression environment repl))) (define (%repl-eval/write s-expression environment repl) @@ -564,7 +564,7 @@ USA. (if (not (and parent (repl? parent) (eq? (repl/environment parent) environment))) - (let ((operation (cmdl/operation repl 'SET-DEFAULT-ENVIRONMENT))) + (let ((operation (cmdl/operation repl 'set-default-environment))) (if operation (operation repl environment) (hook/set-default-environment repl environment)))))) @@ -572,7 +572,7 @@ USA. (define hook/set-default-environment) (define (default/set-default-environment port environment) (let ((port (cmdl/port port))) - (with-output-port-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'cooked (lambda () (if (not (interpreter-environment? environment)) (begin @@ -632,9 +632,9 @@ USA. (loop)))))) (begin (if (not (exact-integer? n)) - (error:wrong-type-argument n "exact integer" 'RESTART)) + (error:wrong-type-argument n "exact integer" 'restart)) (if (not (<= 1 n n-restarts)) - (error:bad-range-argument n 'RESTART)) + (error:bad-range-argument n 'restart)) n)))) condition))))) @@ -774,7 +774,7 @@ USA. (define (repl-history/read history n) (if (not (and (exact-nonnegative-integer? n) (< n (repl-history/size history)))) - (error:wrong-type-argument n "history index" 'REPL-HISTORY/READ)) + (error:wrong-type-argument n "history index" 'repl-history/read)) (list-ref (repl-history/elements history) (- (- (repl-history/size history) 1) n))) @@ -788,13 +788,13 @@ USA. environment)))) (define (ge environment) - (let ((environment (->environment environment 'GE))) + (let ((environment (->environment environment 'ge))) (set-repl/environment! (nearest-repl) environment) (set-load-environment! environment) environment)) (define (->environment object #!optional caller) - (let ((caller (if (default-object? caller) '->ENVIRONMENT caller))) + (let ((caller (if (default-object? caller) '->environment caller))) (cond ((environment? object) object) ((package? object) (package/environment object)) ((procedure? object) (procedure-environment object)) @@ -827,7 +827,7 @@ USA. (repl/start (push-repl environment #f '() prompt) message)) (define (ve environment) - (read-eval-print (->environment environment 'VE) #f 'INHERIT)) + (read-eval-print (->environment environment 've) #f 'inherit)) (define (proceed #!optional value) (if (default-object? value) @@ -840,7 +840,7 @@ USA. ;;;; Breakpoints (define (bkpt datum . arguments) - (apply breakpoint-procedure 'CONTINUATION-ENVIRONMENT datum arguments)) + (apply breakpoint-procedure 'continuation-environment datum arguments)) (define (breakpoint-procedure environment datum . arguments) (signal-breakpoint-1 #f @@ -874,7 +874,7 @@ USA. (call-with-current-continuation (lambda (restart-continuation) (let ((continuation (or continuation restart-continuation))) - (with-restart 'CONTINUE reporter + (with-restart 'continue reporter (lambda () (restart-continuation unspecific)) values (lambda () @@ -889,10 +889,10 @@ USA. (define (get-breakpoint-environment continuation environment message) (let ((environment - (if (eq? 'CONTINUATION-ENVIRONMENT environment) + (if (eq? 'continuation-environment environment) (continuation/first-subproblem-environment continuation) environment))) - (if (eq? 'NO-ENVIRONMENT environment) + (if (eq? 'no-environment environment) (values (nearest-repl/environment) (cmdl-message/append message @@ -908,9 +908,9 @@ USA. (lambda (expression environment subexpression) expression subexpression (if (debugging-info/undefined-environment? environment) - 'NO-ENVIRONMENT + 'no-environment environment))) - 'NO-ENVIRONMENT))) + 'no-environment))) (define condition-type:breakpoint) (define condition/breakpoint?) @@ -923,26 +923,26 @@ USA. (define (initialize-breakpoint-condition!) (set! condition-type:breakpoint - (make-condition-type 'BREAKPOINT #f '(ENVIRONMENT MESSAGE PROMPT) + (make-condition-type 'breakpoint #f '(environment message prompt) (lambda (condition port) condition (write-string "Breakpoint." port)))) (set! condition/breakpoint? (condition-predicate condition-type:breakpoint)) (set! breakpoint/environment - (condition-accessor condition-type:breakpoint 'ENVIRONMENT)) + (condition-accessor condition-type:breakpoint 'environment)) (set! breakpoint/message - (condition-accessor condition-type:breakpoint 'MESSAGE)) + (condition-accessor condition-type:breakpoint 'message)) (set! breakpoint/prompt - (condition-accessor condition-type:breakpoint 'PROMPT)) + (condition-accessor condition-type:breakpoint 'prompt)) (set! %signal-breakpoint (let ((make-condition (condition-constructor condition-type:breakpoint - '(ENVIRONMENT MESSAGE PROMPT)))) + '(environment message prompt)))) (lambda (continuation environment message prompt) (let ((condition (make-condition continuation - 'BOUND-RESTARTS + 'bound-restarts environment message prompt))) diff --git a/src/runtime/rexp.scm b/src/runtime/rexp.scm index c4e78dee3..a89a7a0c1 100644 --- a/src/runtime/rexp.scm +++ b/src/runtime/rexp.scm @@ -42,53 +42,53 @@ USA. (and (fix:= 1 (length (cdr rexp))) (rexp? (cadr rexp)))))) (case (car rexp) - ((ALTERNATIVES SEQUENCE) + ((alternatives sequence) (every rexp? (cdr rexp))) - ((GROUP OPTIONAL * +) + ((group optional * +) (and (one-arg) (not (or (and (string? rexp) (string-null? rexp)) (and (pair? rexp) (memq (car rexp) boundary-rexp-types)))))) - ((CASE-FOLD) + ((case-fold) (and (fix:= 1 (length (cdr rexp))) (string? (cadr exp)))) - ((ANY-CHAR LINE-START LINE-END STRING-START STRING-END - WORD-EDGE NOT-WORD-EDGE WORD-START WORD-END - WORD-CHAR NOT-WORD-CHAR) + ((any-char line-start line-end string-start string-end + word-edge not-word-edge word-start word-end + word-char not-word-char) (null? (cdr rexp))) - ((SYNTAX-CHAR NOT-SYNTAX-CHAR) + ((syntax-char not-syntax-char) (and (one-arg) (assq (cadr rexp) syntax-type-alist))) (else #f)))))) (define boundary-rexp-types - '(LINE-START LINE-END STRING-START STRING-END WORD-EDGE NOT-WORD-EDGE - WORD-START WORD-END)) + '(line-start line-end string-start string-end word-edge not-word-edge + word-start word-end)) (define syntax-type-alist - '((WHITESPACE . " ") - (PUNCTUATION . ".") - (WORD . "w") - (SYMBOL . "_") - (OPEN . "(") - (CLOSE . ")") - (QUOTE . "\'") - (STRING-DELIMITER . "\"") - (MATH-DELIMITER . "$") - (ESCAPE . "\\") - (CHAR-QUOTE . "/") - (COMMENT-START . "<") - (COMMENT-END . ">"))) + '((whitespace . " ") + (punctuation . ".") + (word . "w") + (symbol . "_") + (open . "(") + (close . ")") + (quote . "\'") + (string-delimiter . "\"") + (math-delimiter . "$") + (escape . "\\") + (char-quote . "/") + (comment-start . "<") + (comment-end . ">"))) (define (rexp-alternatives . rexps) - `(ALTERNATIVES ,@rexps)) + `(alternatives ,@rexps)) (define (rexp-sequence . rexps) (let ((rexps (simplify-sequence-args rexps))) (if (pair? rexps) (if (pair? (cdr rexps)) - `(SEQUENCE ,@rexps) + `(sequence ,@rexps) (car rexps)) ""))) @@ -96,22 +96,22 @@ USA. (append-map (lambda (rexp) (cond ((and (string? rexp) (string-null? rexp)) '()) - ((and (pair? rexp) (eq? 'SEQUENCE (car rexp))) + ((and (pair? rexp) (eq? 'sequence (car rexp))) (cdr rexp)) - ((and (pair? rexp) (eq? 'ALTERNATIVES (car rexp))) - (list `(GROUP ,rexp))) + ((and (pair? rexp) (eq? 'alternatives (car rexp))) + (list `(group ,rexp))) (else (list rexp)))) rexps)) (define (rexp-group . rexps) (let ((rexp (apply rexp-sequence rexps))) - (if (and (pair? rexp) (eq? (car rexp) 'GROUP)) + (if (and (pair? rexp) (eq? (car rexp) 'group)) rexp - `(GROUP ,rexp)))) + `(group ,rexp)))) (define (rexp-optional . rexps) - `(OPTIONAL ,(rexp-groupify (apply rexp-sequence rexps)))) + `(optional ,(rexp-groupify (apply rexp-sequence rexps)))) (define (rexp* . rexps) `(* ,(rexp-groupify (apply rexp-sequence rexps)))) @@ -120,7 +120,7 @@ USA. `(+ ,(rexp-groupify (apply rexp-sequence rexps)))) (define (rexp-groupify rexp) - (let ((group (lambda () `(GROUP ,rexp))) + (let ((group (lambda () `(group ,rexp))) (no-group (lambda () (error "Expression can't be grouped:" rexp)))) (cond ((string? rexp) (case (string-length rexp) @@ -130,30 +130,30 @@ USA. ((pair? rexp) (cond ((memq (car rexp) boundary-rexp-types) (no-group)) - ((memq (car rexp) '(ALTERNATIVES SEQUENCE OPTIONAL * +)) + ((memq (car rexp) '(alternatives sequence optional * +)) (group)) (else rexp))) (else rexp)))) -(define (rexp-any-char) `(ANY-CHAR)) -(define (rexp-line-start) `(LINE-START)) -(define (rexp-line-end) `(LINE-END)) -(define (rexp-string-start) `(STRING-START)) -(define (rexp-string-end) `(STRING-END)) -(define (rexp-word-edge) `(WORD-EDGE)) -(define (rexp-not-word-edge) `(NOT-WORD-EDGE)) -(define (rexp-word-start) `(WORD-START)) -(define (rexp-word-end) `(WORD-END)) -(define (rexp-word-char) `(WORD-CHAR)) -(define (rexp-not-word-char) `(NOT-WORD-CHAR)) -(define (rexp-syntax-char type) `(SYNTAX-CHAR ,type)) -(define (rexp-not-syntax-char type) `(NOT-SYNTAX-CHAR ,type)) +(define (rexp-any-char) `(any-char)) +(define (rexp-line-start) `(line-start)) +(define (rexp-line-end) `(line-end)) +(define (rexp-string-start) `(string-start)) +(define (rexp-string-end) `(string-end)) +(define (rexp-word-edge) `(word-edge)) +(define (rexp-not-word-edge) `(not-word-edge)) +(define (rexp-word-start) `(word-start)) +(define (rexp-word-end) `(word-end)) +(define (rexp-word-char) `(word-char)) +(define (rexp-not-word-char) `(not-word-char)) +(define (rexp-syntax-char type) `(syntax-char ,type)) +(define (rexp-not-syntax-char type) `(not-syntax-char ,type)) (define (rexp-case-fold rexp) (cond ((or (string? rexp) (char-set? rexp)) - `(CASE-FOLD ,rexp)) + `(case-fold ,rexp)) ((and (pair? rexp) - (memq (car rexp) '(ALTERNATIVES SEQUENCE GROUP OPTIONAL * +)) + (memq (car rexp) '(alternatives sequence group optional * +)) (list? (cdr rexp))) (cons (car rexp) (map rexp-case-fold (cdr rexp)))) @@ -183,32 +183,32 @@ USA. (cdr entry) (lose)))))) (case (car rexp) - ((ALTERNATIVES) + ((alternatives) (decorated-string-append "" "\\|" "" (rexp-args))) - ((SEQUENCE) (apply string-append (rexp-args))) - ((GROUP) (string-append "\\(" (rexp-arg) "\\)")) - ((OPTIONAL) (string-append (rexp-arg) "?")) + ((sequence) (apply string-append (rexp-args))) + ((group) (string-append "\\(" (rexp-arg) "\\)")) + ((optional) (string-append (rexp-arg) "?")) ((*) (string-append (rexp-arg) "*")) ((+) (string-append (rexp-arg) "+")) - ((CASE-FOLD) + ((case-fold) (rexp->regexp (let ((arg (one-arg))) (cond ((string? arg) (case-fold-string arg)) ((char-set? arg) (case-fold-char-set arg)) (else (lose)))))) - ((ANY-CHAR) ".") - ((LINE-START) "^") - ((LINE-END) "$") - ((STRING-START) "\\`") - ((STRING-END) "\\'") - ((WORD-EDGE) "\\b") - ((NOT-WORD-EDGE) "\\B") - ((WORD-START) "\\<") - ((WORD-END) "\\>") - ((WORD-CHAR) "\\w") - ((NOT-WORD-CHAR) "\\W") - ((SYNTAX-CHAR) (string-append "\\s" (syntax-type))) - ((NOT-SYNTAX-CHAR) (string-append "\\S" (syntax-type))) + ((any-char) ".") + ((line-start) "^") + ((line-end) "$") + ((string-start) "\\`") + ((string-end) "\\'") + ((word-edge) "\\b") + ((not-word-edge) "\\B") + ((word-start) "\\<") + ((word-end) "\\>") + ((word-char) "\\w") + ((not-word-char) "\\W") + ((syntax-char) (string-append "\\s" (syntax-type))) + ((not-syntax-char) (string-append "\\S" (syntax-type))) (else (lose)))))) (else (lose))))) @@ -241,10 +241,10 @@ USA. (apply char-set chars*)))) (define (rexp-n*m n m . rexps) - (guarantee exact-nonnegative-integer? n 'REXP-N*M) - (guarantee exact-nonnegative-integer? m 'REXP-N*M) + (guarantee exact-nonnegative-integer? n 'rexp-n*m) + (guarantee exact-nonnegative-integer? m 'rexp-n*m) (if (not (<= n m)) - (error:bad-range-argument m 'REXP-N*M)) + (error:bad-range-argument m 'rexp-n*m)) (let ((rexp (apply rexp-sequence rexps))) (let loop ((i 1)) (cond ((<= i n) @@ -261,7 +261,7 @@ USA. (apply rexp-n*m 0 n rexps)) (define (rexp-n* n . rexps) - (guarantee exact-nonnegative-integer? n 'REXP-N*) + (guarantee exact-nonnegative-integer? n 'rexp-n*) (let ((rexp (apply rexp-sequence rexps))) (if (= n 0) (rexp* rexp) diff --git a/src/runtime/rfc2822-headers.scm b/src/runtime/rfc2822-headers.scm index fc5e889bb..f37f4ed02 100644 --- a/src/runtime/rfc2822-headers.scm +++ b/src/runtime/rfc2822-headers.scm @@ -69,13 +69,13 @@ USA. #t)))) (define (first-rfc2822-header name headers) - (guarantee-list-of rfc2822-header? headers 'FIRST-RFC2822-HEADER) + (guarantee-list-of rfc2822-header? headers 'first-rfc2822-header) (find (lambda (header) (eq? (rfc2822-header-name header) name)) headers)) (define (all-rfc2822-headers name headers) - (guarantee-list-of rfc2822-header? headers 'ALL-RFC2822-HEADERS) + (guarantee-list-of rfc2822-header? headers 'all-rfc2822-headers) (filter (lambda (header) (eq? (rfc2822-header-name header) name)) headers)) @@ -88,7 +88,7 @@ USA. (write-rfc2822-headers headers port)))) (define (write-rfc2822-headers headers port) - (guarantee-list-of rfc2822-header? headers 'WRITE-RFC2822-HEADERS) + (guarantee-list-of rfc2822-header? headers 'write-rfc2822-headers) (for-each (lambda (header) (write-header header port)) headers) @@ -158,7 +158,7 @@ USA. ((char-wsp? (string-ref line 0)) (parse-error port "Unmatched continuation line:" - 'READ-RFC2822-FOLDED-LINE)) + 'read-rfc2822-folded-line)) (else (call-with-output-string (lambda (out) @@ -169,7 +169,7 @@ USA. (if (eof-object? char) (parse-error port "Premature EOF:" - 'READ-RFC2822-FOLDED-LINE)) + 'read-rfc2822-folded-line)) (char-wsp? char)) (begin (write-char #\space out) @@ -253,18 +253,18 @@ USA. (char-set-difference char-set:rfc2822-text (char-set #\tab #\space #\delete #\\ #\"))) (set! condition-type:rfc2822-parse-error - (make-condition-type 'RFC2822-PARSE-ERROR + (make-condition-type 'rfc2822-parse-error condition-type:port-error - '(MESSAGE IRRITANTS) + '(message irritants) (lambda (condition port) (write-string "Error while parsing RFC 2822 headers: " 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! parse-error (let ((signal (condition-signaller condition-type:rfc2822-parse-error - '(PORT MESSAGE IRRITANTS) + '(port message irritants) standard-error-handler))) (lambda (port message . irritants) (signal port message irritants)))) diff --git a/src/runtime/savres.scm b/src/runtime/savres.scm index 7f122cd72..ab2018634 100644 --- a/src/runtime/savres.scm +++ b/src/runtime/savres.scm @@ -71,7 +71,7 @@ USA. (((ucode-primitive dump-band) restart (string-for-primitive filename))) - (with-simple-restart 'RETRY "Try again." + (with-simple-restart 'retry "Try again." (lambda () (error "Disk save failed:" filename)))) (continuation @@ -130,7 +130,7 @@ USA. (let ((port (if (default-object? port) (current-output-port) - (guarantee textual-output-port? port 'IDENTIFY-WORLD)))) + (guarantee textual-output-port? port 'identify-world)))) (write-mit-scheme-copyright port #!default #!default #t) (newline port) (write-mit-scheme-license port #!default #t) diff --git a/src/runtime/scan.scm b/src/runtime/scan.scm index adf54347e..3c1f2ede8 100644 --- a/src/runtime/scan.scm +++ b/src/runtime/scan.scm @@ -46,7 +46,7 @@ USA. (ucode-type sequence)) (define null-sequence - '(NULL-SEQUENCE)) + '(null-sequence)) (define (cons-sequence action seq) (if (eq? seq null-sequence) @@ -64,7 +64,7 @@ USA. ((scan-loop expression receiver) '() '() null-sequence)) (define (scan-loop expression receiver) - (cond ((scode-open-block? expression) ; must come before SCODE-SEQUENCE? clause + (cond ((scode-open-block? expression) ;must come before SCODE-SEQUENCE? clause (scan-loop (%open-block-actions expression) (lambda (names declarations body) @@ -136,7 +136,7 @@ USA. (receive (names* body*) (unscan-loop names body) (if (not (null? names*)) (error "Extraneous auxiliaries -- get a wizard" - 'UNSCAN-DEFINES + 'unscan-defines names*)) (if (null? declarations) diff --git a/src/runtime/sfile.scm b/src/runtime/sfile.scm index fe363867b..d8dd5f74d 100644 --- a/src/runtime/sfile.scm +++ b/src/runtime/sfile.scm @@ -58,28 +58,28 @@ USA. (->namestring (merge-pathnames filename)))))) (and n (let ((types - '#(REGULAR - DIRECTORY - UNIX-SYMBOLIC-LINK - UNIX-CHARACTER-DEVICE - UNIX-BLOCK-DEVICE - UNIX-NAMED-PIPE - UNIX-SOCKET - UNKNOWN - WIN32-NAMED-PIPE))) + '#(regular + directory + unix-symbolic-link + unix-character-device + unix-block-device + unix-named-pipe + unix-socket + unknown + win32-named-pipe))) (if (fix:< n (vector-length types)) (vector-ref types n) - 'UNKNOWN)))))))) + 'unknown)))))))) (set! file-type-direct (make-file-type (ucode-primitive file-type-direct 1))) (set! file-type-indirect (make-file-type (ucode-primitive file-type-indirect 1)))) (define (file-regular? filename) - (eq? 'REGULAR (file-type-indirect filename))) + (eq? 'regular (file-type-indirect filename))) (define (file-directory? filename) - (eq? 'DIRECTORY (file-type-indirect filename))) + (eq? 'directory (file-type-indirect filename))) (define (file-symbolic-link? filename) ((ucode-primitive file-symlink? 1) @@ -291,13 +291,13 @@ USA. (string->mime-type string))))))) (define (associate-pathname-type-with-mime-type type mime-type) - (guarantee string? type 'ASSOCIATE-PATHNAME-TYPE-WITH-MIME-TYPE) - (guarantee mime-type? mime-type 'ASSOCIATE-PATHNAME-TYPE-WITH-MIME-TYPE) + (guarantee string? type 'associate-pathname-type-with-mime-type) + (guarantee mime-type? mime-type 'associate-pathname-type-with-mime-type) (hash-table/put! local-type-map type mime-type)) (define (disassociate-pathname-type-from-mime-type type) - (guarantee string? type 'DISASSOCIATE-PATHNAME-TYPE-FROM-MIME-TYPE) - (hash-table/put! local-type-map type 'DISASSOCIATED)) + (guarantee string? type 'disassociate-pathname-type-from-mime-type) + (hash-table/put! local-type-map type 'disassociated)) (define-record-type (%%make-mime-type top-level subtype) @@ -306,8 +306,8 @@ USA. (subtype mime-type/subtype)) (define (make-mime-type top-level subtype) - (guarantee mime-token? top-level 'MAKE-MIME-TYPE) - (guarantee mime-token? subtype 'MAKE-MIME-TYPE) + (guarantee mime-token? top-level 'make-mime-type) + (guarantee mime-token? subtype 'make-mime-type) (%make-mime-type top-level subtype)) (define (%make-mime-type top-level subtype) @@ -325,10 +325,10 @@ USA. new))))) (define top-level-mime-types - '#(TEXT IMAGE AUDIO VIDEO APPLICATION MULTIPART MESSAGE)) + '#(text image audio video application multipart message)) (define-unparser-method mime-type? - (standard-unparser-method 'MIME-TYPE + (standard-unparser-method 'mime-type (lambda (mime-type port) (write-char #\space port) (write-string (mime-type->string mime-type) port)))) @@ -353,7 +353,7 @@ USA. (string->char-set "()<>@,;:\\\"/[]?="))) (set! local-type-map (make-string-hash-table)) (associate-pathname-type-with-mime-type "scm" - (make-mime-type 'TEXT 'X-SCHEME)) + (make-mime-type 'text 'x-scheme)) unspecific) (define (mime-type->string mime-type) @@ -362,14 +362,14 @@ USA. (write-mime-type mime-type port)))) (define (write-mime-type mime-type port) - (guarantee mime-type? mime-type 'WRITE-MIME-TYPE) + (guarantee mime-type? mime-type 'write-mime-type) (write-string (symbol->string (mime-type/top-level mime-type)) port) (write-string "/" port) (write-string (symbol->string (mime-type/subtype mime-type)) port)) (define (string->mime-type string #!optional start end) (vector-ref (or (*parse-string parser:mime-type string start end) - (error:not-a mime-type-string? string 'STRING->MIME-TYPE)) + (error:not-a mime-type-string? string 'string->mime-type)) 0)) (define (mime-type-string? object) diff --git a/src/runtime/sha3.scm b/src/runtime/sha3.scm index 7427e0278..5811f9096 100644 --- a/src/runtime/sha3.scm +++ b/src/runtime/sha3.scm @@ -106,23 +106,23 @@ USA. (define (bytevector-u8-xor! bv i x) ;;(declare (no-type-checks) (no-range-checks)) - (guarantee bytevector? bv 'BYTEVECTOR-U8-XOR!) - (guarantee index-fixnum? i 'BYTEVECTOR-U8-XOR!) + (guarantee bytevector? bv 'bytevector-u8-xor!) + (guarantee index-fixnum? i 'bytevector-u8-xor!) (if (not (fix:< i (bytevector-length bv))) - (error:bad-range-argument i 'BYTEVECTOR-U8-XOR!)) - (guarantee u8? x 'BYTEVECTOR-U8-XOR) + (error:bad-range-argument i 'bytevector-u8-xor!)) + (guarantee u8? x 'bytevector-u8-xor) (bytevector-u8-set! bv i (fix:xor x (bytevector-u8-ref bv i)))) (define (bytevector-xor! t ts f fs n) ;;(declare (no-type-checks) (no-range-checks)) - (guarantee bytevector? f 'BYTEVECTOR-XOR!) - (guarantee bytevector? t 'BYTEVECTOR-XOR!) - (guarantee index-fixnum? ts 'BYTEVECTOR-XOR!) - (guarantee index-fixnum? fs 'BYTEVECTOR-XOR!) + (guarantee bytevector? f 'bytevector-xor!) + (guarantee bytevector? t 'bytevector-xor!) + (guarantee index-fixnum? ts 'bytevector-xor!) + (guarantee index-fixnum? fs 'bytevector-xor!) (if (not (fix:<= n (fix:- (bytevector-length t) ts))) - (error:bad-range-argument ts 'BYTEVECTOR-XOR!)) + (error:bad-range-argument ts 'bytevector-xor!)) (if (not (fix:<= n (fix:- (bytevector-length f) fs))) - (error:bad-range-argument fs 'BYTEVECTOR-XOR!)) + (error:bad-range-argument fs 'bytevector-xor!)) (do ((i 0 (fix:+ i 1))) ((fix:>= i n)) (let ((ti (bytevector-u8-ref t (fix:+ ts i))) (fi (bytevector-u8-ref f (fix:+ fs i)))) diff --git a/src/runtime/socket.scm b/src/runtime/socket.scm index f47fb561f..08f40cb61 100644 --- a/src/runtime/socket.scm +++ b/src/runtime/socket.scm @@ -97,10 +97,10 @@ USA. (lambda (k) (let ((result (test-for-io-on-channel server-socket - 'READ + 'read block?))) (case result - ((READ) + ((read) (open-channel (lambda (p) (with-thread-timer-stopped @@ -109,7 +109,7 @@ USA. (channel-descriptor server-socket) peer-address p)))))) - ((PROCESS-STATUS-CHANGE) + ((process-status-change) (handle-subprocess-status-change) (if (channel-closed? server-socket) #f (k))) (else @@ -160,9 +160,9 @@ USA. (define socket-port-type) (define (initialize-package!) (set! socket-port-type - (make-textual-port-type `((CLOSE-INPUT ,socket/close-input) - (CLOSE-OUTPUT ,socket/close-output)) - (generic-i/o-port-type 'CHANNEL 'CHANNEL))) + (make-textual-port-type `((close-input ,socket/close-input) + (close-output ,socket/close-output)) + (generic-i/o-port-type 'channel 'channel))) unspecific) (define (socket/close-input port) diff --git a/src/runtime/srfi-1.scm b/src/runtime/srfi-1.scm index 6c43f3bbf..9d2ea0ce5 100644 --- a/src/runtime/srfi-1.scm +++ b/src/runtime/srfi-1.scm @@ -245,7 +245,7 @@ USA. ;;;; Selectors (define (take lis k) - (guarantee index-fixnum? k 'TAKE) + (guarantee index-fixnum? k 'take) (let recur ((lis lis) (k k)) (if (fix:> k 0) (cons (car lis) @@ -253,7 +253,7 @@ USA. '()))) (define (drop lis k) - (guarantee index-fixnum? k 'DROP) + (guarantee index-fixnum? k 'drop) (%drop lis k)) (define (%drop lis k) @@ -263,7 +263,7 @@ USA. lis))) (define (take! lis k) - (guarantee index-fixnum? k 'TAKE!) + (guarantee index-fixnum? k 'take!) (if (fix:> k 0) (begin (set-cdr! (drop lis (fix:- k 1)) '()) @@ -275,14 +275,14 @@ USA. ;;; the end. (define (take-right lis k) - (guarantee index-fixnum? k 'TAKE-RIGHT) + (guarantee index-fixnum? k 'take-right) (let lp ((lag lis) (lead (%drop lis k))) (if (pair? lead) (lp (cdr lag) (cdr lead)) lag))) (define (drop-right lis k) - (guarantee index-fixnum? k 'DROP-RIGHT) + (guarantee index-fixnum? k 'drop-right) (let recur ((lag lis) (lead (%drop lis k))) (if (pair? lead) (cons (car lag) (recur (cdr lag) (cdr lead))) @@ -292,7 +292,7 @@ USA. ;;; us stop LAG one step early, in time to smash its cdr to (). (define (drop-right! lis k) - (guarantee index-fixnum? k 'DROP-RIGHT!) + (guarantee index-fixnum? k 'drop-right!) (let ((lead (%drop lis k))) (if (pair? lead) ;; Standard case @@ -306,7 +306,7 @@ USA. '()))) (define (split-at x k) - (guarantee index-fixnum? k 'SPLIT-AT) + (guarantee index-fixnum? k 'split-at) (let recur ((lis x) (k k)) (if (fix:> k 0) (receive (prefix suffix) (recur (cdr lis) (fix:- k 1)) @@ -314,7 +314,7 @@ USA. (values '() lis)))) (define (split-at! x k) - (guarantee index-fixnum? k 'SPLIT-AT!) + (guarantee index-fixnum? k 'split-at!) (if (fix:> k 0) (let* ((prev (%drop x (fix:- k 1))) (suffix (cdr prev))) @@ -341,13 +341,13 @@ USA. (define (append-reverse rev-head tail) (let lp ((rev-head rev-head) (tail tail)) - (if (null-list? rev-head 'APPEND-REVERSE) + (if (null-list? rev-head 'append-reverse) tail (lp (cdr rev-head) (cons (car rev-head) tail))))) (define (append-reverse! rev-head tail) (let lp ((rev-head rev-head) (tail tail)) - (if (null-list? rev-head 'APPEND-REVERSE!) + (if (null-list? rev-head 'append-reverse!) tail (let ((next-rev (cdr rev-head))) (set-cdr! rev-head tail) @@ -362,7 +362,7 @@ USA. (define (count pred list1 . lists) (if (pair? lists) (let lp ((list1 list1) (lists lists) (i 0)) - (if (null-list? list1 'COUNT) + (if (null-list? list1 'count) i (receive (as ds) (%cars+cdrs lists) (if (null? as) @@ -382,7 +382,7 @@ USA. (define (unzip2 lis) (let recur ((lis lis)) - (if (null-list? lis 'UNZIP2) + (if (null-list? lis 'unzip2) (values lis lis) (let ((elt (car lis))) (receive (a b) (recur (cdr lis)) @@ -391,7 +391,7 @@ USA. (define (unzip3 lis) (let recur ((lis lis)) - (if (null-list? lis 'UNZIP3) + (if (null-list? lis 'unzip3) (values lis lis lis) (let ((elt (car lis))) (receive (a b c) (recur (cdr lis)) @@ -401,7 +401,7 @@ USA. (define (unzip4 lis) (let recur ((lis lis)) - (if (null-list? lis 'UNZIP4) + (if (null-list? lis 'unzip4) (values lis lis lis lis) (let ((elt (car lis))) (receive (a b c d) (recur (cdr lis)) @@ -412,7 +412,7 @@ USA. (define (unzip5 lis) (let recur ((lis lis)) - (if (null-list? lis 'UNZIP5) + (if (null-list? lis 'unzip5) (values lis lis lis lis lis) (let ((elt (car lis))) (receive (a b c d e) (recur (cdr lis)) @@ -445,7 +445,7 @@ USA. ans (lp tails (apply f (append! lists (list ans))))))) (let lp ((lis lis1) (ans zero)) - (if (null-list? lis 'PAIR-FOLD) + (if (null-list? lis 'pair-fold) ans ;; Grab the cdr now, in case F SET-CDR!s LIS. (let ((tail (cdr lis))) @@ -460,7 +460,7 @@ USA. zero (apply f (append! lists (list (recur cdrs))))))) (let recur ((lis lis1)) - (if (null-list? lis 'PAIR-FOLD-RIGHT) + (if (null-list? lis 'pair-fold-right) zero (f lis (recur (cdr lis))))))) @@ -473,7 +473,7 @@ USA. (apply proc lists) (lp tails))))) (let lp ((lis lis1)) - (if (not (null-list? lis 'PAIR-FOR-EACH)) + (if (not (null-list? lis 'pair-for-each)) ;; Grab the cdr now, in case PROC SET-CDR!s LIS. (let ((tail (cdr lis))) (proc lis) @@ -484,7 +484,7 @@ USA. (define (map! f lis1 . lists) (if (pair? lists) (let lp ((lis1 lis1) (lists lists)) - (if (not (null-list? lis1 'MAP!)) + (if (not (null-list? lis1 'map!)) (receive (heads tails) (%cars+cdrs/no-test lists) (set-car! lis1 (apply f (car lis1) heads)) (lp (cdr lis1) tails)))) @@ -503,7 +503,7 @@ USA. (else (recur cdrs))) ; Tail call in this arm. '()))) (let recur ((lis lis1)) - (if (null-list? lis 'FILTER-MAP) + (if (null-list? lis 'filter-map) lis (let ((tail (recur (cdr lis)))) (cond ((f (car lis)) => (lambda (x) (cons x tail))) @@ -536,7 +536,7 @@ USA. (cons x (recur cdrs))) '()))) (let recur ((lis lis1)) - (if (null-list? lis 'MAP-IN-ORDER) + (if (null-list? lis 'map-in-order) lis ;; Do head first, then tail. (let ((x (f (car lis)))) @@ -555,7 +555,7 @@ USA. (define (filter pred lis) (let recur ((lis lis)) - (if (null-list? lis 'FILTER) + (if (null-list? lis 'filter) lis (let ((head (car lis)) (tail (cdr lis))) @@ -576,7 +576,7 @@ USA. (define (filter! pred lis) (let lp ((ans lis)) - (cond ((null-list? ans 'FILTER!) ans) ; Scan looking for + (cond ((null-list? ans 'filter!) ans) ; Scan looking for ((not (pred (car ans))) (lp (cdr ans))) ; first cons of result. ;; ANS is the eventual answer. @@ -609,7 +609,7 @@ USA. (define (partition pred lis) (let recur ((lis lis)) - (if (null-list? lis 'PARTITION) + (if (null-list? lis 'partition) (values lis lis) (let ((elt (car lis)) (tail (cdr lis))) @@ -628,7 +628,7 @@ USA. ;;; lists. (define (partition! pred lis) - (if (null-list? lis 'PARTITION!) + (if (null-list? lis 'partition!) (values lis lis) ;; This pair of loops zips down contiguous in & out runs of the @@ -685,7 +685,7 @@ USA. (define (delete-duplicates lis #!optional elt=) (let ((elt= (if (default-object? elt=) equal? elt=))) (let recur ((lis lis)) - (if (null-list? lis 'DELETE-DUPLICATES) + (if (null-list? lis 'delete-duplicates) lis (let* ((x (car lis)) (tail (cdr lis)) @@ -695,7 +695,7 @@ USA. (define (delete-duplicates! lis #!optional elt=) (let ((elt= (if (default-object? elt=) equal? elt=))) (let recur ((lis lis)) - (if (null-list? lis 'DELETE-DUPLICATES!) + (if (null-list? lis 'delete-duplicates!) lis (let* ((x (car lis)) (tail (cdr lis)) @@ -708,13 +708,13 @@ USA. (define (find-tail pred list) (let lp ((list list)) - (and (not (null-list? list 'FIND-TAIL)) + (and (not (null-list? list 'find-tail)) (if (pred (car list)) list (lp (cdr list)))))) (define (take-while pred lis) (let recur ((lis lis)) - (if (null-list? lis 'TAKE-WHILE) + (if (null-list? lis 'take-while) '() (let ((x (car lis))) (if (pred x) @@ -723,14 +723,14 @@ USA. (define (drop-while pred lis) (let lp ((lis lis)) - (if (null-list? lis 'DROP-WHILE) + (if (null-list? lis 'drop-while) '() (if (pred (car lis)) (lp (cdr lis)) lis)))) (define (take-while! pred lis) - (if (or (null-list? lis 'TAKE-WHILE!) + (if (or (null-list? lis 'take-while!) (not (pred (car lis)))) '() (begin @@ -743,7 +743,7 @@ USA. (define (span pred lis) (let recur ((lis lis)) - (if (null-list? lis 'SPAN) + (if (null-list? lis 'span) (values '() '()) (let ((x (car lis))) (if (pred x) @@ -752,11 +752,11 @@ USA. (values '() lis)))))) (define (span! pred lis) - (if (or (null-list? lis 'SPAN!) + (if (or (null-list? lis 'span!) (not (pred (car lis)))) (values '() lis) (let ((suffix (let lp ((prev lis) (rest (cdr lis))) - (if (null-list? rest 'SPAN!) + (if (null-list? rest 'span!) rest (let ((x (car rest))) (if (pred x) (lp rest (cdr rest)) @@ -783,9 +783,9 @@ USA. (or (apply pred heads) (lp next-heads next-tails)) (apply pred heads)))))) - (and (not (null-list? lis1 'ANY)) + (and (not (null-list? lis1 'any)) (let lp ((head (car lis1)) (tail (cdr lis1))) - (if (null-list? tail 'ANY) + (if (null-list? tail 'any) (pred head) (or (pred head) (lp (car tail) (cdr tail)))))))) @@ -800,9 +800,9 @@ USA. (and (apply pred heads) (lp next-heads next-tails)) (apply pred heads)))))) - (or (null-list? lis1 'EVERY) + (or (null-list? lis1 'every) (let lp ((head (car lis1)) (tail (cdr lis1))) - (if (null-list? tail 'EVERY) + (if (null-list? tail 'every) (pred head) (and (pred head) (lp (car tail) (cdr tail)))))))) @@ -815,7 +815,7 @@ USA. (if (apply pred heads) n (lp tails (fix:+ n 1)))))) (let lp ((lis lis1) (n 0)) - (and (not (null-list? lis 'LIST-INDEX)) + (and (not (null-list? lis 'list-index)) (if (pred (car lis)) n (lp (cdr lis) (fix:+ n 1))))))) @@ -861,7 +861,7 @@ USA. (define (lset-union = . lists) (reduce (lambda (lis ans) ; Compute ANS + LIS. (cond ((null? lis) ans) ; Don't copy any lists - ((null? ans) lis) ; if we don't have to. + ((null? ans) lis) ; if we don't have to. ((eq? lis ans) ans) (else (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans) @@ -889,7 +889,7 @@ USA. (define (lset-intersection = lis1 . lists) (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. (cond ((any (lambda (list) - (null-list? list 'LSET-INTERSECTION)) + (null-list? list 'lset-intersection)) lists) '()) ; Short cut ((null? lists) lis1) ; Short cut @@ -900,7 +900,7 @@ USA. (define (lset-intersection! = lis1 . lists) (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. (cond ((any (lambda (list) - (null-list? list 'LSET-INTERSECTION!)) + (null-list? list 'lset-intersection!)) lists) '()) ; Short cut ((null? lists) lis1) ; Short cut @@ -972,7 +972,7 @@ USA. (define (lset-diff+intersection = lis1 . lists) (cond ((every (lambda (list) - (null-list? list 'LSET-DIFF+INTERSECTION)) + (null-list? list 'lset-diff+intersection)) lists) (values lis1 '())) ; Short cut ((memq lis1 lists) (values '() lis1)) ; Short cut @@ -982,7 +982,7 @@ USA. lis1)))) (define (lset-diff+intersection! = lis1 . lists) (cond ((every (lambda (list) - (null-list? list 'LSET-DIFF+INTERSECTION!)) + (null-list? list 'lset-diff+intersection!)) lists) (values lis1 '())) ; Short cut ((memq lis1 lists) (values '() lis1)) ; Short cut diff --git a/src/runtime/stack-sample.scm b/src/runtime/stack-sample.scm index 68cf21987..64b792363 100644 --- a/src/runtime/stack-sample.scm +++ b/src/runtime/stack-sample.scm @@ -79,9 +79,9 @@ ;;;; Miscellaneous Kludgerosity (define (compiled-entry? object) - (object-type? (ucode-type COMPILED-ENTRY) object)) + (object-type? (ucode-type compiled-entry) object)) -(define event-return-address 'UNINITIALIZED) +(define event-return-address 'uninitialized) (define (initialize-package!) (set! stack-sampling-return-address (make-unsettable-parameter #f)) @@ -106,7 +106,7 @@ (and (eq? stack-frame-type/compiled-return-address (stack-frame/type stack-frame)) (stack-frame/return-address stack-frame)))))))) - (do () ((not (eq? event-return-address 'UNINITIALIZED))) + (do () ((not (eq? event-return-address 'uninitialized))) (suspend-current-thread)) (if (not blocked?) (unblock-thread-events)))) @@ -130,7 +130,7 @@ (define (deregister-event) (deregister-timer-event timer-registration) (set! timer-registration #f)) - (values (with-simple-restart 'ABORT "Abort stack sampling." + (values (with-simple-restart 'abort "Abort stack sampling." (lambda () (dynamic-wind register-event @@ -139,7 +139,7 @@ profile))) (define (carefully-record-sample profile continuation) - (with-simple-restart 'CONTINUE "Ignore the sample." + (with-simple-restart 'continue "Ignore the sample." (lambda () (let ((ignore (first-bound-restart))) ;silly (define (go) (record-sample profile continuation)) diff --git a/src/runtime/stream.scm b/src/runtime/stream.scm index 9a6f6edc6..f1054bb48 100644 --- a/src/runtime/stream.scm +++ b/src/runtime/stream.scm @@ -36,11 +36,11 @@ USA. (define-guarantee stream-pair "stream pair") (define (stream-car stream) - (guarantee stream-pair? stream 'STREAM-CAR) + (guarantee stream-pair? stream 'stream-car) (car stream)) (define (stream-cdr stream) - (guarantee stream-pair? stream 'STREAM-CDR) + (guarantee stream-pair? stream 'stream-cdr) (force (cdr stream))) (define the-empty-stream '()) @@ -60,33 +60,33 @@ USA. (loop (force (cdr stream)) (+ n 1)) (begin (if (not (null? stream)) - (error:illegal-stream-element stream 'STREAM-LENGTH 0)) + (error:illegal-stream-element stream 'stream-length 0)) n)))) (define (stream-ref stream index) (let ((tail (stream-tail stream index))) (if (not (stream-pair? tail)) - (error:bad-range-argument index 'STREAM-REF)) + (error:bad-range-argument index 'stream-ref)) (car tail))) (define (stream-head stream index) - (guarantee exact-nonnegative-integer? index 'STREAM-HEAD) + (guarantee exact-nonnegative-integer? index 'stream-head) (let loop ((stream stream) (index index)) (if (> index 0) (begin (if (not (stream-pair? stream)) - (error:bad-range-argument index 'STREAM-HEAD)) + (error:bad-range-argument index 'stream-head)) (cons (car stream) (loop (force (cdr stream)) (- index 1)))) '()))) (define (stream-tail stream index) - (guarantee exact-nonnegative-integer? index 'STREAM-TAIL) + (guarantee exact-nonnegative-integer? index 'stream-tail) (let loop ((stream stream) (index index)) (if (> index 0) (begin (if (not (stream-pair? stream)) - (error:bad-range-argument index 'STREAM-TAIL)) + (error:bad-range-argument index 'stream-tail)) (loop (force (cdr stream)) (- index 1))) stream))) @@ -96,21 +96,21 @@ USA. (define (stream-last-pair stream) (if (not (stream-pair? stream)) (if (null? stream) - (error:bad-range-argument stream 'STREAM-LAST-PAIR) - (error:illegal-stream-element stream 'STREAM-LAST-PAIR 0))) + (error:bad-range-argument stream 'stream-last-pair) + (error:illegal-stream-element stream 'stream-last-pair 0))) (let loop ((stream stream)) (let ((next (force (cdr stream)))) (if (stream-pair? next) (loop next) (begin (if (not (null? next)) - (error:illegal-stream-element stream 'STREAM-LAST-PAIR 0)) + (error:illegal-stream-element stream 'stream-last-pair 0)) stream))))) (define (stream-map procedure stream . streams) (cond ((pair? streams) (let loop ((streams (cons stream streams))) - (receive (cars cdrs) (split-streams streams 'STREAM-MAP) + (receive (cars cdrs) (split-streams streams 'stream-map) (if (pair? cars) (cons-stream (apply procedure cars) (loop (map force cdrs))) @@ -123,7 +123,7 @@ USA. (loop (force (cdr stream)))) (begin (if (not (null? stream)) - (error:illegal-stream-element stream 'STREAM-MAP 1)) + (error:illegal-stream-element stream 'stream-map 1)) '())))) ((and (procedure? stream) (or (null? procedure) (stream-pair? procedure))) @@ -135,7 +135,7 @@ USA. (define (stream-for-each procedure stream . streams) (if (pair? streams) (let loop ((streams (cons stream streams))) - (receive (cars cdrs) (split-streams streams 'STREAM-FOR-EACH) + (receive (cars cdrs) (split-streams streams 'stream-for-each) (if (pair? cars) (begin (apply procedure cars) @@ -145,11 +145,11 @@ USA. (procedure (car stream)) (loop (force (cdr stream)))) ((not (null? stream)) - (error:illegal-stream-element stream 'STREAM-FOR-EACH 1)))))) + (error:illegal-stream-element stream 'stream-for-each 1)))))) (define (split-streams streams operator) - (let ((cars (list 'CARS)) - (cdrs (list 'CDRS))) + (let ((cars (list 'cars)) + (cdrs (list 'cdrs))) (let loop ((streams streams) (cars-tail cars) (cdrs-tail cdrs) (n 0)) (if (pair? streams) (let ((stream (car streams))) @@ -173,11 +173,11 @@ USA. (cons-stream (car s) (loop (force (cdr s)))) (begin (if (not (null? s)) - (error:illegal-stream-element s1 'STREAM-APPEND 0)) + (error:illegal-stream-element s1 'stream-append 0)) (force s2))))))) (if (pair? streams) (let loop ((streams (cons stream streams))) - (receive (cars cdrs) (split-streams streams 'STREAM-APPEND-MAP) + (receive (cars cdrs) (split-streams streams 'stream-append-map) (if (pair? cars) (sappend (apply procedure cars) (delay (loop (map force cdrs)))) @@ -188,7 +188,7 @@ USA. (delay (loop (force (cdr stream))))) (begin (if (not (null? stream)) - (error:illegal-stream-element stream 'STREAM-APPEND-MAP 1)) + (error:illegal-stream-element stream 'stream-append-map 1)) '())))))) (define (stream-append . streams) @@ -201,7 +201,7 @@ USA. (inner-loop (force (cdr stream)))) (begin (if (not (null? stream)) - (error:illegal-stream-element stream 'STREAM-APPEND n)) + (error:illegal-stream-element stream 'stream-append n)) (outer-loop (cdr streams) (fix:+ n 1))))) (car streams))) '())) @@ -212,7 +212,7 @@ USA. (stream-accumulate procedure initial (force (cdr stream)))) (begin (if (not (null? stream)) - (error:illegal-stream-element stream 'STREAM-ACCUMULATE 2)) + (error:illegal-stream-element stream 'stream-accumulate 2)) initial))) (define (stream-filter predicate stream) @@ -223,7 +223,7 @@ USA. (stream-filter predicate (force (cdr stream)))) (begin (if (not (null? stream)) - (error:illegal-stream-element stream 'STREAM-FILTER 1)) + (error:illegal-stream-element stream 'stream-filter 1)) '()))) (define (stream-truncate stream predicate) @@ -234,14 +234,14 @@ USA. (stream-truncate (tail stream) predicate))) (begin (if (not (null? stream)) - (error:illegal-stream-element stream 'STREAM-TRUNCATE 1)) + (error:illegal-stream-element stream 'stream-truncate 1)) '()))) (define (stream-write stream #!optional port) (let ((port (if (default-object? port) (current-output-port) - (guarantee textual-output-port? port 'STREAM-WRITE)))) + (guarantee textual-output-port? port 'stream-write)))) (if (stream-pair? stream) (begin (write-char #\{ port) @@ -253,7 +253,7 @@ USA. (write-char #\} port)) (begin (if (not (null? stream)) - (error:illegal-stream-element stream 'STREAM-WRITE 0)) + (error:illegal-stream-element stream 'stream-write 0)) (write-string "{}" port))))) (define (list->stream list) @@ -261,7 +261,7 @@ USA. (cons-stream (car list) (list->stream (cdr list))) (begin (if (not (null? list)) - (error:not-a list? list 'LIST->STREAM)) + (error:not-a list? list 'list->stream)) '()))) (define (stream->list stream) @@ -269,7 +269,7 @@ USA. (elements '())) (cond ((stream-pair? s) (loop (tail s) (cons (head s) elements))) ((null? s) (reverse elements)) - (else (error:illegal-stream-element s 'STREAM->LIST 0))))) + (else (error:illegal-stream-element s 'stream->list 0))))) (define prime-numbers-stream) @@ -314,23 +314,23 @@ USA. (define (initialize-conditions!) (set! condition-type:illegal-stream-element - (make-condition-type 'ILLEGAL-STREAM-ELEMENT + (make-condition-type 'illegal-stream-element condition-type:wrong-type-argument '() (lambda (condition port) (write-string "The object " port) - (write (access-condition condition 'DATUM) port) + (write (access-condition condition 'datum) port) (write-string ", passed as the " port) (write-string (ordinal-number-string - (+ (access-condition condition 'OPERAND) 1)) + (+ (access-condition condition 'operand) 1)) port) (write-string " argument to " port) - (write-operator (access-condition condition 'OPERATOR) port) + (write-operator (access-condition condition 'operator) port) (write-string ", is not a stream." port)))) (set! error:illegal-stream-element (let ((signaller (condition-signaller condition-type:illegal-stream-element - '(TYPE DATUM OPERATOR OPERAND) + '(type datum operator operand) standard-error-handler))) (named-lambda (error:illegal-stream-element stream operator operand) (signaller "stream" stream operator operand)))) diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm index 3a112f9f8..37f44c712 100644 --- a/src/runtime/swank.scm +++ b/src/runtime/swank.scm @@ -84,7 +84,7 @@ USA. unspecific)))) (define (serve socket) - (with-simple-restart 'DISCONNECT "Close connection." + (with-simple-restart 'disconnect "Close connection." (lambda () (with-keyboard-interrupt-handler (lambda () @@ -95,7 +95,7 @@ USA. (new-handler (lambda (char) char - (with-simple-restart 'CONTINUE "Continue from interrupt." + (with-simple-restart 'continue "Continue from interrupt." (lambda () (error "Keyboard Interrupt."))))) (old-handler)) @@ -111,13 +111,13 @@ USA. unspecific)))) (define (disconnect) - (invoke-restart (find-restart 'DISCONNECT))) + (invoke-restart (find-restart 'disconnect))) (define (main-loop socket) (do () (#f) - (with-simple-restart 'ABORT "Return to SLIME top-level." + (with-simple-restart 'abort "Return to SLIME top-level." (lambda () - (parameterize* (list (cons *top-level-restart* (find-restart 'ABORT))) + (parameterize* (list (cons *top-level-restart* (find-restart 'abort))) (lambda () (process-one-message socket 0))))))) @@ -277,7 +277,7 @@ USA. #t) :repl-result) socket) - 'NIL) + 'nil) (define (interactive-eval sexp socket nl?) (let ((value (repl-eval sexp socket))) @@ -298,7 +298,7 @@ USA. (define (repl-eval sexp socket) (with-output-to-repl socket (lambda () - (with-repl-eval-boundary 'SWANK + (with-repl-eval-boundary 'swank (lambda () (eval sexp (buffer-env))))))) @@ -317,12 +317,12 @@ USA. (set! *buffer-pstring* (make-unsettable-parameter unspecific)) (set! repl-port-type (make-textual-port-type - `((WRITE-CHAR + `((write-char ,(lambda (port char) (write-message `(:write-string ,(string char)) (textual-port-state port)) 1)) - (WRITE-SUBSTRING + (write-substring ,(lambda (port string start end) (if (< start end) (write-message `(:write-string ,(substring string start end)) @@ -364,7 +364,7 @@ USA. run-time gc-time (set! time real-time) unspecific)) - (list 'NIL (string (internal-time/ticks->seconds time))))) + (list 'nil (string (internal-time/ticks->seconds time))))) (define (swank:compile-file-for-emacs socket file load?) (call-compiler @@ -501,7 +501,7 @@ USA. (carefully-pa (eval (read-from-string name) (pstring->env pstring))))))))))) - (if (condition? v) 'NIL v))) + (if (condition? v) 'nil v))) (define (carefully-pa o) (cond ((arity-dispatched-procedure? o) @@ -591,12 +591,12 @@ USA. (define (swank:buffer-first-change socket filename) socket filename - 'NIL) + 'nil) ;; M-. is beyond my capabilities. (define (swank:find-definitions-for-emacs socket name) socket name - 'NIL) + 'nil) #| ;;; List of names obtained by grepping through "slime.el" and @@ -680,11 +680,11 @@ swank:xref socket) (sldb-loop level socket)) (lambda () - (write-message `(:debug-return 0 ,(- level 1) 'NIL) socket)))))) + (write-message `(:debug-return 0 ,(- level 1) 'nil) socket)))))) (define (sldb-loop level socket) (write-message `(:debug-activate 0 ,level) socket) - (with-simple-restart 'ABORT (string "Return to SLDB level " level ".") + (with-simple-restart 'abort (string "Return to SLDB level " level ".") (lambda () (process-one-message socket level))) (sldb-loop level socket)) @@ -694,7 +694,7 @@ swank:xref (rs (sldb-state.restarts state))) (list (list (condition/report-string c) (string " [" (condition-type/name (condition/type c)) "]") - 'NIL) + 'nil) (sldb-restarts rs) (sldb-backtrace c start end) ;;'((0 "dummy frame")) @@ -878,9 +878,9 @@ swank:xref (map (lambda (symbol) `((:designator ,(string symbol " " pstring)) ,@(case (environment-reference-type env symbol) - ((UNBOUND) '()) - ((UNASSIGNED) `((:variable nil))) - ((MACRO) `((:macro nil))) + ((unbound) '()) + ((unassigned) `((:variable nil))) + ((macro) `((:macro nil))) (else (let ((v (environment-lookup env symbol))) `((,(cond ((procedure? v) ':function) @@ -972,14 +972,14 @@ swank:xref (cond ((istate-previous istate) (set! istate (istate-previous istate)) (istate->elisp istate)) - (else 'NIL))) + (else 'nil))) (define (swank:inspector-next socket) socket (cond ((istate-next istate) (set! istate (istate-next istate)) (istate->elisp istate)) - (else 'NIL))) + (else 'nil))) (define (swank:inspector-range socket from to) socket @@ -988,7 +988,7 @@ swank:xref from to)) (define (iline label value) - `(LINE ,label ,value)) + `(line ,label ,value)) (define (inspect o) (cond ((environment? o) (inspect-environment o)) @@ -1115,7 +1115,7 @@ swank:xref ;;;; Auxilary functions -(define (elisp-false? o) (or (null? o) (eq? o 'NIL))) +(define (elisp-false? o) (or (null? o) (eq? o 'nil))) (define (elisp-true? o) (not (elisp-false? o))) (define (->line o) diff --git a/src/runtime/syncproc.scm b/src/runtime/syncproc.scm index 379853220..0feef1221 100644 --- a/src/runtime/syncproc.scm +++ b/src/runtime/syncproc.scm @@ -29,7 +29,7 @@ USA. (declare (usual-integrations)) -(load-option 'SUBPROCESS) +(load-option 'subprocess) (define-structure (subprocess-context (keyword-constructor make-subprocess-context) @@ -85,16 +85,16 @@ USA. (let loop () (receive (status reason) (synchronous-subprocess-wait process context) (case status - ((EXITED) reason) - ((SIGNALLED) (error:subprocess-signalled process reason)) + ((exited) reason) + ((signalled) (error:subprocess-signalled process reason)) ;++ Give a restart to continue the process and loop? - ((STOPPED) (error:subprocess-stopped process reason)) + ((stopped) (error:subprocess-stopped process reason)) (else (error "Invalid synchronous subprocess status:" status)))))) (lambda () (if (and process ;++ Need a predicate SUBPROCESS-LIVE? or something. - (not (memq (subprocess-status process) '(EXITED SIGNALLED)))) + (not (memq (subprocess-status process) '(exited signalled)))) (ignore-errors (lambda () (subprocess-kill process)))))))) (define (start-subprocess program arguments directory context) @@ -110,8 +110,8 @@ USA. environment)))) (define condition-type:subprocess-abnormal-termination - (make-condition-type 'SUBPROCESS-ABNORMAL-TERMINATION condition-type:error - '(SUBPROCESS REASON) + (make-condition-type 'subprocess-abnormal-termination condition-type:error + '(subprocess reason) #f)) (define (abnormal-termination-type name message) @@ -120,27 +120,27 @@ USA. '() (lambda (condition port) (write-string "Subprocess " port) - (write (access-condition condition 'SUBPROCESS) port) + (write (access-condition condition 'subprocess) port) (write-string " " port) (write-string message port) (write-string " " port) - (write (access-condition condition 'REASON) port) + (write (access-condition condition 'reason) port) (write-string "." port)))) (define condition-type:subprocess-stopped - (abnormal-termination-type 'SUBPROCESS-STOPPED "stopped with signal")) + (abnormal-termination-type 'subprocess-stopped "stopped with signal")) (define error:subprocess-stopped (condition-signaller condition-type:subprocess-stopped - '(SUBPROCESS REASON) + '(subprocess reason) standard-error-handler)) (define condition-type:subprocess-signalled - (abnormal-termination-type 'SUBPROCESS-SIGNALLED "terminated with signal")) + (abnormal-termination-type 'subprocess-signalled "terminated with signal")) (define error:subprocess-signalled (condition-signaller condition-type:subprocess-signalled - '(SUBPROCESS REASON) + '(subprocess reason) standard-error-handler)) (define (synchronous-subprocess-wait process context) diff --git a/src/runtime/syntax-check.scm b/src/runtime/syntax-check.scm index 2c6d93ff4..f6bcefba8 100644 --- a/src/runtime/syntax-check.scm +++ b/src/runtime/syntax-check.scm @@ -50,15 +50,15 @@ USA. (pattern object)) ((symbol? pattern) (case pattern - ((SYMBOL) (symbol? object)) - ((IDENTIFIER) (identifier? object)) - ((DATUM EXPRESSION FORM) #t) - ((R4RS-BVL) (r4rs-lambda-list? object)) - ((MIT-BVL) (mit-lambda-list? object)) - ((STRING) (string? object)) - ((CHAR) (char? object)) - ((URI) (->uri object #f)) - ((INDEX) (exact-nonnegative-integer? object)) + ((symbol) (symbol? object)) + ((identifier) (identifier? object)) + ((datum expression form) #t) + ((r4rs-bvl) (r4rs-lambda-list? object)) + ((mit-bvl) (mit-lambda-list? object)) + ((string) (string? object)) + ((char) (char? object)) + ((uri) (->uri object #f)) + ((index) (exact-nonnegative-integer? object)) (else (match-error)))) ((pair? pattern) (case (car pattern) @@ -97,7 +97,7 @@ USA. (syntax-match? pattern object)) (cdr pattern)) (match-error))) - ((QUOTE) + ((quote) (if (and (pair? (cdr pattern)) (null? (cddr pattern))) (eqv? (cadr pattern) object) diff --git a/src/runtime/syntax-declaration.scm b/src/runtime/syntax-declaration.scm index ede42ac19..b99ff000f 100644 --- a/src/runtime/syntax-declaration.scm +++ b/src/runtime/syntax-declaration.scm @@ -64,7 +64,7 @@ USA. (define known-declarations '()) (for-each (lambda (keyword) - (define-declaration keyword '(* IDENTIFIER) + (define-declaration keyword '(* identifier) (lambda (procedure declaration selector) (cons (car declaration) (map+ procedure diff --git a/src/runtime/system.scm b/src/runtime/system.scm index be464007e..805b64c07 100644 --- a/src/runtime/system.scm +++ b/src/runtime/system.scm @@ -32,7 +32,7 @@ USA. (define (add-subsystem-identification! name version) (if (not (and (string? name) (not (string-null? name)))) (error:wrong-type-argument name "non-null string" - 'ADD-SUBSYSTEM-IDENTIFICATION!)) + 'add-subsystem-identification!)) (let ((version (let loop ((version version)) (append-map (lambda (version) -- 2.25.1