From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 23 Jan 2018 06:43:03 +0000 (-0800)
Subject: Merge gensym into symbol and add mutex for its counter.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~315
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1d2b6d43091536331a0ef79e24d0955d4b51d592;p=mit-scheme.git

Merge gensym into symbol and add mutex for its counter.
---

diff --git a/src/runtime/ed-ffi.scm b/src/runtime/ed-ffi.scm
index 81a2a3b50..3f38ceed0 100644
--- a/src/runtime/ed-ffi.scm
+++ b/src/runtime/ed-ffi.scm
@@ -79,7 +79,6 @@ USA.
     ("gdbm"	(runtime gdbm))
     ("gencache"	(runtime tagged-dispatch))
     ("genio"	(runtime generic-i/o-port))
-    ("gensym"	(runtime gensym))
     ("gentag"	(runtime tagged-dispatch))
     ("global"	(runtime miscellaneous-global))
     ("graphics"	(runtime graphics))
diff --git a/src/runtime/gensym.scm b/src/runtime/gensym.scm
deleted file mode 100644
index 3c6b424c3..000000000
--- a/src/runtime/gensym.scm
+++ /dev/null
@@ -1,59 +0,0 @@
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
-    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
-    2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Symbol Generation
-;;; package: (runtime gensym)
-
-(declare (usual-integrations))
-
-(define (generate-uninterned-symbol #!optional argument)
-  (let ((prefix
-	 (cond ((or (default-object? argument) (not argument))
-		name-prefix)
-	       ((string? argument)
-		argument)
-	       ((symbol? argument)
-		(symbol->string argument))
-	       ((exact-nonnegative-integer? argument)
-		(set! name-counter argument)
-		name-prefix)
-	       (else
-		(error:wrong-type-argument argument "symbol or integer"
-					   'GENERATE-UNINTERNED-SYMBOL)))))
-    (string->uninterned-symbol
-     (string-append prefix
-		    (number->string
-		     (let ((result name-counter))
-		       (set! name-counter (1+ name-counter))
-		       result))))))
-
-(define name-counter)
-(define name-prefix)
-
-(define (initialize-package!)
-  (set! name-counter 0)
-  (set! name-prefix "G")
-  unspecific)
\ No newline at end of file
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index ac06ee3aa..8b9e56e59 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -465,7 +465,6 @@ USA.
    (RUNTIME CHARACTER-SET)
    (RUNTIME LAMBDA-ABSTRACTION)
    (RUNTIME USTRING)
-   (RUNTIME GENSYM)
    (RUNTIME STREAM)
    (RUNTIME 2D-PROPERTY)
    (RUNTIME HASH-TABLE)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e2ae82dc7..6d2b8e73a 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -755,6 +755,7 @@ USA.
 	  intern
 	  intern-soft
 	  interned-symbol?
+	  generate-uninterned-symbol
 	  string->symbol
 	  string->uninterned-symbol
 	  symbol
@@ -2342,13 +2343,6 @@ USA.
   (export (runtime subprocess)
 	  make-generic-i/o-port))
 
-(define-package (runtime gensym)
-  (files "gensym")
-  (parent (runtime))
-  (export ()
-	  generate-uninterned-symbol)
-  (initialization (initialize-package!)))
-
 (define-package (runtime global-database)
   (files "gdatab")
   (parent (runtime))
diff --git a/src/runtime/symbol.scm b/src/runtime/symbol.scm
index 4bc8787ef..989a34584 100644
--- a/src/runtime/symbol.scm
+++ b/src/runtime/symbol.scm
@@ -87,6 +87,37 @@ USA.
 (define (symbol>? x y)
   (string<? (symbol-name y) (symbol-name x)))
 
+(define generate-uninterned-symbol
+  (let ((mutex (make-thread-mutex))
+	(counter 0)
+	(default-prefix "G"))
+    (named-lambda (generate-uninterned-symbol #!optional argument)
+      (let ((finish
+	     (lambda (prefix)
+	       (string->uninterned-symbol
+		(string-append prefix
+			       (number->string
+				(with-thread-mutex-lock mutex
+				  (lambda ()
+				    (let ((n counter))
+				      (set! counter (+ counter 1))
+				      n)))))))))
+	(cond ((or (default-object? argument) (not argument))
+	       (finish default-prefix))
+	      ((string? argument)
+	       (finish argument))
+	      ((symbol? argument)
+	       (finish (symbol->string argument)))
+	      ((exact-nonnegative-integer? argument)
+	       (with-thread-mutex-lock mutex
+		 (lambda ()
+		   (set! counter argument)
+		   unspecific))
+	       (finish default-prefix))
+	      (else
+	       (error "Invalid argument to generate-uninterned-symbol:"
+		      argument)))))))
+
 (define-integrable (->bytes maybe-string)
   (object-new-type (ucode-type bytevector) maybe-string))