core: Add string-append.
authorJan Nieuwenhuizen <janneke@gnu.org>
Thu, 15 Nov 2018 22:09:56 +0000 (23:09 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Thu, 15 Nov 2018 22:09:56 +0000 (23:09 +0100)
* src/strings.c (string_append): New function.
* mes/module/mes/boot-0.scm.in (string-append): Remove.
* mes/module/mes/boot-03.scm (string-append): Remove.
* scaffold/boot/50-make-string.scm (string-append): Remove.
* scaffold/boot/50-string-append.scm (string-append): Remove.
* scaffold/boot/50-string-join.scm (string-append): Remove.
* scaffold/boot/51-module.scm (string-append): Remove.
* scaffold/boot/52-define-module.scm (string-append): Remove.
* tests/macro.test (string-append): Remove.
* scaffold/boot/17-string-append.scm: Move from 50-string-append.scm.

build-aux/check-boot.sh
mes/module/mes/boot-0.scm.in
mes/module/mes/boot-03.scm
scaffold/boot/17-string-append.scm [new file with mode: 0644]
scaffold/boot/50-make-string.scm
scaffold/boot/50-string-append.scm [deleted file]
scaffold/boot/50-string-join.scm
scaffold/boot/51-module.scm
scaffold/boot/52-define-module.scm
src/strings.c
tests/macro.test

index 630567fde9bf6ec7c56ee4289135704b844656b7..bb5660c8a17cc073d80b05efc28c67138fa6b8a7 100755 (executable)
@@ -50,6 +50,7 @@ tests="
 17-memq-keyword.scm
 17-string-equal.scm
 17-equal2.scm
+17-string-append.scm
 17-open-input-string.scm
 
 20-define.scm
index 0d5d9c960192c1f459f18704923a3e3c7ac2648f..a5d7a2751acb4d5a0a21293d3c389cb04a0497a9 100644 (file)
 (include (list->string
           (append2 (string->list %moduledir) (string->list "mes/type-0.mes"))))
 
-(define (string-append . rest)
-  (apply string (apply append (map1 string->list rest))))
-
 (if (and (getenv "MES_DEBUG")
           (not (equal2? (getenv "MES_DEBUG") "0"))
           (not (equal2? (getenv "MES_DEBUG") "1")))
index 4bfc6a3c5597cfdd950c3f36ee308ff3454d4e90..b61874fa46a24c2ee40ac77960799ce84d137bed 100644 (file)
 (include (list->string
           (append2 (string->list %moduledir) (string->list "mes/type-0.mes"))))
 
-(define (string-append . rest)
-  (apply string (apply append (map1 string->list rest))))
-
 (if (and (getenv "MES_DEBUG")
           (not (equal2? (getenv "MES_DEBUG") "0"))
           (not (equal2? (getenv "MES_DEBUG") "1")))
diff --git a/scaffold/boot/17-string-append.scm b/scaffold/boot/17-string-append.scm
new file mode 100644 (file)
index 0000000..e6edeee
--- /dev/null
@@ -0,0 +1,21 @@
+;;; GNU Mes --- Maxwell Equations of Software
+;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of GNU Mes.
+;;;
+;;; GNU Mes 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 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Mes 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 GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+(if (string=? (string-append "foo" "/" "bar") "foo/bar")
+    (exit 0))
+(exit 1)
index bedf7f1c3f9c5ae66ed2b686291e422df3e3fdd2..0218fc8d88b0ff2ef97eac3babfec88c4421dcb2 100644 (file)
             (append2 (car rest) (apply append (cdr rest))))))
 
   (define (string . lst)
-    (list->string lst))
-
-  (define (map1 f lst)
-    (if (null? lst) (list)
-        (cons (f (car lst)) (map1 f (cdr lst)))))
-
-  (define map map1)
-
-  (define (string-append . rest)
-    (apply string (apply append (map string->list rest))))))
+    (list->string lst))))
 
 (define (make-list n . fill)
   fill)
diff --git a/scaffold/boot/50-string-append.scm b/scaffold/boot/50-string-append.scm
deleted file mode 100644 (file)
index 48edbea..0000000
+++ /dev/null
@@ -1,49 +0,0 @@
-;;; GNU Mes --- Maxwell Equations of Software
-;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; This file is part of GNU Mes.
-;;;
-;;; GNU Mes 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 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Mes 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 GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-(cond-expand
- (guile)
- (mes
-  (define (cons* . rest)
-    (if (null? (cdr rest)) (car rest)
-        (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
-
-  (define (apply f h . t)
-    (if (null? t) (core:apply f h (current-module))
-        (apply f (apply cons* (cons h t)))))
-
-  (define (append . rest)
-    (if (null? rest) '()
-        (if (null? (cdr rest)) (car rest)
-            (append2 (car rest) (apply append (cdr rest))))))
-
-  (define (string . lst)
-    (list->string lst))
-
-  (define (map1 f lst)
-    (if (null? lst) (list)
-        (cons (f (car lst)) (map1 f (cdr lst)))))
-
-  (define map map1)
-
-  (define (string-append . rest)
-    (apply string (apply append (map string->list rest))))))
-
-(if (string=? (string-append "foo" "/" "bar") "foo/bar")
-    (exit 0))
-(exit 1)
index 4699ed7f5c49c4787b45bf96b9b88e07710061df..a7398fca88d6503261e20e2a16ba6c766122b3ce 100644 (file)
     (if (null? lst) (list)
         (cons (f (car lst)) (map1 f (cdr lst)))))
 
-  (define map map1)
+  (define map map1)))
 
-  (define (string-append . rest)
-    (apply string (apply append (map string->list rest))))))
-
-  (define (string-join lst infix)
-    (if (null? (cdr lst)) (car lst)
-        (string-append (car lst) infix (string-join (cdr lst) infix))))
+(define (string-join lst infix)
+  (if (null? (cdr lst)) (car lst)
+      (string-append (car lst) infix (string-join (cdr lst) infix))))
 
 (if (string=? (string-join '("foo" "bar") "/") "foo/bar")
     (exit 0))
index 50ff9e803a524e12446f923697f9151f2c63130d..830401451e73bf8ce1b0b8d995825238a179b40c 100644 (file)
@@ -45,9 +45,6 @@
   (define (string . lst)
     (list->string lst))
 
-  (define (string-append . rest)
-    (apply string (apply append (map string->list rest))))
-
   (define %prefix (getenv "MES_PREFIX"))
 
   (define (not x) (if x #f #t))
index 57e55dbfa58f11c71eb7c2efeb4b36db7d977c14..f84705f27ed47035c4ccd8268bc3e05d8d2b886f 100644 (file)
@@ -49,9 +49,6 @@
 
   (define map map1)
 
-  (define (string-append . rest)
-    (apply string (apply append (map string->list rest))))
-
 ;;;;;;;;;;;;;;;;;;
   (define (string-join lst infix)
     (if (null? (cdr lst)) (car lst)
index fe86311aeaeebdaa5e5383e9c77853030f3a0844..11630a26f21c3f507e51457ff9daec3c78cafe2d 100644 (file)
@@ -240,3 +240,23 @@ read_string (SCM port) ///((arity . n))
   g_stdin = fd;
   return make_string (buf, i);
 }
+
+SCM
+string_append (SCM x) ///((arity . n))
+{
+  static char buf[MAX_STRING];
+  char const *p = buf;
+  buf[0] = 0;
+  size_t size = 0;
+  while (x != cell_nil)
+    {
+      SCM string = CAR (x);
+      assert (TYPE (string) == TSTRING);
+      memcpy (p, CSTRING (string), LENGTH (string) + 1);
+      p += LENGTH (string);
+      size += LENGTH (string);
+      assert (size < MAX_STRING);
+      x = CDR (x);
+    }
+  return make_string (buf, size);
+}
index 1ebaba92e3d2bf2ae762db5d318e5310cb042dbf..d98a03249b297ca72fa0db8b95a38bec3fa12bba 100755 (executable)
@@ -59,10 +59,6 @@ exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests macr
 (define (string . lst)
   (list->string lst))
 
-;; boot-0.scm
-(define (string-append . rest)
-  (apply string (apply append (map1 string->list rest))))
-
 ;; scm.mes
 (define (symbol-append . rest)
   (string->symbol (apply string-append (map symbol->string rest))))