From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 28 Feb 2017 06:13:51 +0000 (-0800)
Subject: Implement string-trimmer; hack cold-load to get boot inits earlier.
X-Git-Tag: mit-scheme-pucked-9.2.12~198^2~12
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b80e388c406caa23928735e70293be858e41ed29;p=mit-scheme.git

Implement string-trimmer; hack cold-load to get boot inits earlier.
---

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index e3d17c76e..2abd763f9 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -353,14 +353,15 @@ USA.
 
 ;;; Global databases.  Load, then initialize.
 (define boot-defs)
-(let ((files1
+(let ((files0
        '(("gcdemn" . (RUNTIME GC-DAEMONS))
 	 ("gc" . (RUNTIME GARBAGE-COLLECTOR))
 	 ("boot" . (RUNTIME BOOT-DEFINITIONS))
 	 ("queue" . (RUNTIME SIMPLE-QUEUE))
 	 ("equals" . (RUNTIME EQUALITY))
-	 ("list" . (RUNTIME LIST))
-	 ("ustring" . (RUNTIME USTRING))
+	 ("list" . (RUNTIME LIST))))
+      (files1
+       '(("ustring" . (RUNTIME USTRING))
 	 ("symbol" . (RUNTIME SYMBOL))
 	 ("uproc" . (RUNTIME PROCEDURE))
 	 ("fixart" . (RUNTIME FIXNUM-ARITHMETIC))
@@ -383,8 +384,23 @@ USA.
 	 (do ((files files (cdr files)))
 	     ((null? files))
 	   (eval (file->object (car (car files)) #t #t)
-		 (package-reference (cdr (car files))))))))
-  (load-files files1)
+		 (package-reference (cdr (car files)))))))
+      (load-files-with-boot-inits
+       (lambda (files)
+	 (do ((files files (cdr files)))
+	     ((null? files))
+	   ((access init-boot-inits! boot-defs))
+	   (let ((environment (package-reference (cdr (car files)))))
+	     (eval (file->object (car (car files)) #t #t)
+		   environment)
+	     ((access save-boot-inits! boot-defs) environment))))))
+
+  (load-files files0)
+
+  (set! boot-defs
+	(package/environment (name->package '(RUNTIME BOOT-DEFINITIONS))))
+
+  (load-files-with-boot-inits files1)
   (package-initialize '(RUNTIME GC-DAEMONS) #f #t)
   (package-initialize '(RUNTIME GARBAGE-COLLECTOR) #f #t)
   (package-initialize '(RUNTIME RANDOM-NUMBER) #f #t)
@@ -392,7 +408,8 @@ USA.
 		      #t)
   (package-initialize '(RUNTIME POPULATION) #f #t)
   (package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t)
-  (load-files files2)
+
+  (load-files-with-boot-inits files2)
   (package-initialize '(RUNTIME 1D-PROPERTY) #f #t)	     ;First population.
   (package-initialize '(RUNTIME STATE-SPACE) #f #t)
   (package-initialize '(RUNTIME THREAD) 'INITIALIZE-LOW! #t) ;First 1d-table.
@@ -402,9 +419,6 @@ USA.
   (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! #t)
   (package-initialize '(RUNTIME GC-FINALIZER) #f #t)
 
-  (set! boot-defs
-	(package/environment (name->package '(RUNTIME BOOT-DEFINITIONS))))
-
   ;; Load everything else.
   ((lexical-reference environment-for-package 'LOAD-PACKAGES-FROM-FILE)
    packages-file
@@ -420,6 +434,7 @@ USA.
      (lambda (filename environment)
        (if (not (or (string=? filename "make")
 		    (string=? filename "packag")
+		    (file-member? filename files0)
 		    (file-member? filename files1)
 		    (file-member? filename files2)))
 	   (begin
@@ -445,6 +460,7 @@ USA.
    (RUNTIME CHARACTER)
    (RUNTIME BYTEVECTOR)
    (RUNTIME CHARACTER-SET)
+   (RUNTIME USTRING)
    (RUNTIME GENSYM)
    (RUNTIME STREAM)
    (RUNTIME 2D-PROPERTY)
diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index 6eb5414e5..1f568f9b9 100644
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -1187,6 +1187,38 @@ USA.
 		(if (char=? char char1) char2 char))
 	      string))
 
+(define (string-trimmer . options)
+  (receive (where copy? trim-char?)
+      (string-trimmer-options options 'string-trimmer)
+    (let ((get-trimmed (if copy? string-copy string-slice)))
+      (lambda (string)
+	(let ((end (string-length string)))
+	  (get-trimmed
+	   string
+	   (if (eq? where 'trailing)
+	       0
+	       (let loop ((index 0))
+		 (if (and (fix:< index end)
+			  (trim-char? (string-ref string index)))
+		     (loop (fix:+ index 1))
+		     index)))
+	   (if (eq? where 'leading)
+	       end
+	       (let loop ((index end))
+		 (if (and (fix:> index 0)
+			  (trim-char? (string-ref string (fix:- index 1))))
+		     (loop (fix:- index 1))
+		     index)))))))))
+
+(define-deferred string-trimmer-options
+  (keyword-option-parser
+   (list (list 'where where-value? 'both)
+	 (list 'copy? boolean? #t)
+	 (list 'trim-char? unary-procedure? char-whitespace?))))
+
+(define (where-value? object)
+  (memq object '(leading trailing both)))
+
 (define (string-8-bit? string)
   (receive (string start end) (translate-slice string 0 (string-length string))
     (if (legacy-string? string)