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

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index e3d17c76eec8cdf664bac6f30aa31a34bdb062b3..2abd763f924ce3c847f785bdbfb83fe2094e5f5b 100644 (file)
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -353,14 +353,15 @@ USA.
 \f
 ;;; 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 6eb5414e584f93f52611c30ace05ff345afda160..1f568f9b94692e824a4157ddbbb372b4e337551a 100644 (file)
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -1187,6 +1187,38 @@ USA.
                (if (char=? char char1) char2 char))
              string))
 \f
+(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)))
+\f
 (define (string-8-bit? string)
   (receive (string start end) (translate-slice string 0 (string-length string))
     (if (legacy-string? string)