From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 11 Oct 1993 23:16:41 +0000 (+0000)
Subject: New procedures SYMBOL=? and SYMBOL<?.
X-Git-Tag: 20090517-FFI~7779
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=28118690d11627c8bc95bfb358eb00217841529f;p=mit-scheme.git

New procedures SYMBOL=? and SYMBOL<?.
---

diff --git a/v7/src/runtime/symbol.scm b/v7/src/runtime/symbol.scm
index 57b4d3390..f28953153 100644
--- a/v7/src/runtime/symbol.scm
+++ b/v7/src/runtime/symbol.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: symbol.scm,v 1.1 1992/12/07 22:07:36 cph Exp $
+$Id: symbol.scm,v 1.2 1993/10/11 23:16:41 cph Exp $
 
-Copyright (c) 1992 Massachusetts Institute of Technology
+Copyright (c) 1992-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -88,4 +88,31 @@ MIT in each case. |#
   (string-hash (symbol-name symbol)))
 
 (define-integrable (symbol-hash-mod symbol modulus)
-  (string-hash-mod (symbol-name symbol) modulus))
\ No newline at end of file
+  (string-hash-mod (symbol-name symbol) modulus))
+
+(define (symbol=? x y)
+  (or (eq? x y)
+      (and (uninterned-symbol? x)
+	   (uninterned-symbol? y)
+	   (let ((sx (system-pair-car x))
+		 (sy (system-pair-car y)))
+	     (let ((l (string-length sx)))
+	       (and (fix:= l (string-length sy))
+		    (let loop ((i 0))
+		      (or (fix:= i l)
+			  (and (char=? (string-ref sx i) (string-ref sy i))
+			       (loop (fix:+ i 1)))))))))))
+
+(define (symbol<? x y)
+  (let ((sx (system-pair-car x))
+	(sy (system-pair-car y)))
+    (let ((lx (string-length sx))
+	  (ly (string-length sy)))
+      (let ((l (if (fix:< lx ly) lx ly)))
+	(let loop ((i 0))
+	  (cond ((fix:= i l)
+		 (fix:< lx ly))
+		((fix:= (vector-8b-ref sx i) (vector-8b-ref sy i))
+		 (loop (fix:+ i 1)))
+		(else
+		 (fix:< (vector-8b-ref sx i) (vector-8b-ref sy i)))))))))
\ No newline at end of file