home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / symbol.scm < prev    next >
Text File  |  2001-06-15  |  3KB  |  98 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: symbol.scm,v 1.5 2001/06/15 20:38:49 cph Exp $
  4.  
  5. Copyright (c) 1992-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  20. 02111-1307, USA.
  21. |#
  22.  
  23. ;;;; Symbols
  24. ;;; package: (runtime scode)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define (symbol? object)
  29.   (or (interned-symbol? object)
  30.       (uninterned-symbol? object)))
  31.  
  32. (define-integrable (interned-symbol? object)
  33.   (object-type? (ucode-type interned-symbol) object))
  34.  
  35. (define-integrable (uninterned-symbol? object)
  36.   (object-type? (ucode-type uninterned-symbol) object))
  37.  
  38. (define (string->uninterned-symbol string)
  39.   (if (not (string? string))
  40.       (error:wrong-type-argument string "string" 'STRING->UNINTERNED-SYMBOL))
  41.   ((ucode-primitive system-pair-cons)
  42.    (ucode-type uninterned-symbol)
  43.    string
  44.    ;; Magic: must match microcode and "urtrap".
  45.    ((ucode-primitive primitive-object-set-type)
  46.     (ucode-type reference-trap)
  47.     2)))
  48.  
  49. (define (string->symbol string)
  50.   ;; Calling STRING-COPY prevents the symbol from being affected if
  51.   ;; the string is mutated.  The string is copied only if the symbol
  52.   ;; is created.
  53.   (or ((ucode-primitive find-symbol) string)
  54.       ((ucode-primitive string->symbol) (string-copy string))))
  55.  
  56. (define (intern string)
  57.   (if (string-lower-case? string)
  58.       (string->symbol string)
  59.       ((ucode-primitive string->symbol) (string-downcase string))))
  60.  
  61. (define (intern-soft string)
  62.   ((ucode-primitive find-symbol)
  63.    (if (string-lower-case? string)
  64.        string
  65.        (string-downcase string))))
  66.  
  67. (define (symbol-name symbol)
  68.   (if (not (symbol? symbol))
  69.       (error:wrong-type-argument symbol "symbol" 'SYMBOL-NAME))
  70.   (system-pair-car symbol))
  71.  
  72. (define-integrable (symbol->string symbol)
  73.   (string-copy (symbol-name symbol)))
  74.  
  75. (define (symbol-append . symbols)
  76.   (let ((string (apply string-append (map symbol-name symbols))))
  77.     (string-downcase! string)
  78.     ((ucode-primitive string->symbol) string)))
  79.  
  80. (define-integrable (symbol-hash symbol)
  81.   (string-hash (symbol-name symbol)))
  82.  
  83. (define-integrable (symbol-hash-mod symbol modulus)
  84.   (string-hash-mod (symbol-name symbol) modulus))
  85.  
  86. (define (symbol<? x y)
  87.   (let ((sx (system-pair-car x))
  88.     (sy (system-pair-car y)))
  89.     (let ((lx (string-length sx))
  90.       (ly (string-length sy)))
  91.       (let ((l (if (fix:< lx ly) lx ly)))
  92.     (let loop ((i 0))
  93.       (cond ((fix:= i l)
  94.          (fix:< lx ly))
  95.         ((fix:= (vector-8b-ref sx i) (vector-8b-ref sy i))
  96.          (loop (fix:+ i 1)))
  97.         (else
  98.          (fix:< (vector-8b-ref sx i) (vector-8b-ref sy i)))))))))