From cd9093c20fb5fc448c40e18d3c0629ef46d9e689 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 20 Feb 2017 22:36:08 -0800 Subject: [PATCH] Eliminate references to symbol-append. --- src/compiler/base/lvalue.scm | 14 +++++----- src/compiler/base/macros.scm | 36 ++++++++++++------------- src/compiler/base/utils.scm | 2 +- src/compiler/fggen/canon.scm | 9 +++---- src/compiler/fggen/fggen.scm | 2 +- src/compiler/machines/C/lapgen.scm | 3 +-- src/compiler/machines/C/rules3.scm | 2 +- src/compiler/machines/C/stackops.scm | 4 +-- src/compiler/machines/i386/lapgen.scm | 14 +++++----- src/compiler/machines/i386/rules3.scm | 4 +-- src/compiler/machines/svm/machine.scm | 20 +++++++------- src/compiler/machines/svm/rules.scm | 2 +- src/compiler/machines/x86-64/lapgen.scm | 5 ++-- src/compiler/machines/x86-64/rules3.scm | 4 +-- src/compiler/rtlbase/rtlreg.scm | 6 ++--- src/compiler/rtlbase/valclass.scm | 6 ++--- src/edwin/buffer.scm | 4 +-- src/edwin/editor.scm | 2 +- src/edwin/macros.scm | 6 ++--- src/edwin/tterm.scm | 8 +++--- src/edwin/xcom.scm | 8 +++--- src/runtime/arith.scm | 16 +++++------ src/runtime/defstr.scm | 16 +++++------ src/runtime/graphics.scm | 4 +-- src/runtime/infstr.scm | 2 +- src/runtime/parse.scm | 4 +-- src/runtime/pgsql.scm | 18 ++++++------- src/runtime/rgxcmp.scm | 2 +- src/runtime/starbase.scm | 8 +++--- src/sf/object.scm | 10 +++---- src/win32/ffimacro.scm | 2 +- src/win32/win_ffi.scm | 2 +- src/x11-screen/x11-command.scm | 4 +-- src/xdoc/xdoc.scm | 4 +-- src/xml/xhtml.scm | 4 +-- src/xml/xml-struct.scm | 24 ++++++++--------- tests/runtime/test-entity.scm | 18 ++++++------- tests/runtime/test-floenv.scm | 36 ++++++++++++------------- tests/runtime/test-hash-table.scm | 8 +++--- 39 files changed, 169 insertions(+), 174 deletions(-) diff --git a/src/compiler/base/lvalue.scm b/src/compiler/base/lvalue.scm index 4f8316770..ebfd3c98d 100644 --- a/src/compiler/base/lvalue.scm +++ b/src/compiler/base/lvalue.scm @@ -110,17 +110,17 @@ USA. (lambda (form environment) environment (let* ((name (cadr form)) - (symbol + (variable-name (intern (string-append "#[" (symbol->string name) "]")))) `(BEGIN (DEFINE-INTEGRABLE - (,(symbol-append 'MAKE- name '-VARIABLE) BLOCK) - (MAKE-VARIABLE BLOCK ',symbol)) + (,(symbol 'MAKE- name '-VARIABLE) BLOCK) + (MAKE-VARIABLE BLOCK ',variable-name)) (DEFINE-INTEGRABLE - (,(symbol-append 'VARIABLE/ name '-VARIABLE?) LVALUE) - (EQ? (VARIABLE-NAME LVALUE) ',symbol)) - (DEFINE (,(symbol-append name '-VARIABLE?) LVALUE) + (,(symbol 'VARIABLE/ name '-VARIABLE?) LVALUE) + (EQ? (VARIABLE-NAME LVALUE) ',variable-name)) + (DEFINE (,(symbol name '-VARIABLE?) LVALUE) (AND (VARIABLE? LVALUE) - (EQ? (VARIABLE-NAME LVALUE) ',symbol)))))))) + (EQ? (VARIABLE-NAME LVALUE) ',variable-name)))))))) (define-named-variable continuation) (define-named-variable value) diff --git a/src/compiler/base/macros.scm b/src/compiler/base/macros.scm index c0e62ddae..ff26f94a4 100644 --- a/src/compiler/base/macros.scm +++ b/src/compiler/base/macros.scm @@ -86,11 +86,11 @@ USA. (slots (cdddr form))) (let ((make-defs (lambda (slot index) - (let ((ref-name (symbol-append class '- slot))) + (let ((ref-name (symbol class '- slot))) `((DEFINE-INTEGRABLE (,ref-name V) (VECTOR-REF V ,index)) (DEFINE-INTEGRABLE - (,(symbol-append 'SET- ref-name '!) V OBJECT) + (,(symbol 'SET- ref-name '!) V OBJECT) (VECTOR-SET! V ,index OBJECT))))))) (if (pair? slots) `(BEGIN @@ -117,12 +117,12 @@ USA. (if (syntax-match? pattern (cdr form)) (let ((type (cadr form)) (slots (cddr form))) - (let ((tag-name (symbol-append type '-TAG))) + (let ((tag-name (symbol type '-TAG))) (let ((tag-ref (close-syntax tag-name environment))) `(BEGIN (DEFINE ,tag-name (MAKE-VECTOR-TAG #F ',type #F)) - (DEFINE ,(symbol-append type '?) + (DEFINE ,(symbol type '?) (TAGGED-VECTOR/SUBCLASS-PREDICATE ,tag-ref)) (DEFINE-VECTOR-SLOTS ,type 1 ,@slots) (SET-VECTOR-TAG-DESCRIPTION! ,tag-ref @@ -137,8 +137,8 @@ USA. (reserved (caddr form)) (enumeration (close-syntax (cadddr form) environment))) (let ((parent - (close-syntax (symbol-append name '-TAG) environment))) - `(define-syntax ,(symbol-append 'DEFINE- name) + (close-syntax (symbol name '-TAG) environment))) + `(define-syntax ,(symbol 'DEFINE- name) (sc-macro-transformer (let ((pattern `(SYMBOL * ,(lambda (x) @@ -149,14 +149,14 @@ USA. (if (syntax-match? pattern (cdr form)) (let ((type (cadr form)) (slots (cddr form))) - (let ((tag-name (symbol-append type '-TAG))) + (let ((tag-name (symbol type '-TAG))) (let ((tag-ref (close-syntax tag-name environment))) `(BEGIN (DEFINE ,tag-name (MAKE-VECTOR-TAG ,',parent ',type ,',enumeration)) - (DEFINE ,(symbol-append type '?) + (DEFINE ,(symbol type '?) (TAGGED-VECTOR/PREDICATE ,tag-ref)) (DEFINE-VECTOR-SLOTS ,type ,,reserved ,@slots) @@ -191,7 +191,7 @@ USA. (slots (cdddr form))) (let ((ref-name (lambda (slot) - (close-syntax (symbol-append type '- slot) + (close-syntax (symbol type '- slot) environment)))) `(LIST ,@(map (lambda (slot) @@ -290,18 +290,18 @@ USA. (SET! ,types (CONS ',type ,types)) ,(let ((parameters (map make-synthetic-identifier components))) `(DEFINE-INTEGRABLE - (,(symbol-append prefix 'MAKE- type) ,@parameters) + (,(symbol prefix 'MAKE- type) ,@parameters) ,(wrap-constructor `(LIST ',type ,@parameters)))) - (DEFINE-INTEGRABLE (,(symbol-append 'RTL: type '?) EXPRESSION) + (DEFINE-INTEGRABLE (,(symbol 'RTL: type '?) EXPRESSION) (EQ? (CAR EXPRESSION) ',type)) ,@(let loop ((components components) (ref-index 6) (set-index 2)) (if (pair? components) - (let ((name (symbol-append type '- (car components)))) + (let ((name (symbol type '- (car components)))) `((DEFINE-INTEGRABLE - (,(symbol-append 'RTL: name) OBJECT) + (,(symbol 'RTL: name) OBJECT) (GENERAL-CAR-CDR OBJECT ,ref-index)) (DEFINE-INTEGRABLE - (,(symbol-append 'RTL:SET- name '!) OBJECT V) + (,(symbol 'RTL:SET- name '!) OBJECT V) (SET-CAR! (GENERAL-CAR-CDR OBJECT ,set-index) V)) ,@(loop (cdr components) (* ref-index 2) @@ -358,13 +358,13 @@ USA. (if (syntax-match? '(SYMBOL (* SYMBOL)) (cdr form)) (let ((name (cadr form)) (elements (caddr form))) - (let ((enumeration (symbol-append name 'S))) + (let ((enumeration (symbol name 'S))) (let ((enum-ref (close-syntax enumeration environment))) `(BEGIN (DEFINE ,enumeration (MAKE-ENUMERATION ',elements)) ,@(map (lambda (element) - `(DEFINE ,(symbol-append name '/ element) + `(DEFINE ,(symbol name '/ element) (ENUMERATION/NAME->INDEX ,enum-ref ',element))) elements))))) (ill-formed-syntax form))))) @@ -375,7 +375,7 @@ USA. (if (syntax-match? '(SYMBOL EXPRESSION * (DATUM * EXPRESSION)) (cdr form)) (enumeration-case-1 (caddr form) (cdddr form) environment (lambda (element) - (symbol-append (cadr form) '/ element)) + (symbol (cadr form) '/ element)) (lambda (expression) expression '())) (ill-formed-syntax form))))) @@ -384,7 +384,7 @@ USA. (lambda (form environment) (if (syntax-match? '(EXPRESSION * (DATUM * EXPRESSION)) (cdr form)) (enumeration-case-1 (cadr form) (cddr form) environment - (lambda (element) (symbol-append element '-TAG)) + (lambda (element) (symbol element '-TAG)) (lambda (expression) `((ELSE (ERROR "Unknown node type:" ,expression))))) diff --git a/src/compiler/base/utils.scm b/src/compiler/base/utils.scm index b9c229d40..5dec6dceb 100644 --- a/src/compiler/base/utils.scm +++ b/src/compiler/base/utils.scm @@ -144,7 +144,7 @@ USA. (sc-macro-transformer (lambda (form environment) environment - `(DEFINE-INTEGRABLE ,(symbol-append 'TYPE-CODE: (cadr form)) + `(DEFINE-INTEGRABLE ,(symbol 'TYPE-CODE: (cadr form)) ',(microcode-type (cadr form)))))) (define-type-code lambda) diff --git a/src/compiler/fggen/canon.scm b/src/compiler/fggen/canon.scm index 2083aba35..a1f156402 100644 --- a/src/compiler/fggen/canon.scm +++ b/src/compiler/fggen/canon.scm @@ -835,8 +835,7 @@ ARBITRARY: The expression may be executed more than once. It (lambda (form environment) (let ((name (cadr form))) `(DISPATCH-ENTRY ,name - ,(close-syntax (symbol-append 'CANONICALIZE/ - name) + ,(close-syntax (symbol 'CANONICALIZE/ name) environment)))))) (nary-entry @@ -846,9 +845,9 @@ ARBITRARY: The expression may be executed more than once. It (name (caddr form))) `(DISPATCH-ENTRY ,name ,(close-syntax - `(,(symbol-append 'CANONICALIZE/ nary) - ,(symbol-append 'SCODE/ name '-COMPONENTS) - ,(symbol-append 'SCODE/MAKE- name)) + `(,(symbol 'CANONICALIZE/ nary) + ,(symbol 'SCODE/ name '-COMPONENTS) + ,(symbol 'SCODE/MAKE- name)) environment)))))) (binary-entry diff --git a/src/compiler/fggen/fggen.scm b/src/compiler/fggen/fggen.scm index f9eee18a7..e008fda4f 100644 --- a/src/compiler/fggen/fggen.scm +++ b/src/compiler/fggen/fggen.scm @@ -979,7 +979,7 @@ USA. (lambda (form environment) (let ((name (cadr form))) `(DISPATCH-ENTRY ,name - ,(close-syntax (symbol-append 'GENERATE/ name) + ,(close-syntax (symbol 'GENERATE/ name) environment))))))) (standard-entry access) (standard-entry assignment) diff --git a/src/compiler/machines/C/lapgen.scm b/src/compiler/machines/C/lapgen.scm index 342d398f9..f9a227180 100644 --- a/src/compiler/machines/C/lapgen.scm +++ b/src/compiler/machines/C/lapgen.scm @@ -662,8 +662,7 @@ USA. ,@(let loop ((names (cddr form)) (index (cadr form))) (if (pair? names) (cons `(DEFINE-INTEGRABLE - ,(symbol-append 'CODE:COMPILER- - (car names)) + ,(symbol 'CODE:COMPILER- (car names)) ,index) (loop (cdr names) (1+ index))) `())))))) diff --git a/src/compiler/machines/C/rules3.scm b/src/compiler/machines/C/rules3.scm index 30bfce128..0fa3e71ee 100644 --- a/src/compiler/machines/C/rules3.scm +++ b/src/compiler/machines/C/rules3.scm @@ -157,7 +157,7 @@ USA. ,(make-primitive-procedure name #t)) FRAME-SIZE CONTINUATION (INVOKE-SPECIAL-PRIMITIVE - ,(close-syntax (symbol-append 'CODE:COMPILER- name) + ,(close-syntax (symbol 'CODE:COMPILER- name) environment)))))))) (define-special-primitive-invocation &+) (define-special-primitive-invocation &-) diff --git a/src/compiler/machines/C/stackops.scm b/src/compiler/machines/C/stackops.scm index 3f2ae2895..aa8beb671 100644 --- a/src/compiler/machines/C/stackops.scm +++ b/src/compiler/machines/C/stackops.scm @@ -64,7 +64,7 @@ USA. (bindings '())) (if (not (pair? elements)) (reverse! - (cons `(define ,(symbol-append '* name '*) + (cons `(define ,(symbol '* name '*) '#(,@(reverse! bindings))) code)) (let* ((next (car elements)) @@ -78,7 +78,7 @@ USA. (error "define-enumeration: Overlap" next) m))))) - (let ((name (symbol-append name '/ suffix))) + (let ((name (symbol name '/ suffix))) (loop (+ n 1) (cdr elements) (cons `(DEFINE-INTEGRABLE ,name ,n) diff --git a/src/compiler/machines/i386/lapgen.scm b/src/compiler/machines/i386/lapgen.scm index a260666ba..3f7a8ae27 100644 --- a/src/compiler/machines/i386/lapgen.scm +++ b/src/compiler/machines/i386/lapgen.scm @@ -265,7 +265,7 @@ USA. (define (load-pc-relative-address target label-expr) (with-pc (lambda (pc-label pc-register) - (LAP (LEA ,target (@RO W ,pc-register (- ,label-expr ,pc-label))))))) + (LAP (LEA ,target (@RO W ,pc-register (- ,label-expr ,pc-label))))))) (define (with-pc recvr) (with-values (lambda () (get-cached-label)) @@ -310,7 +310,7 @@ USA. (define (target-register target) (delete-dead-registers!) (or (register-alias target 'GENERAL) - (allocate-alias-register! target 'GENERAL))) + (allocate-alias-register! target 'GENERAL))) (define-integrable (target-register-reference target) (register-reference (target-register target))) @@ -357,7 +357,7 @@ USA. (with-reused-temp (lambda (temp) (need-register! temp) - (with-address-temp temp))) + (with-address-temp temp))) (fail-index (lambda () (with-address-temp @@ -575,8 +575,7 @@ USA. ,@(let loop ((names (cddr form)) (index (cadr form))) (if (pair? names) (cons `(DEFINE-INTEGRABLE - ,(symbol-append 'CODE:COMPILER- - (car names)) + ,(symbol 'CODE:COMPILER- (car names)) ,index) (loop (cdr names) (+ index 1))) '())))))) @@ -584,7 +583,7 @@ USA. (define-codes #x012 primitive-apply primitive-lexpr-apply apply error lexpr-apply link - interrupt-closure interrupt-dlink interrupt-procedure + interrupt-closure interrupt-dlink interrupt-procedure interrupt-continuation interrupt-ic-procedure assignment-trap cache-reference-apply reference-trap safe-reference-trap unassigned?-trap @@ -619,8 +618,7 @@ USA. (if (pair? names) (if (< index high) (cons `(DEFINE-INTEGRABLE - ,(symbol-append 'ENTRY:COMPILER- - (car names)) + ,(symbol 'ENTRY:COMPILER- (car names)) (byte-offset-reference regnum:regs-pointer ,index)) (loop (cdr names) (+ index 4) high)) diff --git a/src/compiler/machines/i386/rules3.scm b/src/compiler/machines/i386/rules3.scm index 8f9e54eed..890d6e355 100644 --- a/src/compiler/machines/i386/rules3.scm +++ b/src/compiler/machines/i386/rules3.scm @@ -233,11 +233,11 @@ USA. (expect-no-exit-interrupt-checks) #| (special-primitive-invocation - ,(close-syntax (symbol-append 'CODE:COMPILER- name) + ,(close-syntax (symbol 'CODE:COMPILER- name) environment)) |# (optimized-primitive-invocation - ,(close-syntax (symbol-append 'ENTRY:COMPILER- name) + ,(close-syntax (symbol 'ENTRY:COMPILER- name) environment)))))))) (define-primitive-invocation &+) diff --git a/src/compiler/machines/svm/machine.scm b/src/compiler/machines/svm/machine.scm index ae6cd502a..fe587c32d 100644 --- a/src/compiler/machines/svm/machine.scm +++ b/src/compiler/machines/svm/machine.scm @@ -73,11 +73,11 @@ USA. (if (syntax-match? '(SYMBOL * SYMBOL) (cdr form)) (let ((tag (cadr form)) (params (cddr form))) - (let ((name (symbol-append 'INST: tag))) + (let ((name (symbol 'INST: tag))) `(BEGIN (DEFINE-INTEGRABLE (,name ,@params) (LIST (LIST ',tag ,@params))) - (DEFINE-INTEGRABLE (,(symbol-append name '?) INST) + (DEFINE-INTEGRABLE (,(symbol name '?) INST) (EQ? (CAR INST) ',tag))))) (ill-formed-syntax form))))) @@ -178,12 +178,12 @@ USA. (if (syntax-match? '(SYMBOL * SYMBOL) (cdr form)) (let ((tag (cadr form)) (params (cddr form))) - (let ((name (symbol-append 'EA: tag))) + (let ((name (symbol 'EA: tag))) `(BEGIN (DEFINE-INTEGRABLE (,name ,@params) (INST-EA (,tag ,@(map (lambda (p) (list 'UNQUOTE p)) params)))) - (DEFINE-INTEGRABLE (,(symbol-append name '?) EA) + (DEFINE-INTEGRABLE (,(symbol name '?) EA) (AND (PAIR? EA) (EQ? (CAR EA) ',tag)))))) (ill-formed-syntax form))))) @@ -257,7 +257,7 @@ USA. ,@(map (lambda (name) (let ((code (if (pair? name) (cadr name) name)) (prim (if (pair? name) (car name) name))) - `(DEFINE (,(symbol-append 'TRAP: prim) . ARGS) + `(DEFINE (,(symbol 'TRAP: prim) . ARGS) (APPLY INST:TRAP ',code ARGS)))) (cdr form)))))) @@ -281,7 +281,7 @@ USA. environment `(BEGIN ,@(map (lambda (name) - `(DEFINE-INST ,(symbol-append 'INTERRUPT-TEST- name))) + `(DEFINE-INST ,(symbol 'INTERRUPT-TEST- name))) (cdr form)))))) (define-interrupt-tests dynamic-link procedure continuation ic-procedure) @@ -331,11 +331,11 @@ USA. '())))) `(BEGIN ,@(map (lambda (p) - `(DEFINE-INTEGRABLE ,(symbol-append 'REGNUM: (car p)) + `(DEFINE-INTEGRABLE ,(symbol 'REGNUM: (car p)) ,(cdr p))) alist) ,@(map (lambda (p) - `(DEFINE-INTEGRABLE ,(symbol-append 'RREF: (car p)) + `(DEFINE-INTEGRABLE ,(symbol 'RREF: (car p)) (REGISTER-REFERENCE ,(cdr p)))) alist) (DEFINE FIXED-REGISTERS ',alist))) @@ -407,12 +407,12 @@ USA. (sc-macro-transformer (lambda (form environment) (if (syntax-match? '(symbol identifier) (cdr form)) - (let ((name (symbol-append 'INTERPRETER- (cadr form))) + (let ((name (symbol 'INTERPRETER- (cadr form))) (regnum (close-syntax (caddr form) environment))) `(BEGIN (DEFINE (,name) (RTL:MAKE-MACHINE-REGISTER ,regnum)) - (DEFINE (,(symbol-append name '?) EXPRESSION) + (DEFINE (,(symbol name '?) EXPRESSION) (AND (RTL:REGISTER? EXPRESSION) (FIX:= (RTL:REGISTER-NUMBER EXPRESSION) ,regnum))))) (ill-formed-syntax form))))) diff --git a/src/compiler/machines/svm/rules.scm b/src/compiler/machines/svm/rules.scm index f67f119e2..16481d3c8 100644 --- a/src/compiler/machines/svm/rules.scm +++ b/src/compiler/machines/svm/rules.scm @@ -725,7 +725,7 @@ USA. frame-size continuation (expect-no-exit-interrupt-checks) (%primitive-invocation - ,(close-syntax (symbol-append 'TRAP: name) environment))))))) + ,(close-syntax (symbol 'TRAP: name) environment))))))) (define (%primitive-invocation make-trap) (LAP ,@(clear-map!) diff --git a/src/compiler/machines/x86-64/lapgen.scm b/src/compiler/machines/x86-64/lapgen.scm index 0be73d44f..61f515b31 100644 --- a/src/compiler/machines/x86-64/lapgen.scm +++ b/src/compiler/machines/x86-64/lapgen.scm @@ -686,8 +686,7 @@ USA. `(BEGIN ,@(let loop ((names (cddr form)) (index (cadr form))) (if (pair? names) - (cons `(DEFINE-INTEGRABLE - ,(symbol-append 'CODE:COMPILER- + (cons `(DEFINE-INTEGRABLE ,(symbol 'CODE:COMPILER- (car names)) ,index) (loop (cdr names) (+ index 1))) @@ -727,7 +726,7 @@ USA. ,@(let loop ((names (cddr form)) (index (cadr form))) (if (pair? names) (cons `(DEFINE-INTEGRABLE - ,(symbol-append 'ENTRY:COMPILER- (car names)) + ,(symbol 'ENTRY:COMPILER- (car names)) (BYTE-OFFSET-REFERENCE REGNUM:REGS-POINTER ,index)) (loop (cdr names) (+ index 8))) '())))))) diff --git a/src/compiler/machines/x86-64/rules3.scm b/src/compiler/machines/x86-64/rules3.scm index b2adced30..85337e125 100644 --- a/src/compiler/machines/x86-64/rules3.scm +++ b/src/compiler/machines/x86-64/rules3.scm @@ -203,11 +203,11 @@ USA. (expect-no-exit-interrupt-checks) #| (special-primitive-invocation - ,(close-syntax (symbol-append 'CODE:COMPILER- name) + ,(close-syntax (symbol 'CODE:COMPILER- name) environment)) |# (optimized-primitive-invocation - ,(close-syntax (symbol-append 'ENTRY:COMPILER- name) + ,(close-syntax (symbol 'ENTRY:COMPILER- name) environment)))))))) (define-primitive-invocation &+) diff --git a/src/compiler/rtlbase/rtlreg.scm b/src/compiler/rtlbase/rtlreg.scm index e5b71b6d6..70a667fdf 100644 --- a/src/compiler/rtlbase/rtlreg.scm +++ b/src/compiler/rtlbase/rtlreg.scm @@ -73,16 +73,16 @@ USA. (sc-macro-transformer (lambda (form environment) (let ((slot (cadr form))) - (let ((name (symbol-append 'REGISTER- slot))) + (let ((name (symbol 'REGISTER- slot))) (let ((vector - `(,(close-syntax (symbol-append 'RGRAPH- name) + `(,(close-syntax (symbol 'RGRAPH- name) environment) *CURRENT-RGRAPH*))) `(BEGIN (DEFINE-INTEGRABLE (,name REGISTER) (VECTOR-REF ,vector REGISTER)) (DEFINE-INTEGRABLE - (,(symbol-append 'SET- name '!) REGISTER VALUE) + (,(symbol 'SET- name '!) REGISTER VALUE) (VECTOR-SET! ,vector REGISTER VALUE))))))))) (define-register-references bblock) diff --git a/src/compiler/rtlbase/valclass.scm b/src/compiler/rtlbase/valclass.scm index 5ca575746..0c5fad011 100644 --- a/src/compiler/rtlbase/valclass.scm +++ b/src/compiler/rtlbase/valclass.scm @@ -85,7 +85,7 @@ USA. (parent-name (caddr form))) (let* ((name->variable (lambda (name) - (symbol-append 'VALUE-CLASS= name))) + (symbol 'VALUE-CLASS= name))) (variable (name->variable name))) `(BEGIN (DEFINE ,variable @@ -95,9 +95,9 @@ USA. (close-syntax (name->variable parent-name) environment) `#F))) - (DEFINE (,(symbol-append variable '?) CLASS) + (DEFINE (,(symbol variable '?) CLASS) (VALUE-CLASS/ANCESTOR-OR-SELF? CLASS ,variable)) - (DEFINE (,(symbol-append 'REGISTER- variable '?) REGISTER) + (DEFINE (,(symbol 'REGISTER- variable '?) REGISTER) (VALUE-CLASS/ANCESTOR-OR-SELF? (REGISTER-VALUE-CLASS REGISTER) ,variable)))))))) diff --git a/src/edwin/buffer.scm b/src/edwin/buffer.scm index 620d4bf8e..537b226c7 100644 --- a/src/edwin/buffer.scm +++ b/src/edwin/buffer.scm @@ -53,8 +53,8 @@ USA. (sc-macro-transformer (lambda (form environment) (let ((slot-name (cadr form))) - `(DEFINE-INTEGRABLE ,(symbol-append 'BUFFER- slot-name) - ,(close-syntax (symbol-append 'BUFFER-% slot-name) + `(DEFINE-INTEGRABLE ,(symbol 'BUFFER- slot-name) + ,(close-syntax (symbol 'BUFFER-% slot-name) environment)))))) (rename-buffer-accessor name) diff --git a/src/edwin/editor.scm b/src/edwin/editor.scm index 2f38855e6..ef6772a98 100644 --- a/src/edwin/editor.scm +++ b/src/edwin/editor.scm @@ -291,7 +291,7 @@ with the contents of the startup message." (define (maybe-debug-scheme-error error-type condition) (let ((p (variable-default-value - (or (name->variable (symbol-append 'DEBUG-ON- error-type '-ERROR) #f) + (or (name->variable (symbol 'DEBUG-ON- error-type '-ERROR) #f) (ref-variable-object debug-on-internal-error))))) (if p (debug-scheme-error error-type condition (eq? p 'ASK)))) diff --git a/src/edwin/macros.scm b/src/edwin/macros.scm index df31897da..850683016 100644 --- a/src/edwin/macros.scm +++ b/src/edwin/macros.scm @@ -93,7 +93,7 @@ USA. (ill-formed-syntax form))))) (define (command-name->scheme-name name) - (symbol-append 'EDWIN-COMMAND$ name)) + (symbol 'EDWIN-COMMAND$ name)) (define-syntax ref-command (sc-macro-transformer @@ -146,7 +146,7 @@ USA. (ill-formed-syntax form))))) (define (variable-name->scheme-name name) - (symbol-append 'EDWIN-VARIABLE$ name)) + (symbol 'EDWIN-VARIABLE$ name)) (define-syntax ref-variable (sc-macro-transformer @@ -261,4 +261,4 @@ USA. (ill-formed-syntax form))))) (define (mode-name->scheme-name name) - (symbol-append 'EDWIN-MODE$ name)) \ No newline at end of file + (symbol 'EDWIN-MODE$ name)) \ No newline at end of file diff --git a/src/edwin/tterm.scm b/src/edwin/tterm.scm index 938475968..60eca3a70 100644 --- a/src/edwin/tterm.scm +++ b/src/edwin/tterm.scm @@ -490,8 +490,8 @@ USA. (sc-macro-transformer (lambda (form environment) (let ((name (cadr form))) - `(DEFINE-INTEGRABLE (,(symbol-append 'SCREEN- name) SCREEN) - (,(close-syntax (symbol-append 'TERMINAL-STATE/ name) + `(DEFINE-INTEGRABLE (,(symbol 'SCREEN- name) SCREEN) + (,(close-syntax (symbol 'TERMINAL-STATE/ name) environment) (SCREEN-STATE SCREEN))))))) @@ -501,9 +501,9 @@ USA. (let ((name (cadr form))) (let ((param (make-synthetic-identifier name))) `(DEFINE-INTEGRABLE - (,(symbol-append 'SET-SCREEN- name '!) SCREEN ,param) + (,(symbol 'SET-SCREEN- name '!) SCREEN ,param) (,(close-syntax - (symbol-append 'SET-TERMINAL-STATE/ name '!) + (symbol 'SET-TERMINAL-STATE/ name '!) environment) (SCREEN-STATE SCREEN) ,param))))))) diff --git a/src/edwin/xcom.scm b/src/edwin/xcom.scm index e1682e396..7c0d9b265 100644 --- a/src/edwin/xcom.scm +++ b/src/edwin/xcom.scm @@ -295,8 +295,8 @@ When called interactively, completion is available on the input." (sc-macro-transformer (lambda (form environment) (let ((name (cadr form))) - `(DEFINE ,(symbol-append 'EDWIN-COMMAND$X- name) - ,(close-syntax (symbol-append 'EDWIN-COMMAND$ name) + `(DEFINE ,(symbol 'EDWIN-COMMAND$X- name) + ,(close-syntax (symbol 'EDWIN-COMMAND$ name) environment)))))) (define-old-mouse-command set-foreground-color) @@ -327,8 +327,8 @@ When called interactively, completion is available on the input." (sc-macro-transformer (lambda (form environment) (let ((name (cadr form))) - `(DEFINE ,(symbol-append 'EDWIN-VARIABLE$X-SCREEN- name) - ,(close-syntax (symbol-append 'EDWIN-VARIABLE$FRAME- name) + `(DEFINE ,(symbol 'EDWIN-VARIABLE$X-SCREEN- name) + ,(close-syntax (symbol 'EDWIN-VARIABLE$FRAME- name) environment)))))) (define-old-screen-command icon-name-format) diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm index 5603e4933..3875d679f 100644 --- a/src/runtime/arith.scm +++ b/src/runtime/arith.scm @@ -156,13 +156,13 @@ USA. ZS)) (VECTOR (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag) - (NAMED-LAMBDA (,(symbol-append 'NULLARY- name)) + (NAMED-LAMBDA (,(symbol 'NULLARY- name)) ,identity) - (NAMED-LAMBDA (,(symbol-append 'UNARY- name) Z) + (NAMED-LAMBDA (,(symbol 'UNARY- name) Z) (IF (NOT (COMPLEX:COMPLEX? Z)) (ERROR:WRONG-TYPE-ARGUMENT Z "number" ',name)) Z) - (NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2) + (NAMED-LAMBDA (,(symbol 'BINARY- name) Z1 Z2) ((UCODE-PRIMITIVE ,(list-ref form 4)) Z1 Z2)))))))))) (commutative + complex:+ 0 &+) (commutative * complex:* 1 &*)) @@ -185,7 +185,7 @@ USA. (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag) #F ,(close-syntax (list-ref form 2) environment) - (NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2) + (NAMED-LAMBDA (,(symbol 'BINARY- name) Z1 Z2) ((UCODE-PRIMITIVE ,(list-ref form 6)) Z1 Z2)))))))))) (non-commutative - complex:negate complex:- complex:+ 0 &-) (non-commutative / complex:invert complex:/ complex:* 1 &/)) @@ -205,14 +205,14 @@ USA. ZS ',name)) (VECTOR (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag) - (NAMED-LAMBDA (,(symbol-append 'NULLARY- name)) #T) - (NAMED-LAMBDA (,(symbol-append 'UNARY- name) Z) + (NAMED-LAMBDA (,(symbol 'NULLARY- name)) #T) + (NAMED-LAMBDA (,(symbol 'UNARY- name) Z) (IF (NOT (,(intern (string-append "complex:" type "?")) Z)) (ERROR:WRONG-TYPE-ARGUMENT Z ,(string-append type " number") ',name)) #T) - (NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2) + (NAMED-LAMBDA (,(symbol 'BINARY- name) Z1 Z2) ,(let ((p `((UCODE-PRIMITIVE ,(list-ref form 3)) Z1 Z2))) (if (list-ref form 5) @@ -238,7 +238,7 @@ USA. (VECTOR (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag) #F - (NAMED-LAMBDA (,(symbol-append 'UNARY- name) X) + (NAMED-LAMBDA (,(symbol 'UNARY- name) X) (IF (NOT (COMPLEX:REAL? X)) (ERROR:WRONG-TYPE-ARGUMENT X "real number" ',name)) X) diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm index d4d133907..6b0870d28 100644 --- a/src/runtime/defstr.scm +++ b/src/runtime/defstr.scm @@ -289,16 +289,16 @@ differences: (car (option/arguments option))) (define (default-conc-name context) - (symbol-append (parser-context/name context) '-)) + (symbol (parser-context/name context) '-)) (define (default-constructor-name context) - (symbol-append 'MAKE- (parser-context/name context))) + (symbol 'MAKE- (parser-context/name context))) (define (default-copier-name context) - (symbol-append 'COPY- (parser-context/name context))) + (symbol 'COPY- (parser-context/name context))) (define (default-predicate-name context) - (symbol-append (parser-context/name context) '?)) + (symbol (parser-context/name context) '?)) (define (default-unparser-text context) `(,(absolute 'STANDARD-UNPARSER-METHOD context) @@ -306,7 +306,7 @@ differences: #F)) (define (default-type-name context) - (symbol-append 'RTD: (parser-context/name context))) + (symbol 'RTD: (parser-context/name context))) (define (apply-option-transformers options context) (let loop ((options options)) @@ -623,7 +623,7 @@ differences: (accessor-name (let ((conc-name (structure/conc-name structure))) (if conc-name - (symbol-append conc-name name) + (symbol conc-name name) name)))) (if (structure/safe-accessors? structure) `(DEFINE ,accessor-name @@ -651,8 +651,8 @@ differences: (modifier-name (let ((conc-name (structure/conc-name structure))) (if conc-name - (symbol-append 'SET- conc-name name '!) - (symbol-append 'SET- name '!))))) + (symbol 'SET- conc-name name '!) + (symbol 'SET- name '!))))) (if (structure/safe-accessors? structure) `(DEFINE ,modifier-name (,(absolute (case (structure/physical-type structure) diff --git a/src/runtime/graphics.scm b/src/runtime/graphics.scm index ebdc689ca..4eaca985c 100644 --- a/src/runtime/graphics.scm +++ b/src/runtime/graphics.scm @@ -259,8 +259,8 @@ USA. (lambda (form environment) (let ((name (cadr form))) `(DEFINE-INTEGRABLE - (,(symbol-append 'GRAPHICS-DEVICE/OPERATION/ name) DEVICE) - (,(close-syntax (symbol-append 'GRAPHICS-DEVICE-TYPE/OPERATION/ + (,(symbol 'GRAPHICS-DEVICE/OPERATION/ name) DEVICE) + (,(close-syntax (symbol 'GRAPHICS-DEVICE-TYPE/OPERATION/ name) environment) (GRAPHICS-DEVICE/TYPE DEVICE))))))) diff --git a/src/runtime/infstr.scm b/src/runtime/infstr.scm index d7938cbf4..cbd802db9 100644 --- a/src/runtime/infstr.scm +++ b/src/runtime/infstr.scm @@ -205,7 +205,7 @@ USA. ((dbg-block-name (sc-macro-transformer (lambda (form environment) - (let ((symbol (symbol-append 'DBG-BLOCK-NAME/ (cadr form)))) + (let ((symbol (symbol 'DBG-BLOCK-NAME/ (cadr form)))) `(DEFINE-INTEGRABLE ,symbol ',((ucode-primitive string->symbol) (string-append "#[(runtime compiler-info)" diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm index 0d44f4ef3..5380c967c 100644 --- a/src/runtime/parse.scm +++ b/src/runtime/parse.scm @@ -1095,7 +1095,7 @@ USA. (let ((name (caadr form)) (field-names (cdadr form)) (reporter (caddr form))) - (let ((ct (symbol-append 'CONDITION-TYPE: name))) + (let ((ct (symbol 'CONDITION-TYPE: name))) `(BEGIN (SET! ,ct (MAKE-CONDITION-TYPE ',name CONDITION-TYPE:PARSE-ERROR @@ -1106,7 +1106,7 @@ USA. `(ACCESS-CONDITION CONDITION ',field-name)) field-names) PORT)))) - (SET! ,(symbol-append 'ERROR: name) + (SET! ,(symbol 'ERROR: name) (CONDITION-SIGNALLER ,ct ',field-names STANDARD-ERROR-HANDLER))))) diff --git a/src/runtime/pgsql.scm b/src/runtime/pgsql.scm index d177dd07c..a747479d6 100644 --- a/src/runtime/pgsql.scm +++ b/src/runtime/pgsql.scm @@ -125,11 +125,11 @@ USA. environment (if (syntax-match? '(SYMBOL EXPRESSION) (cdr form)) (let ((type (cadr form))) - (let ((type? (symbol-append type '?)) - (guarantee-type (symbol-append 'GUARANTEE- type)) - (error:not-type (symbol-append 'ERROR:NOT- type)) - (guarantee-valid-type (symbol-append 'GUARANTEE-VALID- type)) - (type-handle (symbol-append type '-HANDLE))) + (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)) @@ -270,8 +270,8 @@ USA. environment (if (syntax-match? '(SYMBOL) (cdr form)) (let ((field (cadr form))) - `(DEFINE (,(symbol-append 'PGSQL-CONN- field) OBJECT) - (,(symbol-append '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) @@ -350,8 +350,8 @@ USA. environment (if (syntax-match? '(SYMBOL) (cdr form)) (let ((field (cadr form))) - `(DEFINE (,(symbol-append 'PGSQL- field) OBJECT) - (,(symbol-append '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/rgxcmp.scm b/src/runtime/rgxcmp.scm index 87e94bc83..b5e52785a 100644 --- a/src/runtime/rgxcmp.scm +++ b/src/runtime/rgxcmp.scm @@ -42,7 +42,7 @@ USA. ,@(let loop ((n 0) (suffixes suffixes)) (if (pair? suffixes) (cons `(DEFINE-INTEGRABLE - ,(symbol-append prefix (car suffixes)) + ,(symbol prefix (car suffixes)) ,n) (loop (+ n 1) (cdr suffixes))) '())) diff --git a/src/runtime/starbase.scm b/src/runtime/starbase.scm index 9ff8744bd..044c2fb87 100644 --- a/src/runtime/starbase.scm +++ b/src/runtime/starbase.scm @@ -113,15 +113,15 @@ USA. (lambda (form environment) (let ((name (cadr form))) `(BEGIN - (DEFINE (,(symbol-append 'STARBASE-DEVICE/ name) DEVICE) + (DEFINE (,(symbol 'STARBASE-DEVICE/ name) DEVICE) (,(close-syntax - (symbol-append 'STARBASE-GRAPHICS-DESCRIPTOR/ name) + (symbol 'STARBASE-GRAPHICS-DESCRIPTOR/ name) environment) (GRAPHICS-DEVICE/DESCRIPTOR DEVICE))) (DEFINE - (,(symbol-append 'SET-STARBASE-DEVICE/ name '!) DEVICE VALUE) + (,(symbol 'SET-STARBASE-DEVICE/ name '!) DEVICE VALUE) (,(close-syntax - (symbol-append 'SET-STARBASE-GRAPHICS-DESCRIPTOR/ name '!) + (symbol 'SET-STARBASE-GRAPHICS-DESCRIPTOR/ name '!) environment) (GRAPHICS-DEVICE/DESCRIPTOR DEVICE) VALUE))))))) diff --git a/src/sf/object.scm b/src/sf/object.scm index 4ea0f632f..981db88b1 100644 --- a/src/sf/object.scm +++ b/src/sf/object.scm @@ -76,7 +76,7 @@ USA. (DEFINE ,enumeration-name (ENUMERATION/MAKE ',enumerand-names)) ,@(map (lambda (enumerand-name) - `(DEFINE ,(symbol-append enumerand-name '/ENUMERAND) + `(DEFINE ,(symbol enumerand-name '/ENUMERAND) (ENUMERATION/NAME->ENUMERAND ,(close-syntax enumeration-name environment) ',enumerand-name))) @@ -122,11 +122,11 @@ USA. (,name (TYPE VECTOR) (NAMED - ,(close-syntax (symbol-append name '/ENUMERAND) environment)) - (TYPE-DESCRIPTOR ,(symbol-append 'RTD: name)) - (CONC-NAME ,(symbol-append name '/)) + ,(close-syntax (symbol name '/ENUMERAND) environment)) + (TYPE-DESCRIPTOR ,(symbol 'RTD: name)) + (CONC-NAME ,(symbol name '/)) (CONSTRUCTOR ,(or constructor-name - (symbol-append name '/MAKE)))) + (symbol name '/MAKE)))) (scode #f read-only #t) ,@slots) (DEFINE-GUARANTEE ,name ,(symbol->string name))))))) diff --git a/src/win32/ffimacro.scm b/src/win32/ffimacro.scm index e7411f018..2987beea7 100644 --- a/src/win32/ffimacro.scm +++ b/src/win32/ffimacro.scm @@ -235,7 +235,7 @@ to inside a string that is being used as the buffer). (,revert X Y)))))))) (define ((make-type-namer suffix) type #!optional environment) - (let ((name (symbol-append type suffix))) + (let ((name (symbol type suffix))) (if (default-object? environment) name (close-syntax name environment)))) diff --git a/src/win32/win_ffi.scm b/src/win32/win_ffi.scm index b803f00df..20e2e0f07 100644 --- a/src/win32/win_ffi.scm +++ b/src/win32/win_ffi.scm @@ -72,7 +72,7 @@ USA. (intern (string-append "arg" (number->string i)))) indexes)) (type-names - (map (lambda (n) (symbol-append n '-TYPE)) + (map (lambda (n) (symbol n '-TYPE)) arg-names))) `(LAMBDA (MODULE-ENTRY) (LET ,(map (lambda (type-name index) diff --git a/src/x11-screen/x11-command.scm b/src/x11-screen/x11-command.scm index 46e53b862..e4a970270 100644 --- a/src/x11-screen/x11-command.scm +++ b/src/x11-screen/x11-command.scm @@ -268,8 +268,8 @@ When called interactively, completion is available on the input." (sc-macro-transformer (lambda (form environment) (let ((name (cadr form))) - `(DEFINE ,(symbol-append 'EDWIN-COMMAND$X- name) - ,(close-syntax (symbol-append 'EDWIN-COMMAND$ name) + `(DEFINE ,(symbol 'EDWIN-COMMAND$X- name) + ,(close-syntax (symbol 'EDWIN-COMMAND$ name) environment)))))) (define-old-mouse-command set-foreground-color) diff --git a/src/xdoc/xdoc.scm b/src/xdoc/xdoc.scm index 12111e98c..8d5aec733 100644 --- a/src/xdoc/xdoc.scm +++ b/src/xdoc/xdoc.scm @@ -1474,12 +1474,12 @@ USA. (let ((local (cadr form)) (content-type (caddr form)) (elt-type (cadddr form))) - (let ((qname (symbol-append 'xd: local))) + (let ((qname (symbol 'xd: local))) `(BEGIN (DEFINE ,qname (STANDARD-XML-ELEMENT-CONSTRUCTOR ',qname XDOC-URI ,(eq? content-type 'empty))) - (DEFINE ,(symbol-append qname '?) + (DEFINE ,(symbol qname '?) (LET ((NAME (MAKE-XML-NAME ',qname XDOC-URI))) (LAMBDA (OBJECT) (AND (XML-ELEMENT? OBJECT) diff --git a/src/xml/xhtml.scm b/src/xml/xhtml.scm index 96e01e42b..bdd4c498b 100644 --- a/src/xml/xhtml.scm +++ b/src/xml/xhtml.scm @@ -139,9 +139,9 @@ USA. (context (caddr form)) (empty? (pair? (cdddr form)))) `(BEGIN - (DEFINE ,(symbol-append 'HTML: name) + (DEFINE ,(symbol 'HTML: name) (STANDARD-XML-ELEMENT-CONSTRUCTOR ',name HTML-URI ,empty?)) - (DEFINE ,(symbol-append 'HTML: name '?) + (DEFINE ,(symbol 'HTML: name '?) (STANDARD-XML-ELEMENT-PREDICATE ',name HTML-URI)) (DEFINE-HTML-ELEMENT-CONTEXT ',name ',context))) (ill-formed-syntax form))))) diff --git a/src/xml/xml-struct.scm b/src/xml/xml-struct.scm index 502d7636c..9f9600049 100644 --- a/src/xml/xml-struct.scm +++ b/src/xml/xml-struct.scm @@ -38,13 +38,13 @@ USA. (or (syntax-match? '(IDENTIFIER EXPRESSION) slot) (syntax-match? '(IDENTIFIER 'CANONICALIZE EXPRESSION) slot))))) - (let ((root (symbol-append 'XML- (cadr form))) + (let ((root (symbol 'XML- (cadr form))) (slots (cddr form))) - (let ((rtd (symbol-append '< root '>)) - (%constructor (symbol-append '%MAKE- root)) - (constructor (symbol-append 'MAKE- root)) - (predicate (symbol-append root '?)) - (error:not (symbol-append 'ERROR:NOT- root)) + (let ((rtd (symbol '< root '>)) + (%constructor (symbol '%MAKE- root)) + (constructor (symbol 'MAKE- root)) + (predicate (symbol root '?)) + (error:not (symbol 'ERROR:NOT- root)) (slot-vars (map (lambda (slot) (close-syntax (car slot) environment)) @@ -66,7 +66,7 @@ USA. (MAKE-RECORD-TYPE ',root '(,@(map car slots)))) (DEFINE ,predicate (RECORD-PREDICATE ,rtd)) - (DEFINE (,(symbol-append 'GUARANTEE- root) OBJECT CALLER) + (DEFINE (,(symbol 'GUARANTEE- root) OBJECT CALLER) (IF (NOT ,predicate) (,error:not OBJECT CALLER))) (DEFINE (,error:not OBJECT CALLER) @@ -86,8 +86,8 @@ USA. slots slot-vars))) ,@(map (lambda (slot var) - (let* ((accessor (symbol-append root '- (car slot))) - (modifier (symbol-append 'SET- accessor '!))) + (let* ((accessor (symbol root '- (car slot))) + (modifier (symbol 'SET- accessor '!))) `(BEGIN (DEFINE ,accessor (RECORD-ACCESSOR ,rtd ',(car slot))) @@ -447,9 +447,9 @@ USA. (if (syntax-match? '(IDENTIFIER EXPRESSION) (cdr form)) (let ((name (cadr form)) (accessor (caddr form))) - (let ((root (symbol-append 'XML- name))) + (let ((root (symbol 'XML- name))) `(SET-RECORD-TYPE-UNPARSER-METHOD! - ,(close-syntax (symbol-append '< root '>) environment) + ,(close-syntax (symbol '< root '>) environment) (SIMPLE-UNPARSER-METHOD ',root (LAMBDA (,name) (LIST (,(close-syntax accessor environment) ,name))))))) @@ -486,7 +486,7 @@ USA. (let ((value (find-xml-attr (if (null-xml-name-prefix? prefix) 'xmlns - (symbol-append 'xmlns: prefix)) + (symbol 'xmlns: prefix)) elt))) (and value (begin diff --git a/tests/runtime/test-entity.scm b/tests/runtime/test-entity.scm index 79a66b77d..2ff1914bf 100644 --- a/tests/runtime/test-entity.scm +++ b/tests/runtime/test-entity.scm @@ -38,14 +38,14 @@ USA. ((lambda (f) (for-each (lambda (descriptor) (apply f descriptor)) descriptors)) (lambda (name constructor predicate get-procedure get-extra) - (define-test (symbol-append name '?) + (define-test (symbol name '?) (lambda () (assert-true (predicate (constructor some-procedure some-extra))))) - (define-test (symbol-append name '- 'PROCEDURE) + (define-test (symbol name '- 'PROCEDURE) (lambda () (assert-eq some-procedure (get-procedure (constructor some-procedure some-extra))))) - (define-test (symbol-append name '- 'EXTRA) + (define-test (symbol name '- 'EXTRA) (lambda () (assert-eq some-extra @@ -61,28 +61,28 @@ USA. (lambda (name constructor predicate get-procedure get-extra name* constructor* predicate* get-procedure* get-extra*) constructor predicate* get-procedure* get-extra* - (define-test (symbol-append name '? '/ name*) + (define-test (symbol name '? '/ name*) (lambda () (assert-false (predicate (constructor* some-procedure some-extra))))) - (define-test (symbol-append name '? '/ 'JUNK) + (define-test (symbol name '? '/ 'JUNK) (lambda () (assert-false (predicate some-extra)))) - (define-test (symbol-append name '- 'PROCEDURE '/ name*) + (define-test (symbol name '- 'PROCEDURE '/ name*) (lambda () (let ((object* (constructor* some-procedure some-extra))) (assert-error (lambda () (get-procedure object*)) (list condition-type:wrong-type-argument))))) - (define-test (symbol-append name '- 'PROCEDURE '/ 'JUNK) + (define-test (symbol name '- 'PROCEDURE '/ 'JUNK) (lambda () (assert-error (lambda () (get-procedure some-extra)) (list condition-type:wrong-type-argument)))) - (define-test (symbol-append name '- 'EXTRA '/ name*) + (define-test (symbol name '- 'EXTRA '/ name*) (lambda () (let ((object* (constructor* some-procedure some-extra))) (assert-error (lambda () (get-extra object*)) (list condition-type:wrong-type-argument))))) - (define-test (symbol-append name '- 'EXTRA '/ 'JUNK) + (define-test (symbol name '- 'EXTRA '/ 'JUNK) (lambda () (assert-error (lambda () (get-extra some-extra)) (list condition-type:wrong-type-argument))))))) diff --git a/tests/runtime/test-floenv.scm b/tests/runtime/test-floenv.scm index 42e59caea..c063cf3d6 100644 --- a/tests/runtime/test-floenv.scm +++ b/tests/runtime/test-floenv.scm @@ -54,7 +54,7 @@ USA. (for-each-rounding-mode (lambda (mode) - (define-test (symbol-append 'FLO:SET-ROUNDING-MODE ': mode) + (define-test (symbol 'FLO:SET-ROUNDING-MODE ': mode) (lambda () (let ((mode* (flo:rounding-mode))) (flo:preserving-environment @@ -65,7 +65,7 @@ USA. (for-each-rounding-mode (lambda (mode) - (define-test (symbol-append 'FLO:WITH-ROUNDING-MODE ': mode) + (define-test (symbol 'FLO:WITH-ROUNDING-MODE ': mode) (lambda () (let ((mode* (flo:rounding-mode))) (flo:with-rounding-mode mode @@ -77,7 +77,7 @@ USA. (lambda (mode) (define inputs '(-2.0 -1.5 -1.0 -0.5 -0.0 0.0 0.5 1.0 1.5 2.0)) (define (define-rounding-test name operator outputs) - (define-test (symbol-append 'ROUNDING-MODE-INDEPENDENT ': mode '/ name) + (define-test (symbol 'ROUNDING-MODE-INDEPENDENT ': mode '/ name) (lambda () (do ((inputs inputs (cdr inputs)) (outputs outputs (cdr outputs)) @@ -229,10 +229,10 @@ USA. (for-each-exception (lambda (name exception condition-type trappable? elicitors) condition-type trappable? elicitors ;ignore - (define-test (symbol-append 'FLO:EXCEPTIONS->NAMES ': name) + (define-test (symbol 'FLO:EXCEPTIONS->NAMES ': name) (lambda () (assert-equal (flo:exceptions->names (exception)) (list name)))) - (define-test (symbol-append 'FLO:NAMES->EXCEPTIONS ': name) + (define-test (symbol 'FLO:NAMES->EXCEPTIONS ': name) (lambda () (assert-equal (flo:names->exceptions (list name)) (exception)))))) @@ -271,7 +271,7 @@ USA. (flo:trapped-exceptions))) (define (define-set-trapped-exceptions-test name to-trap) - (define-test (symbol-append 'FLO:SET-TRAPPED-EXCEPTIONS! ': name) + (define-test (symbol 'FLO:SET-TRAPPED-EXCEPTIONS! ': name) (lambda () (let ((exceptions (to-trap)) (trapped (flo:trapped-exceptions))) @@ -281,7 +281,7 @@ USA. (assert-eqv (flo:trapped-exceptions) exceptions))))))) (define (define-with-trapped-exceptions-test name to-trap) - (define-test (symbol-append 'FLO:WITH-TRAPPED-EXCEPTIONS ': name) + (define-test (symbol 'FLO:WITH-TRAPPED-EXCEPTIONS ': name) (lambda () (let ((exceptions (to-trap))) (flo:with-trapped-exceptions exceptions @@ -297,7 +297,7 @@ USA. (for-each-trappable-exception (lambda (name exception condition-type elicitors) condition-type elicitors ;ignore - (define-test (symbol-append 'FLO:WITH-TRAPPED-EXCEPTIONS ': name) + (define-test (symbol 'FLO:WITH-TRAPPED-EXCEPTIONS ': name) (lambda () (flo:with-trapped-exceptions (exception) (lambda () @@ -306,7 +306,7 @@ USA. (for-each-trappable-exception (lambda (name exception condition-type elicitors) condition-type elicitors ;ignore - (define-test (symbol-append 'FLO:TRAP-EXCEPTIONS! ': name) + (define-test (symbol 'FLO:TRAP-EXCEPTIONS! ': name) (lambda () (flo:with-trapped-exceptions 0 (lambda () @@ -316,7 +316,7 @@ USA. (for-each-trappable-exception (lambda (name exception condition-type elicitors) condition-type elicitors ;ignore - (define-test (symbol-append 'FLO:UNTRAP-EXCEPTIONS! ': name) + (define-test (symbol 'FLO:UNTRAP-EXCEPTIONS! ': name) (lambda () (flo:with-trapped-exceptions (flo:trappable-exceptions) (lambda () @@ -328,7 +328,7 @@ USA. (for-each-trappable-exception (lambda (name exception condition-type elicitors) condition-type elicitors ;ignore - (define-test (symbol-append 'FLO:SET-TRAPPED-EXCEPTIONS! ': name ': 'ENABLE) + (define-test (symbol 'FLO:SET-TRAPPED-EXCEPTIONS! ': name ': 'ENABLE) (lambda () (flo:with-trapped-exceptions 0 (lambda () @@ -338,7 +338,7 @@ USA. (for-each-trappable-exception (lambda (name exception condition-type elicitors) condition-type elicitors ;ignore - (define-test (symbol-append 'FLO:SET-TRAPPED-EXCEPTIONS! ': name ': 'DISABLE) + (define-test (symbol 'FLO:SET-TRAPPED-EXCEPTIONS! ': name ': 'DISABLE) (lambda () (let ((exceptions (fix:andc (flo:trappable-exceptions) (exception)))) (flo:with-trapped-exceptions (flo:trappable-exceptions) @@ -349,7 +349,7 @@ USA. (for-each-trappable-exception-elicitor (lambda (name exception condition-type elicitor-name elicitor) - (define-test (symbol-append 'ELICIT ': name ': elicitor-name) + (define-test (symbol 'ELICIT ': name ': elicitor-name) (lambda () (assert-error (lambda () (flo:with-trapped-exceptions (exception) elicitor)) @@ -358,7 +358,7 @@ USA. (for-each-trappable-exception-elicitor (lambda (name exception condition-type elicitor-name elicitor) exception ;ignore - (define-test (symbol-append 'ELICIT-DEFERRED ': name ': elicitor-name) + (define-test (symbol 'ELICIT-DEFERRED ': name ': elicitor-name) (lambda () (assert-error (lambda () @@ -375,14 +375,14 @@ USA. (for-each-exception-elicitor (lambda (name exception condition-type trappable? elicitor-name elicitor) exception condition-type trappable? ;ignore - (define-test (symbol-append 'ELICIT-IGNORED ': name ': elicitor-name) + (define-test (symbol 'ELICIT-IGNORED ': name ': elicitor-name) (lambda () (flo:ignoring-exception-traps elicitor))))) (for-each-exception-elicitor (lambda (name exception condition-type trappable? elicitor-name elicitor) condition-type trappable? ;ignore - (define-test (symbol-append 'ELICIT-AND-TEST ': name ': elicitor-name) + (define-test (symbol 'ELICIT-AND-TEST ': name ': elicitor-name) (lambda () (assert-eqv (flo:ignoring-exception-traps (lambda () @@ -393,7 +393,7 @@ USA. (for-each-exception-elicitor (lambda (name exception condition-type trappable? elicitor-name elicitor) condition-type trappable? ;ignore - (define-test (symbol-append 'ELICIT-CLEAR-TEST ': name ': elicitor-name) + (define-test (symbol 'ELICIT-CLEAR-TEST ': name ': elicitor-name) (lambda () (assert-eqv (flo:ignoring-exception-traps (lambda () @@ -427,7 +427,7 @@ USA. (flo:with-default-environment (lambda () 0)))) (define (define-default-environment-test name procedure) - (define-test (symbol-append 'FLO:DEFAULT-ENVIRONMENT ': name) + (define-test (symbol 'FLO:DEFAULT-ENVIRONMENT ': name) (lambda () (flo:preserving-environment (lambda () diff --git a/tests/runtime/test-hash-table.scm b/tests/runtime/test-hash-table.scm index 13ee59192..e6cb17ce8 100644 --- a/tests/runtime/test-hash-table.scm +++ b/tests/runtime/test-hash-table.scm @@ -209,10 +209,10 @@ USA. (for-each (lambda (hash-parameters) (for-each (lambda (entry-type) (define-test - (symbol-append 'CORRECTNESS-VS-RB: - (car entry-type) - '- - (car hash-parameters)) + (symbol 'CORRECTNESS-VS-RB: + (car entry-type) + '- + (car hash-parameters)) (lambda () (check (make-hash-table-implementation -- 2.25.1