Returns the @dfn{qname} of @var{xml-name} as a string. Equivalent to
@example
-(symbol-name (xml-name->symbol @var{xml-name}))
+(symbol->string (xml-name->symbol @var{xml-name}))
@end example
@end deffn
label-bindings)
(let ((map-label/fail
(lambda (label)
- (let ((key (symbol-name label)))
+ (let ((key (symbol->string label)))
(let ((datum (hash-table/get labels key no-datum)))
(if (eq? datum no-datum)
(error "Missing label:" key))
datum))))
(map-label/false
(lambda (label)
- (hash-table/get labels (symbol-name label) #f))))
+ (hash-table/get labels (symbol->string label) #f))))
(for-each (lambda (label)
(set-dbg-label/external?! (map-label/fail label) true))
external-labels)
(let ((offsets (make-rb-tree = <)))
(for-each (lambda (binding)
(let ((offset (cdr binding))
- (name (symbol-name (car binding))))
+ (name (symbol->string (car binding))))
(let ((datum (rb-tree/lookup offsets offset #f)))
(if datum
(set-cdr! datum (cons name (cdr datum)))
(define (c:line-item item)
(cond ((string? item) item)
((char? item) (string item))
- ((symbol? item) (symbol-name item))
+ ((symbol? item) (symbol->string item))
((number? item)
;; XXX Kludgey test for negative zero, to support building
;; from versions when NUMBER->STRING failed to do that itself.
(let ((types
(let ((types '(char short int long float double)))
`(,@(map (lambda (t)
- (cons t (symbol-name t)))
+ (cons t (symbol->string t)))
types)
,@(map (lambda (t)
(cons (symbol 'u t)
- (string-append "unsigned " (symbol-name t))))
+ (string-append "unsigned " (symbol->string t))))
types)
(sobj . "SCHEME_OBJECT")))))
`(,@types
(define (c:var item)
(cond ((string? item) item)
- ((symbol? item) (symbol-name item))
+ ((symbol? item) (symbol->string item))
(else (error:wrong-type-argument item "C variable" 'C:VAR))))
(define (c:array-decl type name dim items)
(if (uninterned-symbol? obj)
stackify-opcode/push-uninterned-symbol
stackify-opcode/push-symbol)
- (symbol-name obj)
+ (symbol->string obj)
prog))
((bit-string? obj)
(build/string stackify-opcode/push-bit-string
(build/push-nat (bit-string-length obj) prog)))
((scode/primitive-procedure? obj)
(let ((arity (primitive-procedure-arity obj))
- (name (symbol-name (primitive-procedure-name obj))))
+ (name (symbol->string (primitive-procedure-name obj))))
(cond ((fix:< arity 0)
(build/string stackify-opcode/push-primitive-lexpr
name
(for-each
write-string
(list "\t"
- (stackify/C-quotify (symbol-name (car binding)))
+ (stackify/C-quotify (symbol->string (car binding)))
" = 0"
(if (zero? value)
""
coding-types))))
(define (defn-name-length defn)
- (string-length (symbol-name (defn-name defn))))
+ (string-length (symbol->string (defn-name defn))))
(define (wrap-scheme-output title pathname generator)
(call-with-output-file pathname
(newline port))
(define (name->c-string name upcase?)
- (name-string->c-string (symbol-name name) upcase?))
+ (name-string->c-string (symbol->string name) upcase?))
(define (name-string->c-string name upcase?)
(call-with-output-string
(write-c-name-string name upcase? port))))
(define (write-c-name name upcase? port)
- (write-c-name-string (symbol-name name) upcase? port))
+ (write-c-name-string (symbol->string name) upcase? port))
(define (write-c-name-string name upcase? port)
(let ((e (string-length name))
(declare (integrate-operator name->string))
(define (name->string name)
(if (interned-symbol? name)
- (symbol-name name)
+ (symbol->string name)
(write-to-string name)))
(define-integrable (name<? x y)
(define (find-global-definitions name model-pathname os-type)
(let* ((filename (->pathname
- (cond ((symbol? name) (symbol-name name))
+ (cond ((symbol? name) (symbol->string name))
((string? name) name)
(else (error "Not a globals name:" name)))))
(pkd (package-set-pathname filename os-type)))
(let ((abbrev
(string-downcase
(cond ((string? abbrev) abbrev)
- ((symbol? abbrev) (symbol-name abbrev))
+ ((symbol? abbrev) (symbol->string abbrev))
(else
(error:wrong-type-argument abbrev "string"
'ABBREV-EXPANSION))))))
(lambda (name)
(let ((table (get-named-abbrev-table name)))
(insert-string "(" mark)
- (insert-string (symbol-name name) mark)
+ (insert-string (symbol->string name) mark)
(insert-string ")\n\n" mark)
(hash-table/for-each table
(lambda (abbrev entry)
(list
(prompt-for-alist-value "Load library"
(map (lambda (library)
- (cons (symbol-name (car library))
+ (cons (symbol->string (car library))
(car library)))
known-libraries))
(command-argument)))
(define (special-key/name special-key)
(string-append (bucky-bits->prefix (special-key/bucky-bits special-key))
- (symbol-name (special-key/symbol special-key))))
+ (symbol->string (special-key/symbol special-key))))
(define (make-special-key name bits)
(hook/make-special-key name bits))
(let ((desc (command-%description command)))
(if (description? desc)
desc
- (let ((new (->doc-string (symbol-name (command-name command)) desc)))
+ (let ((new (->doc-string (symbol->string (command-name command)) desc)))
(if new
(set-command-%description! command new))
new))))
(define (command-name-string command)
- (editor-name/internal->external (symbol-name (command-name command))))
+ (editor-name/internal->external (symbol->string (command-name command))))
(define (editor-name/internal->external string)
string)
string)
(define (make-command name description specification procedure)
- (let* ((sname (symbol-name name))
+ (let* ((sname (symbol->string name))
(command
(or (string-table-get editor-commands sname)
(let ((command (%make-command)))
(make-string-table 500))
(define (name->command name #!optional if-undefined)
- (or (string-table-get editor-commands (symbol-name name))
+ (or (string-table-get editor-commands (symbol->string name))
(case (if (default-object? if-undefined) 'INTERN if-undefined)
((#F) #f)
((ERROR) (error "Undefined command:" name))
(let ((desc (variable-%description variable)))
(if (description? desc)
desc
- (let ((new (->doc-string (symbol-name (variable-name variable)) desc)))
+ (let ((new
+ (->doc-string (symbol->string (variable-name variable)) desc)))
(if new
(set-variable-%description! variable new))
new))))
(define-integrable variable-default-value variable-%default-value)
(define (variable-name-string variable)
- (editor-name/internal->external (symbol-name (variable-name variable))))
+ (editor-name/internal->external (symbol->string (variable-name variable))))
(define (make-variable name description value buffer-local?
#!optional test normalization)
- (let* ((sname (symbol-name name))
+ (let* ((sname (symbol->string name))
(variable
(or (string-table-get editor-variables sname)
(let ((variable (%make-variable)))
(make-string-table 50))
(define (name->variable name #!optional if-undefined)
- (or (string-table-get editor-variables (symbol-name name))
+ (or (string-table-get editor-variables (symbol->string name))
(case (if (default-object? if-undefined) 'INTERN if-undefined)
((#F) #f)
((ERROR) (error "Undefined variable:" name))
(define (mode-name? object)
(and (symbol? object)
- (string-table-get editor-modes (symbol-name object))))
+ (string-table-get editor-modes (symbol->string object))))
(define (list-of-comtabs? object)
(and (not (null? object))
(not (button-down? object))))
(define (button-name button)
- (symbol-name (button-symbol button)))
+ (symbol->string (button-symbol button)))
(set-record-type-unparser-method! <button>
(simple-unparser-method (record-type-name <button>)
(define (mode-apropos regexp)
(for-each (lambda (mode)
- (write-string (symbol-name (mode-name mode)))
+ (write-string (symbol->string (mode-name mode)))
(newline)
(print-short-description "Mode" (mode-description mode)))
(string-table-apropos editor-modes regexp)))
(if (pair? bindings)
(xkey->name (car bindings))
(string-append "M-x " (command-name-string command))))
- (string-append "M-x " (symbol-name argument))))
+ (string-append "M-x " (symbol->string argument))))
(find-escape next comtabs)))
(define (show-bindings argument next comtabs)
(if (not (or (not super-mode)
(and major? (major-mode? super-mode))))
(error:wrong-type-argument super-mode "major mode" 'MAKE-MODE))
- (let ((sname (symbol-name name))
+ (let ((sname (symbol->string name))
(major? (if major? #t #f))
(super-comtabs (if super-mode (mode-comtabs super-mode) '())))
(let ((mode (string-table-get editor-modes sname))
(make-string-table))
(define (name->mode name #!optional if-undefined)
- (let ((sname (symbol-name name)))
+ (let ((sname (symbol->string name)))
(or (string-table-get editor-modes sname)
(case (if (default-object? if-undefined) 'INTERN if-undefined)
((#F) #f)
(let ((desc (mode-%description mode)))
(if (description? desc)
desc
- (let ((new (->doc-string (symbol-name (mode-name mode)) desc)))
+ (let ((new (->doc-string (symbol->string (mode-name mode)) desc)))
(if new
(set-mode-%description! mode new))
new))))
((#\s)
(let ((process (get-buffer-process buffer)))
(if process
- (symbol-name (process-status process))
+ (symbol->string (process-status process))
"no process")))
((#\p)
(let ((group (buffer-group buffer)))
(let ((process (car processes)))
(write-line (or (process-name process) "")
(let ((status (process-status process)))
- (let ((name (symbol-name status)))
+ (let ((name (symbol->string status)))
(if (or (eq? 'EXIT status)
(eq? 'SIGNAL status))
(let ((reason (process-exit-reason process)))
(number->string (msg-memo/number (msg-memo/last memo)))
(append-map!
(lambda (label) (list "," label))
- (append! (map symbol-name (msg-memo/attributes memo))
+ (append! (map symbol->string (msg-memo/attributes memo))
(parse-labels (msg-memo/start memo))))))))
\f
;;;; Message deletion
rmail-last-label
(alist->string-table
(map list
- (append! (map symbol-name attributes)
+ (append! (map symbol->string attributes)
(buffer-keywords (current-buffer)))))
'REQUIRE-MATCH? require-match?)))
(set! rmail-last-label label)
(update-mode-line! (mark-buffer start))))))))
(define (attribute->string attribute)
- (string-append " " (string-downcase (symbol-name attribute)) ","))
+ (string-append " " (string-downcase (symbol->string attribute)) ","))
(define (label->attribute label)
(let ((s (intern-soft label)))
(cond ((not (pair? completions))
(if-not-found))
((null? (cdr completions))
- (if-unique (symbol-name (car completions))))
+ (if-unique (symbol->string (car completions))))
(else
- (let ((completions (map symbol-name completions)))
+ (let ((completions (map symbol->string completions)))
(if-not-unique
(string-greatest-common-prefix completions)
(lambda () (sort completions string<=?))))))))
(let ((completions '()))
(for-each-interned-symbol
(lambda (symbol)
- (if (and (string-prefix? prefix (symbol-name symbol))
+ (if (and (string-prefix? prefix (symbol->string symbol))
(filter symbol))
(set! completions (cons symbol completions)))
unspecific))
(cond ((pair? argl)
(insert-char #\space point)
(insert-string (if (symbol? (car argl))
- (symbol-name (car argl))
+ (symbol->string (car argl))
(write-to-string (car argl)))
point)
(loop (cdr argl)))
((symbol? argl)
(insert-string " . " point)
- (insert-string (symbol-name argl) point)))))
+ (insert-string (symbol->string argl) point)))))
(parameterize*
(list (cons param:unparse-uninterned-symbols-by-name? #t))
(lambda ()
(subtype (mime-attachment-subtype attachment)))
(write-message-header-field
"Content-Type"
- (string-append (symbol-name type)
+ (string-append (symbol->string type)
"/"
- (symbol-name subtype)
+ (symbol->string subtype)
(mime-parameters->string
(mime-attachment-parameters attachment)))
port)
(decorated-string-append
"; " "" ""
(map (lambda (parameter)
- (string-append (symbol-name (car parameter))
+ (string-append (symbol->string (car parameter))
"=\""
(cadr parameter)
"\""))
parameters)))
(define (mime-disposition->string disposition)
- (string-append (symbol-name (car disposition))
+ (string-append (symbol->string (car disposition))
(mime-parameters->string (cdr disposition))))
(define (guarantee-mime-compliant-headers h-start h-end)
(let ((start (mark-right-inserting-copy mark))
(type (mime-attachment-type attachment))
(subtype (mime-attachment-subtype attachment)))
- (insert-string-pad-right (string-append (symbol-name type)
+ (insert-string-pad-right (string-append (symbol->string type)
"/"
- (symbol-name subtype))
+ (symbol->string subtype))
30 #\space mark)
(if (not (and (eq? type 'MESSAGE) (eq? subtype 'RFC822)))
(begin
(or (hash-table/get table name #f)
(let ((atom
(x-intern-atom display
- (string-upcase (symbol-name name))
+ (string-upcase (symbol->string name))
soft?)))
(if (not (= atom 0))
(hash-table/put! table name atom))
;; munge the correct alist in INCLUDES.
(if (not (and (pair? rest) (symbol? (car rest))
(list? (cdr rest))))
- (cerror form "malformed "(symbol-name (car form))" declaration"))
+ (cerror form "malformed " (symbol->string (car form)) " declaration"))
(let* ((name (car rest))
(params (cdr rest))
(others (if (eq? 'EXTERN (car form))
(alien-function/filename (cdr entry))))
(let ((new (cons name
(make-alien-function
- (symbol-name name)
+ (symbol->string name)
(c-includes/library includes)
(valid-ctype rettype includes)
(valid-params params includes)
(null? (cddr form))))
(cerror form "malformed parameter declaration"))
(if (string-find-next-char-in-set
- (symbol-name (car form)) char-set:not-c-symbol)
+ (symbol->string (car form)) char-set:not-c-symbol)
(cerror form "invalid parameter name"))
(let ((name (car form))
(ctype (valid-ctype (cadr form) includes)))
(callout-restores name tos-var ret-var ret-ctype includes))
(return
(callout-return tos-var ret-var ret-ctype includes))
- (name (symbol-name name)))
+ (name (symbol->string name)))
(write-string
(string-append "
SCM
(inits (callout-inits ret-ctype params includes))
(call (callout-call name ret-var ret-ctype params includes))
(saves (callout-saves ret-var ret-ctype includes)))
- (let ((name (symbol-name name)))
+ (let ((name (symbol->string name)))
(write-string
(string-append "
SCM
(define (matching-param? string params)
(find-matching-item params
- (lambda (param) (string=? string (symbol-name (car param))))))
+ (lambda (param) (string=? string (symbol->string (car param))))))
(define (new-variable root-name params)
;; Returns a name (string) for a variable that must be distinct from
(define (callout-restores name tos-var ret-var ret-ctype includes)
(let* ((ctype (definite-ctype ret-ctype includes))
- (tramp2 (string-append "&Scm_continue_" (symbol-name name)))
+ (tramp2 (string-append "&Scm_continue_" (symbol->string name)))
(ret-decl (decl-string ret-ctype)))
(string-append "
"tos-var" = callout_lunseal ("tramp2");"
(if (null? params) '()
(cons
(let* ((param (car params))
- (name (symbol-name (car param)))
+ (name (symbol->string (car param)))
(type (cadr param))
(decl (decl-string type)))
(string-append "
(name (car param))
(ctype (cadr param))
(funcast (callout-arg-converter name ctype includes))
- (name (symbol-name name))
+ (name (symbol->string name))
(num (number->string n)))
(string-append "
"name" = "funcast" ("num");"))
(define (callout-call name ret-var ret-ctype params includes)
;; Returns a multi-line string in C syntax for the Call section.
- (let ((name (symbol-name name))
+ (let ((name (symbol->string name))
(args (decorated-string-append
- "" ", " "" (map (lambda (param) (symbol-name (car param)))
+ "" ", " "" (map (lambda (param) (symbol->string (car param)))
params))))
(if (not (ctype/void? (definite-ctype ret-ctype includes)))
(string-append "
((eq? ctype 'ushort) "unsigned short")
((eq? ctype 'uint) "unsigned int")
((eq? ctype 'ulong) "unsigned long")
- ((symbol? ctype) (symbol-name ctype))
+ ((symbol? ctype) (symbol->string ctype))
((ctype/pointer? ctype)
(string-append (decl-string (ctype-pointer/target-type ctype))
" *"))
(string-append (decl-string (ctype-const/qualified-type ctype))
" const"))
((ctype/struct-name? ctype)
- (string-append "struct " (symbol-name (ctype-struct/name ctype))))
+ (string-append "struct " (symbol->string (ctype-struct/name ctype))))
((ctype/union-name? ctype)
- (string-append "union " (symbol-name (ctype-union/name ctype))))
+ (string-append "union " (symbol->string (ctype-union/name ctype))))
((ctype/enum-name? ctype)
- (string-append "enum " (symbol-name (ctype-enum/name ctype))))
+ (string-append "enum " (symbol->string (ctype-enum/name ctype))))
(else
(error "Could not generate a C type declaration:" ctype))))
\f
(let ((declares (callback-decls params))
(restores (callback-restores params tos-var))
(constructs (callback-conses params args-var includes))
- (name (symbol-name name)))
+ (name (symbol->string name)))
(write-string
(string-append "
static void
(saves (callback-saves params))
(return (callback-return ret-ctype includes))
(ret-decl (decl-string ret-ctype))
- (name (symbol-name name)))
+ (name (symbol->string name)))
(write-string
(string-append
"
;; the second (inner, kernel) part of a callback trampoline.
(apply string-append (map (lambda (param)
(let ((decl (decl-string (cadr param)))
- (name (symbol-name (car param))))
+ (name (symbol->string (car param))))
(string-append "
"decl" "name";")))
params)))
(define (callback-restores params tos-var)
;; Returns a multi-line string setting the params from the C data stack.
(apply string-append (map (lambda (param)
- (let ((name (symbol-name (car param)))
+ (let ((name (symbol->string (car param)))
(decl (decl-string (cadr param))))
(string-append "
CSTACK_LPOP ("decl", "name", "tos-var");")))
(ctype (cadr param)))
(if (eq? name '|ID|)
""
- (let ((name (symbol-name name)))
+ (let ((name (symbol->string name)))
(let ((construction
(callback-arg-cons name ctype includes)))
(string-append "
"" ", " "" ;prefix, infix, suffix
(map (lambda (param)
(string-append (decl-string (cadr param))
- " " (symbol-name (car param))))
+ " " (symbol->string (car param))))
params)))
(define (callback-saves params)
(apply string-append
(map (lambda (param)
- (let ((name (symbol-name (car param)))
+ (let ((name (symbol->string (car param)))
(ctype (cadr param)))
(string-append "
CSTACK_PUSH ("(decl-string ctype)", "name");")))
(map (lambda (entry)
(let* ((name (car entry))
(decl (decl-string name))
- (name (symbol-name name)))
+ (name (symbol->string name)))
(string-append "
fprintf (out, \" ((sizeof "name") . %ld)\\n\", (long) sizeof ("decl"));")))
peek-poke-primitives))
\{"
(apply string-append
(map (lambda (constant)
- (let ((name (symbol-name (car constant))))
+ (let ((name (symbol->string (car constant))))
(string-append "
fprintf (out, \" (|"name"| . %ld)\\n\", ((long)"name"));")))
(c-includes/enum-constants includes)))
;; Generate C code for a grovel_NAME function.
(let ((fname (cond ((ctype/struct-name? name)
(string-append "grovel_struct_"
- (symbol-name (ctype-struct/name name))))
+ (symbol->string (ctype-struct/name name))))
((ctype/union-name? name)
(string-append "grovel_union_"
- (symbol-name (ctype-union/name name))))
+ (symbol->string (ctype-union/name name))))
((symbol? name)
- (string-append "grovel_type_" (symbol-name name)))
+ (string-append "grovel_type_" (symbol->string name)))
(else (error "Unexpected name:" name))))
(ctype (definite-ctype name includes))
(decl (decl-string name))
ctype includes
(lambda (path brief-type)
(let ((path (decorated-string-append
- "" "." "" (map symbol-name path)))
+ "" "." "" (map symbol->string path)))
(key (cons* 'OFFSET name path)))
(_ "
fprintf (out, \" (")(write key)(_" %ld . ")(write brief-type)(_")\\n\", (long)((char*)&(S."path") - (char*)&S));"))))
(lambda ()
(let ((args (gdbf-args gdbf)))
(if (alien-null? args)
- (error (string-append (symbol-name operator) " failed: closed")))
+ (error (string-append (symbol->string operator) " failed: closed")))
(receiver args)))))
(define (gdbm-error gdbf msg)
(map (lambda (x)
(if (exact-nonnegative-integer? x)
(number->string x)
- (symbol-name x)))
+ (symbol->string x)))
section))
"]"))
\f
`(,@(imap-message-cache-specifier message)
,(encode-cache-namestring
(if (symbol? keyword)
- (symbol-name keyword)
+ (symbol->string keyword)
keyword)))))
(define (imap-message-cache-pathname message)
(flush-output imap-trace-port)))
(imap-transcript-write-string tag port)
(imap-transcript-write-char #\space port)
- (imap-transcript-write-string (symbol-name command) port)
+ (imap-transcript-write-string (symbol->string command) port)
(for-each (lambda (argument)
(if argument
(begin
(cond ((exact-nonnegative-integer? argument)
(imap-transcript-write argument port))
((symbol? argument)
- (imap-transcript-write-string (symbol-name argument) port))
+ (imap-transcript-write-string (symbol->string argument) port))
((and (pair? argument)
(eq? (car argument) 'QUOTE)
(pair? (cdr argument))
names)))
(define (aproposer text env search-parents? process-env process-symbol)
- (let ((text (if (symbol? text) (symbol-name text) text)))
+ (let ((text (if (symbol? text) (symbol->string text) text)))
(process-env env)
(for-each (lambda (symbol)
- (if (substring? text (symbol-name symbol))
+ (if (substring? text (symbol->string symbol))
(process-symbol symbol env)))
(sort (environment-bound-names env) symbol<?))
(if (and search-parents? (environment-has-parent? env))
(cond ((string? name)
(write-string name port))
((interned-symbol? name)
- (write-string (symbol-name name) port))
+ (write-string (symbol->string name) port))
(else
(write name port))))
(cond ((string? name)
(write-string (string-upcase name)))
((interned-symbol? name)
- (write-string (string-upcase (symbol-name name)) port))
+ (write-string (string-upcase (symbol->string name)) port))
(else
(write name port))))
(trim-initial-token token)
token)))
(cond ((not token*) (tokenize confusion-count tokens))
- ((string-suffix? "-*-" (symbol-name token*))
+ ((string-suffix? "-*-" (symbol->string token*))
(let ((token** (trim-final-token token*)))
(if token**
(reverse (cons token** tokens))
;;; -*-*- coding: latin-1 -*-*-
(define (trim-initial-token sym)
- (if (string-prefix? "*-" (symbol-name sym))
- (do ((token-string (symbol-name sym) (string-tail token-string 2)))
+ (if (string-prefix? "*-" (symbol->string sym))
+ (do ((token-string (symbol->string sym) (string-tail token-string 2)))
((not (string-prefix? "*-" token-string))
(if (zero? (string-length token-string))
#f
;;; -*-outline-*-*-
(define (trim-final-token sym)
(do ((token-string
- (let ((s (symbol-name sym)))
+ (let ((s (symbol->string sym)))
(string-head s (- (string-length s) 3)))
(string-head token-string (- (string-length token-string) 2))))
((not (string-suffix? "-*" token-string))
((string? argument)
argument)
((symbol? argument)
- (symbol-name argument))
+ (symbol->string argument))
((exact-nonnegative-integer? argument)
(set! name-counter argument)
name-prefix)
(port/set-line-ending port 'crlf)
(let ((write-datum
(lambda (datum)
- (encode-segment (symbol-name (car datum)) port)
+ (encode-segment (symbol->string (car datum)) port)
(write-char #\= port)
(encode-segment (cdr datum) port))))
(if (pair? data)
(define (http-token? object)
(and (interned-symbol? object)
- (string-is-http-token? (symbol-name object))))
+ (string-is-http-token? (symbol->string object))))
(define-guarantee http-token "HTTP token")
(define (write-http-token token port)
- (write-string (symbol-name token) port))
+ (write-string (symbol->string token) port))
(define (http-token-string? object)
(and (string? object)
(*matcher
(seq segment
(* (seq #\- segment)))))
- (symbol-name object))))
+ (symbol->string object))))
(define language-range?
(alt-predicate *? language-tag?))
((and (eq? (mime-type/top-level type) 'APPLICATION)
(let ((sub (mime-type/subtype type)))
(or (eq? sub 'XML)
- (string-suffix-ci? "+xml" (symbol-name sub)))))
+ (string-suffix-ci? "+xml" (symbol->string sub)))))
(port/set-coding port (or coding 'UTF-8))
(port/set-line-ending port 'XML-1.0))
(coding
`(DEFINE-INTEGRABLE ,symbol
',((ucode-primitive string->symbol)
(string-append "#[(runtime compiler-info)"
- (string-downcase (symbol-name symbol))
+ (string-downcase (symbol->string symbol))
"]"))))))))
;; Various names used in `layout' to identify things that wouldn't
;; otherwise have names.
(and procedure
(let ((name (dbg-procedure/name procedure)))
(or (special-form-procedure-name? name)
- (symbol-name name))))))
+ (symbol->string name))))))
(define load-debugging-info-on-demand?
#f)
(define (special-form-procedure-name? name)
(let ((association (assq name special-form-procedure-names)))
(and association
- (symbol-name (cdr association)))))
+ (symbol->string (cdr association)))))
(define special-form-procedure-names)
(define (lookup-file-attribute file-attribute-alist attribute)
(assoc attribute file-attribute-alist
(lambda (left right)
- (string-ci=? (symbol-name left) (symbol-name right)))))
+ (string-ci=? (symbol->string left) (symbol->string right)))))
;;; Look for keyword-style: prefix or keyword-style: suffix
(define (process-keyword-attribute file-attribute-alist port)
(if (pair? keyword-entry)
(let ((value (cdr keyword-entry)))
(cond ((and (symbol? value)
- (or (string-ci=? (symbol-name value) "none")
- (string-ci=? (symbol-name value) "false")))
+ (or (string-ci=? (symbol->string value) "none")
+ (string-ci=? (symbol->string value) "false")))
(set-port-property! port 'parser-keyword-style #f))
((and (symbol? value)
- (string-ci=? (symbol-name value) "prefix"))
+ (string-ci=? (symbol->string value) "prefix"))
(set-port-property! port 'parser-keyword-style 'prefix))
((and (symbol? value)
- (string-ci=? (symbol-name value) "suffix"))
+ (string-ci=? (symbol->string value) "suffix"))
(set-port-property! port 'parser-keyword-style 'suffix))
(else
(warn "Unrecognized value for keyword-style" value)))))))
(if (pair? mode-entry)
(let ((value (cdr mode-entry)))
(if (or (not (symbol? value))
- (not (string-ci=? (symbol-name value) "scheme")))
+ (not (string-ci=? (symbol->string value) "scheme")))
(warn "Unexpected file mode:" (if (symbol? value)
- (symbol-name value)
+ (symbol->string value)
value)))))))
;; If you want to turn on studly case, then the attribute must be
(let ((value (cdr studly-case-entry)))
(cond ((or (eq? value #t)
(and (symbol? value)
- (string-ci=? (symbol-name value) "true")))
+ (string-ci=? (symbol->string value) "true")))
;; STricTly cHeck thE case.
- (cond ((not (string=? (symbol-name (car studly-case-entry))
+ (cond ((not (string=? (symbol->string (car studly-case-entry))
"sTuDly-case"))
(warn "Attribute name mismatch. Expected sTuDly-case.")
#f)
((and (symbol? value)
- (not (string=? (symbol-name value) "True")))
+ (not (string=? (symbol->string value) "True")))
(warn "Attribute value mismatch. Expected True.")
#f)
(else
(set-port-property! port 'parser-fold-case? #f))))
((or (not value)
(and (symbol? value)
- (string-ci=? (symbol-name value) "false")))
+ (string-ci=? (symbol->string value) "false")))
(set-port-property! port 'parser-fold-case? #t))
(else
(warn "Unrecognized value for sTuDly-case" value)))))))
(define (->type-name object)
(cond ((string? object) object)
- ((symbol? object) (symbol-name object))
+ ((symbol? object) (symbol->string object))
(else (error:wrong-type-argument object "type name" #f))))
(define (list-of-unique-symbols? object)
(define (header-name? object)
(and (interned-symbol? object)
(not (eq? object '||))
- (string-in-char-set? (symbol-name object) char-set:rfc2822-name)))
+ (string-in-char-set? (symbol->string object) char-set:rfc2822-name)))
(define-guarantee header-name "RFC 2822 header-field name")
(newline port))
(define (write-name name port)
- (let* ((name (symbol-name name))
+ (let* ((name (symbol->string name))
(end (string-length name)))
(if (char-alphabetic? (string-ref name 0))
(letrec
(export-deprecated () ;ignored on 9.2 hosts
(substring->symbol string->symbol)
(symbol-append symbol)
+ (symbol-name symbol->string)
error:not-interned-symbol
error:not-symbol
error:not-uninterned-symbol
guarantee-interned-symbol
guarantee-symbol
- guarantee-uninterned-symbol
- symbol-name)
+ guarantee-uninterned-symbol)
(export () ;temporary duplicate for 9.2 hosts
(substring->symbol string->symbol)
(symbol-append symbol)
+ (symbol-name symbol->string)
error:not-interned-symbol
error:not-symbol
error:not-uninterned-symbol
guarantee-interned-symbol
guarantee-symbol
- guarantee-uninterned-symbol
- symbol-name)
+ guarantee-uninterned-symbol)
(export ()
intern
intern-soft
interned-symbol?
string->symbol
string->uninterned-symbol
- string-head->symbol
- string-tail->symbol
symbol
symbol->string
symbol-hash
(define (write-mime-type mime-type port)
(guarantee-mime-type mime-type 'WRITE-MIME-TYPE)
- (write-string (symbol-name (mime-type/top-level mime-type)) port)
+ (write-string (symbol->string (mime-type/top-level mime-type)) port)
(write-string "/" port)
- (write-string (symbol-name (mime-type/subtype mime-type)) 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)
(define (mime-token? object)
(and (interned-symbol? object)
- (string-is-mime-token? (symbol-name object))))
+ (string-is-mime-token? (symbol->string object))))
(define (mime-token-string? object)
(and (string? object)
(completions '()))
(for-each-interned-symbol
(lambda (symbol)
- (if (and (string-prefix? prefix (symbol-name symbol))
+ (if (and (string-prefix? prefix (symbol->string symbol))
(environment-bound? environment symbol))
- (set! completions (cons (symbol-name symbol) completions)))
+ (set! completions (cons (symbol->string symbol) completions)))
unspecific))
completions))
((ucode-primitive string->symbol) (string->utf8 string start end)))
(define (symbol->string symbol)
- (guarantee symbol? symbol 'symbol->string)
+ (if (not (symbol? symbol))
+ (error:not-a symbol? symbol 'symbol->string))
(let ((s (system-pair-car symbol)))
(cond ((maybe-ascii s))
((bytevector? s) (utf8->string s))
((legacy-string? s) (utf8->string (%legacy-string->bytevector s)))
(else (error "Illegal symbol name:" s)))))
-(define (string-head->symbol string end)
- (string->symbol (string-slice string 0 end)))
-
-(define (string-tail->symbol string start)
- (string->symbol (string-slice string start)))
-
(define (symbol . objects)
(string->symbol (%string* objects 'symbol)))
((ucode-primitive find-symbol) (foldcase->utf8 string)))
(define (symbol-name symbol)
- (if (not (symbol? symbol))
- (error:not-a symbol? symbol 'symbol-name))
(let ((bytes (system-pair-car symbol)))
(or (maybe-ascii bytes)
(utf8->string bytes))))
(define (output/letrec names values body)
(let ((temps (map (lambda (name)
(string->uninterned-symbol
- (string-append (symbol-name (identifier->symbol name))
+ (string-append (symbol->string (identifier->symbol name))
"-value"))) names)))
(output/let
names (map (lambda (name) name (output/unassigned)) names)
(or (hash-table/get mapping-table key #f)
(let ((mapped-identifier
(string->uninterned-symbol
- (symbol-name (identifier->symbol identifier)))))
+ (symbol->string (identifier->symbol identifier)))))
(hash-table/put! mapping-table key mapped-identifier)
(hash-table/put! (rename-database/unmapping-table renames)
mapped-identifier
;; an uninterned symbol that guarantees uniqueness.
(string->uninterned-symbol
(string-append "."
- (symbol-name (identifier->symbol identifier))
+ (symbol->string (identifier->symbol identifier))
"."
(number->string (force (make-rename-id)))))))
(and code
((ucode-primitive system-call-error-message 1) code)))
(if (symbol? error-type)
- (string-replace (symbol-name error-type) #\- #\space)
+ (string-replace (symbol->string error-type) #\- #\space)
(string-append "error " (write-to-string error-type)))))
;++ Whattakludge!
(define (unparse-symbol symbol context)
(if (keyword? symbol)
(unparse-keyword-name (keyword->string symbol) context)
- (unparse-symbol-name (symbol-name symbol) context)))
+ (unparse-symbol-name (symbol->string symbol) context)))
(define (unparse-keyword-name s context)
(case (get-param:parser-keyword-style (context-environment context))
(actions (cdr clause)))
`(,(cond ((eq? key 'EOF)
`(EOF-OBJECT? CHAR))
- ((fix:= 1 (string-length (symbol-name key)))
- `(CHAR=? CHAR ,(string-ref (symbol-name key) 0)))
+ ((fix:= 1 (string-length (symbol->string key)))
+ `(CHAR=? CHAR ,(string-ref (symbol->string key) 0)))
(else
`(CHAR-SET-MEMBER? ,(symbol 'CHAR-SET:URI- key) CHAR)))
,@(map (lambda (action)
(define (action:push? action) (syntax-match? '('PUSH ? SYMBOL) action))
(define (expand:push action)
`(WRITE-CHAR ,(if (pair? (cdr action))
- (string-ref (symbol-name (cadr action)) 0)
+ (string-ref (symbol->string (cadr action)) 0)
'CHAR)
BUFFER))
(define (hackify-variable variable)
(set-variable/name!
variable
- (string->uninterned-symbol (symbol-name (variable/name variable)))))
+ (string->uninterned-symbol (symbol->string (variable/name variable)))))
(define (sequence-with-actions sequence actions)
(sequence/make (sequence/scode sequence) actions))
(list (car p) (cdr p)))
(http-message-headers message)))))
(for-each (lambda (header)
- (write-string (symbol-name (car header)) port)
+ (write-string (symbol->string (car header)) port)
(newline port)
(write-string (cdr header) port)
(newline port))
(if (default-object? value)
""
(string-append "; "
- (symbol-name name)
+ (symbol->string name)
"="
(if map-value
(map-value value)
(attr
(lambda (name map-value)
(%attr name name map-value))))
- (string-append (symbol-name name) "=" value
+ (string-append (symbol->string name) "=" value
(%attr 'max-age 'expires max-age->expires)
(attr 'domain #f)
(attr 'path #f)
(write-string (status-message code) port)))))
(define (set-content-type-header message type)
- (set-header message 'CONTENT-TYPE (symbol-name type)))
+ (set-header message 'CONTENT-TYPE (symbol->string type)))
\f
(define (status-message code)
(let loop ((low 0) (high (vector-length known-status-codes)))
(string->uninterned-symbol
(string-append
internal-identifier-prefix
- (symbol-name prefix)
+ (symbol->string prefix)
(number->string
(let ((entry (assq prefix *id-counters*)))
(if entry
internal-identifier-suffix)))
(define (internal-identifier? identifier)
- (let ((string (symbol-name identifier)))
+ (let ((string (symbol->string identifier)))
(and (string-prefix? internal-identifier-prefix string)
(string-suffix? internal-identifier-suffix string))))
(map (lambda (sym)
(intern
(string-append "[converted "
- (symbol-name sym)
+ (symbol->string sym)
"]")))
arg-names)))
`((ACCESS PARAMETERIZE-WITH-MODULE-ENTRY
(string-append "'"
(escape-pgsql-string
(if (symbol? object)
- (symbol-name object)
+ (symbol->string object)
object))
"'"))
"NULL"))
(let ((bindings (http-request-post-parameter-bindings)))
(let per-elt ((elt elt) (containers (xdoc-element-containers elt)))
(let* ((id (xdoc-db-id elt))
- (suffix (string-append "-" (symbol-name id))))
+ (suffix (string-append "-" (symbol->string id))))
(cond ((find-matching-item bindings
(lambda (binding)
- (string-suffix? suffix (symbol-name (car binding)))))
+ (string-suffix? suffix (symbol->string (car binding)))))
=> (lambda (binding)
- (values (let ((name (symbol-name (car binding))))
+ (values (let ((name (symbol->string (car binding))))
(substring->symbol
name
0
source
(let ((expected (boolean-attribute 'expected elt #t)))
(if (or (string=? value "true") (string=? value "false"))
- (if (string=? value (symbol-name expected))
+ (if (string=? value (symbol->string expected))
"correct"
"incorrect")
"malformed"))))
symbol))
(define (xdoc-procedure-name? symbol)
- (re-string-match "[A-Za-z_][0-9A-Za-z_]*" (symbol-name symbol)))
+ (re-string-match "[A-Za-z_][0-9A-Za-z_]*" (symbol->string symbol)))
\f
;;;; Merging of attributes
((rdf-literal-language literal)
=> (lambda (lang)
(write-string "@" port)
- (write-string (symbol-name lang) port)))))
+ (write-string (symbol->string lang) port)))))
(define (write-rdf/nt-literal-text text port)
(let ((text (open-input-string text)))
(define (rdf-qname-prefix qname)
(guarantee-rdf-qname qname 'RDF-QNAME-PREFIX)
- (let ((s (symbol-name qname)))
+ (let ((s (symbol->string qname)))
(symbol (string-head s (fix:+ (string-find-next-char s #\:) 1)))))
(define (rdf-qname-local qname)
(guarantee-rdf-qname qname 'RDF-QNAME-LOCAL)
- (let ((s (symbol-name qname)))
+ (let ((s (symbol->string qname)))
(string-tail s (fix:+ (string-find-next-char s #\:) 1))))
(define (split-rdf-qname qname)
(guarantee-rdf-qname qname 'SPLIT-RDF-QNAME)
- (let ((s (symbol-name qname)))
+ (let ((s (symbol->string qname)))
(let ((i (fix:+ (string-find-next-char s #\:) 1)))
(values (symbol (string-head s i))
(string-tail s i)))))
(write-rdf/turtle-prefix (car p) (cdr p) port))
(sort (hash-table->alist table)
(lambda (a b)
- (let ((a (symbol-name (car a)))
- (b (symbol-name (car b))))
+ (let ((a (symbol->string (car a)))
+ (b (symbol->string (car b))))
(string<?
(string-head a (fix:- (string-length a) 1))
(string-head b (fix:- (string-length b) 1)))))))))
(let ((start (string-length expansion)))
(if (*match-string match:name s start end)
(begin
- (write-string (symbol-name prefix) port)
+ (write-string (symbol->string prefix) port)
(write-substring s start end port))
(write-rdf/nt-uri uri port)))
(write-rdf/nt-uri uri port)))))
(write-char #\space port))
(define (write-symbol symbol port)
- (write-string (symbol-name symbol) port))
+ (write-string (symbol->string symbol) port))
(define (write-parens open close indentation port procedure)
(write-string open port)
(guarantee-keyword-list keyword-list 'HTML:STYLE-ATTR)
(if (pair? keyword-list)
(let loop ((bindings keyword-list))
- (string-append (symbol-name (car bindings))
+ (string-append (symbol->string (car bindings))
": "
(cadr bindings)
(if (pair? (cddr bindings))
(define-guarantee xml-name "an XML Name")
(define (xml-name-string name)
- (symbol-name (xml-name->symbol name)))
+ (symbol->string (xml-name->symbol name)))
(define (xml-name->symbol name)
(cond ((xml-name-symbol? name) name)
(string->symbol object))
(begin
(guarantee-symbol object constructor)
- (if (not (string-predicate (symbol-name object)))
+ (if (not (string-predicate (symbol->string object)))
(error:bad-range-argument object constructor))
object))))
(define (name-predicate string-predicate)
(lambda (object)
(and (symbol? object)
- (string-predicate (symbol-name object)))))
+ (string-predicate (symbol->string object)))))
(define xml-name-symbol? (name-predicate string-is-xml-name?))
(define xml-nmtoken? (name-predicate string-is-xml-nmtoken?))
(%xml-qname-prefix qname))
(define (%xml-qname-prefix qname)
- (let ((s (symbol-name qname)))
+ (let ((s (symbol->string qname)))
(let ((c (string-find-next-char s #\:)))
(if c
(string->symbol (string-head s c))
(%xml-qname-local qname))
(define (%xml-qname-local qname)
- (let ((s (symbol-name qname)))
+ (let ((s (symbol->string qname)))
(let ((c (string-find-next-char s #\:)))
(if c
(string->symbol (string-tail s (fix:+ c 1)))
(emit-string " " ctx)
(let ((type (xml-!element-content-type decl)))
(cond ((symbol? type)
- (emit-string (string-upcase (symbol-name type)) ctx))
+ (emit-string (string-upcase (symbol->string type)) ctx))
((and (pair? type) (eq? (car type) '|#PCDATA|))
(emit-string "(#PCDATA" ctx)
(if (pair? (cdr type))
(emit-string " " ctx)
(let ((type (cadr definition)))
(cond ((symbol? type)
- (emit-string (string-upcase (symbol-name type)) ctx))
+ (emit-string (string-upcase (symbol->string type)) ctx))
((and (pair? type) (eq? (car type) '|NOTATION|))
(emit-string "NOTATION (" ctx)
(if (pair? (cdr type))
(let ((default (caddr definition)))
(cond ((or (eq? default '|#REQUIRED|)
(eq? default '|#IMPLIED|))
- (emit-string (symbol-name default) ctx))
+ (emit-string (symbol->string default) ctx))
((and (pair? default) (eq? (car default) '|#FIXED|))
- (emit-string (symbol-name (car default)) ctx)
+ (emit-string (symbol->string (car default)) ctx)
(emit-string " " ctx)
(write-xml-attribute-value (cdr default) ctx))
((and (pair? default) (eq? (car default) 'default))
(string-length (xml-name-string name)))
(define (write-xml-nmtoken nmtoken ctx)
- (emit-string (symbol-name nmtoken) ctx))
+ (emit-string (symbol->string nmtoken) ctx))
(define (write-entity-value value col ctx)
(if (xml-external-id? value)
(((ctx-char-map ctx) char)
=> (lambda (name)
(emit-char #\& ctx)
- (emit-string (symbol-name name) ctx)
+ (emit-string (symbol->string name) ctx)
(emit-char #\; ctx)))
(else
(emit-char char ctx))))
(lambda (v)
(let ((name (vector-ref v 0))
(text (vector-ref v 1)))
- (if (string-ci=? (symbol-name name) "xml")
+ (if (string-ci=? (symbol->string name) "xml")
(perror p "Reserved XML processor name" name))
(let ((entry (assq name *pi-handlers*)))
(if entry
(ERROR:WRONG-TYPE-ARGUMENT
OBJECT
,(string-append "an XML "
- (string-replace (symbol-name (cadr form))
+ (string-replace (symbol->string (cadr form))
#\-
#\space))
CALLER))
(define (convert-xml-string-value value)
(cond ((xml-content-item? value) value)
- ((symbol? value) (symbol-name value))
+ ((symbol? value) (symbol->string value))
((number? value) (number->string value))
((uri? value) (uri->string value))
((list-of-type? value xml-nmtoken?) (nmtokens->string value))
(for-each (lambda (nmtokens)
(if (not (builder 'empty?))
(builder #\space))
- (builder (symbol-name (car nmtokens))))
+ (builder (symbol->string (car nmtokens))))
nmtokens)
(builder)))
\ No newline at end of file
projects / mit-scheme.git / commitdiff