← Back to branch summary

~ubuntu-branches/ubuntu/trusty/mit-scheme/trusty-proposed

« back to all changes in this revision

Viewing changes to src/runtime/symbol.scm

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2006-09-20 21:59:42 UTC
  • mfrom: (1.1.4 upstream) (3.1.1 etch)
  • Revision ID: james.westby@ubuntu.com-20060920215942-o3erry1wowyk1ezz
Tags: 7.7.90+20060906-3
No changes; rebuild with downgraded openssl in order to permit
transition into testing.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/runtime/symbol.scm
1
1
#| -*-Scheme-*-
2
2
 
3
 
$Id: symbol.scm,v 1.19 2005/05/30 18:49:01 cph Exp $
 
3
$Id: symbol.scm,v 1.21 2006/07/27 00:03:57 cph Exp $
4
4
 
5
5
Copyright 1992,1993,2001,2003,2004,2005 Massachusetts Institute of Technology
 
6
Copyright 2006 Massachusetts Institute of Technology
6
7
 
7
8
This file is part of MIT/GNU Scheme.
8
9
 
38
39
(define-integrable (uninterned-symbol? object)
39
40
  (object-type? (ucode-type uninterned-symbol) object))
40
41
 
41
 
(define-integrable (guarantee-symbol object caller)
42
 
  (if (not (symbol? object))
43
 
      (error:wrong-type-argument object "symbol" caller)))
44
 
 
45
 
(define-integrable (guarantee-interned-symbol object caller)
46
 
  (if (not (interned-symbol? object))
47
 
      (error:wrong-type-argument object "interned symbol" caller)))
48
 
 
49
 
(define-integrable (guarantee-uninterned-symbol object caller)
50
 
  (if (not (uninterned-symbol? object))
51
 
      (error:wrong-type-argument object "uninterned symbol" caller)))
 
42
(define-guarantee symbol "symbol")
 
43
(define-guarantee interned-symbol "interned symbol")
 
44
(define-guarantee uninterned-symbol "uninterned symbol")
52
45
 
53
46
(define (string->uninterned-symbol string)
54
47
  (make-uninterned-symbol (if (string? string)
100
93
        (else (error:wrong-type-argument object "symbol component" 'SYMBOL))))
101
94
 
102
95
(define (intern string)
103
 
  (if (string-lower-case? string)
104
 
      (string->symbol string)
105
 
      ((ucode-primitive string->symbol) (string-downcase string))))
 
96
  ((ucode-primitive string->symbol)
 
97
   (utf8-string-downcase
 
98
    (if (string? string)
 
99
        string
 
100
        (wide-string->utf8-string string)))))
106
101
 
107
102
(define (intern-soft string)
108
103
  ((ucode-primitive find-symbol)
109
 
   (if (string-lower-case? string)
110
 
       string
111
 
       (string-downcase string))))
 
104
   (utf8-string-downcase
 
105
    (if (string? string)
 
106
        string
 
107
        (wide-string->utf8-string string)))))
 
108
 
 
109
(define (utf8-string-downcase string)
 
110
  (if (ascii-string? string)
 
111
      ;; Needed during cold load.
 
112
      (string-downcase string)
 
113
      (call-with-input-string string
 
114
        (lambda (input)
 
115
          (port/set-coding input 'utf-8)
 
116
          (call-with-output-string
 
117
            (lambda (output)
 
118
              (port/set-coding output 'utf-8)
 
119
              (let loop ()
 
120
                (let ((c (read-char input)))
 
121
                  (if (not (eof-object? c))
 
122
                      (begin
 
123
                        (write-char (char-downcase c) output)
 
124
                        (loop)))))))))))
 
125
 
 
126
(define (ascii-string? string)
 
127
  (let ((end (string-length string)))
 
128
    (let loop ((i 0))
 
129
      (if (fix:< i end)
 
130
          (and (fix:< (vector-8b-ref string i) #x80)
 
131
               (loop (fix:+ i 1)))
 
132
          #t))))
112
133
 
113
134
(define (symbol-name symbol)
114
135
  (guarantee-symbol symbol 'SYMBOL-NAME)