core: String as array of bytes.

* src/strings.c: New file.
* src/mes.c: Use it.  Update users.

build-aux/build-mes.sh

@@ -75,8 +75,8 @@ compile scaffold/argv
 [ "$mes_p" ] && link scaffold/micro-mes
 [ "$mes_p" ] && compile scaffold/tiny-mes
 [ "$mes_p" ] && link scaffold/tiny-mes
-[ "$mes_p" ] && compile scaffold/mini-mes
+#[ "$mes_p" ] && compile scaffold/mini-mes
-[ "$mes_p" ] && link scaffold/mini-mes
+#[ "$mes_p" ] && link scaffold/mini-mes
 
 compile src/mes
 link src/mes

build-aux/check-boot.sh

@@ -46,6 +46,12 @@ tests="
 
 16-if-eq-quote.scm
 
+17-memq.scm
+17-memq-keyword.scm
+17-string-equal.scm
+17-equal2.scm
+17-open-input-string.scm
+
 20-define.scm
 20-define-quoted.scm
 20-define-quote.scm
@@ -99,6 +105,8 @@ tests="
 4e-let-global.scm
 4f-string-split.scm
 
+50-string-append.scm
+50-string-join.scm
 50-primitive-load.scm
 51-module.scm
 52-define-module.scm

build-aux/check-mes.sh

@@ -52,6 +52,7 @@ tests/guile.test
 tests/syntax.test
 tests/let-syntax.test
 tests/pmatch.test
+tests/posix.test
 tests/match.test
 tests/psyntax.test
 "

build-aux/config.sh

@@ -87,8 +87,7 @@ CPPFLAGS=${CPPFLAGS-"
 -D 'VERSION=\"$VERSION\"'
 -D 'MODULEDIR=\"$moduledir\"'
 -D 'PREFIX=\"$prefix\"'
--I src
+-I ${srcdest}.
--I ${srcdest}src
 -I ${srcdest}lib
 -I ${srcdest}include
 "}
@@ -97,6 +96,7 @@ CPPFLAGS=${CPPFLAGS-"
 
 LDFLAGS=${LDFLAGS-"
 -v
+-g
 -L lib/linux/$mes_arch
 -L lib/linux
 -L lib/$mes_arch

build-aux/mes-snarf.scm

@@ -110,8 +110,8 @@ exec ${GUILE-guile} --no-auto-compile -L $(dirname $0) -C $(dirname $0) -e '(mes
 
 (define (symbol->names s i)
   (if %gcc?
-      (format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.name);\n" s s)
+      (format #f "NAME_SYMBOL (cell_~a, scm_~a.name);\n" s s)
-      (format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.car);\n" s s)))
+      (format #f "NAME_SYMBOL (cell_~a, scm_~a.cdr);\n" s s)))
 
 (define (function->header f i)
   (let* ((arity (or (assoc-ref (function.annotation f) 'arity)
@@ -132,7 +132,7 @@ exec ${GUILE-guile} --no-auto-compile -L $(dirname $0) -C $(dirname $0) -e '(mes
   (string-append
    (if %gcc?
        (format #f "~a.function = g_function;\n" (function-builtin-name f))
-       (format #f "~a.cdr = g_function;\n" (function-builtin-name f)))
+       (format #f "~a.car = g_function;\n" (function-builtin-name f)))
    (format #f "g_functions[g_function++] = fun_~a;\n" (function.name f))
    (format #f "cell_~a = g_free++;\n" (function.name f))
    (format #f "g_cells[cell_~a] = ~a;\n\n" (function.name f) (function-builtin-name f))))
@@ -140,14 +140,11 @@ exec ${GUILE-guile} --no-auto-compile -L $(dirname $0) -C $(dirname $0) -e '(mes
 (define (function->environment f i)
   (string-append
    (if %gcc?
-       (format #f "scm_~a.string = cstring_to_list (fun_~a.name);\n" (function.name f) (function.name f))
+       (format #f "scm_~a.string = MAKE_BYTES0 (fun_~a.name);\n" (function.name f) (function.name f))
-       (format #f "scm_~a.car = cstring_to_list (fun_~a.name);\n" (function.name f) (function.name f)))
+       (format #f "scm_~a.cdr = MAKE_BYTES0 (fun_~a.name);\n" (function.name f) (function.name f)))
    (if %gcc?
-       (format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (function.name f) (function.name f))
+       (format #f "a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_~a)), ~a, a);\n\n" (function.name f) (function-cell-name f))
-       (format #f "g_cells[cell_~a].car = MAKE_STRING (scm_~a.car);\n" (function.name f) (function.name f)))
+       (format #f "a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_~a)), ~a, a);\n\n" (function.name f) (function-cell-name f)))))
-   (if %gcc?
-       (format #f "a = acons (list_to_symbol (scm_~a.string), ~a, a);\n\n" (function.name f) (function-cell-name f))
-       (format #f "a = acons (list_to_symbol (scm_~a.car), ~a, a);\n\n" (function.name f) (function-cell-name f)))))
 
 (define (disjoin . predicates)
   (lambda (. arguments)

build-aux/snarf.sh

@@ -35,5 +35,6 @@ trace "SNARF$snarf  mes.c"    ${srcdest}build-aux/mes-snarf.scm $1 src/mes.c
 trace "SNARF$snarf  module.c"  ${srcdest}build-aux/mes-snarf.scm $1 src/module.c
 trace "SNARF$snarf  posix.c"   ${srcdest}build-aux/mes-snarf.scm $1 src/posix.c
 trace "SNARF$snarf  reader.c"  ${srcdest}build-aux/mes-snarf.scm $1 src/reader.c
+trace "SNARF$snarf  strings.c" ${srcdest}build-aux/mes-snarf.scm $1 src/strings.c
 trace "SNARF$snarf  struct.c"  ${srcdest}build-aux/mes-snarf.scm $1 src/struct.c
 trace "SNARF$snarf  vector.c"  ${srcdest}build-aux/mes-snarf.scm $1 src/vector.c

include/linux/x86_64/syscall.h

@@ -59,6 +59,7 @@
 #define SYS_pipe      0x16
 #define SYS_getgid    0x68
 #define SYS_rt_sigaction 0x0d
+#define SYS_rt_sigreturn 0x0f
 #define SYS_fcntl     0x48
 #define SYS_dup2      0x21
 #define SYS_getrusage 0x62

include/signal.h

@@ -76,6 +76,7 @@ typedef long stack_t;
 #define SA_NOCLDSTOP 0x00000001
 #define SA_NOCLDWAIT 0x00000002
 #define SA_SIGINFO   0x00000004
+#define SA_RESTORER  0x04000000
 #define SA_ONSTACK   0x08000000
 #define SA_RESTART   0x10000000
 #define SA_NODEFER   0x40000000

lib/linux/gettimeofday.c

@@ -18,7 +18,7 @@
  * along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
  */
 
-#include <time.h>
+#include <sys/time.h>
 
 int
 gettimeofday (struct timeval *tv, struct timezone *tz)

lib/linux/gnu.c

@@ -63,19 +63,13 @@ getgid ()
   return _sys_call (SYS_getgid);
 }
 
-// long _sys_call (long sys_call);
+#if __x86_64__
-// long _sys_call4 (long sys_call, long one, long two, long three, long four);
-
-#define SA_SIGINFO 4
-#define SA_RESTORER 0x04000000
-
-#define SYS_rt_sigreturn 15
-
 void
 _restorer (void)
 {
   _sys_call (SYS_rt_sigreturn);
 }
+#endif
 
 # define __sigmask(sig) \
   (((unsigned long int) 1) << (((sig) - 1) % (8 * sizeof (unsigned long int))))

mes/module/mes/base.mes

@@ -101,6 +101,24 @@
   (or (null? x)
       (and (pair? x) (list? (cdr x)))))
 
+(define-macro (cond . clauses)
+  (list 'if (pair? clauses)
+        (list (cons
+               'lambda
+               (cons
+                '(test)
+                (list (list 'if 'test
+                            (if (pair? (cdr (car clauses)))
+                                (if (eq? (car (cdr (car clauses))) '=>)
+                                    (append2 (cdr (cdr (car clauses))) '(test))
+                                    (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
+                                (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
+                            (if (pair? (cdr clauses))
+                                (cons 'cond (cdr clauses)))))))
+              (car (car clauses)))))
+
+(define else #t)
+
 (define (procedure? p)
   (cond ((builtin? p) #t)
         ((and (pair? p) (eq? (car p) 'lambda)))

mes/module/mes/boot-0.scm.in

@@ -52,18 +52,12 @@
   (if (null? rest) (core:write x)
       (core:write-port x (car rest))))
 
-(define (list->string lst)
-  (core:make-cell <cell:string> lst 0))
-
 (define (integer->char x)
   (core:make-cell <cell:char> 0 x))
 
 (define (newline . rest)
   (core:display (list->string (list (integer->char 10)))))
 
-(define (string->list s)
-  (core:car s))
-
 (define (cadr x) (car (cdr x)))
 
 (define (map1 f lst)
@@ -107,7 +101,9 @@
   #t)
 ;; end boot-02.scm
 
-;; boot-0.scm
+;; boot-03.scm
+(define guile? #f)
+(define mes? #t)
 (define (primitive-eval e) (core:eval e (current-module)))
 (define eval core:eval)
 
@@ -125,24 +121,6 @@
   (if (null? t) (core:apply f h (current-module))
       (apply f (apply cons* (cons h t)))))
 
-(define-macro (cond . clauses)
-  (list 'if (pair? clauses)
-        (list (cons
-               'lambda
-               (cons
-                '(test)
-                (list (list 'if 'test
-                            (if (pair? (cdr (car clauses)))
-                                (if (eq? (car (cdr (car clauses))) '=>)
-                                    (append2 (cdr (cdr (car clauses))) '(test))
-                                    (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
-                                (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
-                            (if (pair? (cdr clauses))
-                                (cons 'cond (cdr clauses)))))))
-              (car (car clauses)))))
-
-(define else #t)
-
 (define-macro (load file)
   (list 'begin
         (list 'if (list 'and (list getenv "MES_DEBUG")
@@ -161,9 +139,6 @@
       (if (null? (cdr rest)) (car rest)
           (append2 (car rest) (apply append (cdr rest))))))
 
-(define (string->list s)
-  (core:car s))
-
 (define %prefix (getenv "MES_PREFIX"))
 (define %moduledir
   (if (not %prefix) "mes/module/"
@@ -173,16 +148,9 @@
 (include (list->string
           (append2 (string->list %moduledir) (string->list "mes/type-0.mes"))))
 
-(define (symbol->string s)
-  (apply string (symbol->list s)))
-
 (define (string-append . rest)
   (apply string (apply append (map1 string->list rest))))
 
-(define %version (if (eq? (car (string->list "@VERSION@")) #\@) "git"
-                     "@VERSION@"))
-(define (effective-version) %version)
-
 (if (and (getenv "MES_DEBUG")
           (not (equal2? (getenv "MES_DEBUG") "0"))
           (not (equal2? (getenv "MES_DEBUG") "1")))
@@ -205,6 +173,20 @@
 (mes-use-module (mes quasiquote))
 (mes-use-module (mes let))
 (mes-use-module (mes scm))
+
+(define-macro (define-module module . rest)
+  `(if ,(and (pair? module)
+             (= 1 (length module))
+             (symbol? (car module)))
+       (define (,(car module) . arguments) (main (command-line)))))
+
+(define-macro (use-modules . rest) #t)
+;; end boot-03.scm
+
+(define %version (if (eq? (car (string->list "@VERSION@")) #\@) "git"
+                     "@VERSION@"))
+(define (effective-version) %version)
+
 (mes-use-module (srfi srfi-1))
 (mes-use-module (srfi srfi-13))
 (mes-use-module (mes fluids))

mes/module/mes/boot-01.scm

@@ -42,18 +42,12 @@
   (if (null? rest) (core:write x)
       (core:write-port x (car rest))))
 
-(define (list->string lst)
-  (core:make-cell <cell:string> lst 0))
-
 (define (integer->char x)
   (core:make-cell <cell:char> 0 x))
 
 (define (newline . rest)
   (core:display (list->string (list (integer->char 10)))))
 
-(define (string->list s)
-  (core:car s))
-
 (define (cadr x) (car (cdr x)))
 
 (define (map1 f lst)

mes/module/mes/boot-02.scm

@@ -52,18 +52,12 @@
   (if (null? rest) (core:write x)
       (core:write-port x (car rest))))
 
-(define (list->string lst)
-  (core:make-cell <cell:string> lst 0))
-
 (define (integer->char x)
   (core:make-cell <cell:char> 0 x))
 
 (define (newline . rest)
   (core:display (list->string (list (integer->char 10)))))
 
-(define (string->list s)
-  (core:car s))
-
 (define (cadr x) (car (cdr x)))
 
 (define (map1 f lst)

mes/module/mes/boot-03.scm

@@ -0,0 +1,186 @@
+;;; -*-scheme-*-
+
+;;; GNU Mes --- Maxwell Equations of Software
+;;; Copyright © 2016,2017,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/>.
+
+;;; Commentary:
+
+;;; read-0.mes - bootstrap reader.  This file is read by a minimal
+;;; core reader.  It only supports s-exps and line-comments; quotes,
+;;; character literals, string literals cannot be used here.
+
+;;; Code:
+
+;; boot-00.scm
+(define mes %version)
+
+(define (defined? x)
+  (module-variable (current-module) x))
+
+(define (cond-expand-expander clauses)
+  (if (defined? (car (car clauses)))
+      (cdr (car clauses))
+      (cond-expand-expander (cdr clauses))))
+
+(define-macro (cond-expand . clauses)
+  (cons 'begin (cond-expand-expander clauses)))
+;; end boot-00.scm
+
+;; boot-01.scm
+(define (not x) (if x #f #t))
+
+(define (display x . rest)
+  (if (null? rest) (core:display x)
+      (core:display-port x (car rest))))
+
+(define (write x . rest)
+  (if (null? rest) (core:write x)
+      (core:write-port x (car rest))))
+
+(define (integer->char x)
+  (core:make-cell <cell:char> 0 x))
+
+(define (newline . rest)
+  (core:display (list->string (list (integer->char 10)))))
+
+(define (cadr x) (car (cdr x)))
+
+(define (map1 f lst)
+  (if (null? lst) (list)
+      (cons (f (car lst)) (map1 f (cdr lst)))))
+
+(define (map f lst)
+  (if (null? lst) (list)
+      (cons (f (car lst)) (map f (cdr lst)))))
+
+(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))))))
+;; end boot-01.scm
+
+;; boot-02.scm
+(define-macro (and . x)
+  (if (null? x) #t
+      (if (null? (cdr x)) (car x)
+          (list (quote if) (car x) (cons (quote and) (cdr x))
+                #f))))
+
+(define-macro (or . x)
+  (if (null? x) #f
+      (if (null? (cdr x)) (car x)
+          (list (list (quote lambda) (list (quote r))
+                      (list (quote if) (quote r) (quote r)
+                            (cons (quote or) (cdr x))))
+                (car x)))))
+
+(define-macro (mes-use-module module)
+  #t)
+;; end boot-02.scm
+
+;; boot-03.scm
+(define guile? #f)
+(define mes? #t)
+(define (primitive-eval e) (core:eval e (current-module)))
+(define eval core:eval)
+
+(define (port-filename port) "<stdin>")
+(define (port-line port) 0)
+(define (port-column port) 0)
+(define (ftell port) 0)
+(define (false-if-exception x) x)
+
+(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-macro (load file)
+  (list 'begin
+        (list 'if (list 'and (list getenv "MES_DEBUG")
+                        (list not (list equal2? (list getenv "MES_DEBUG") "0"))
+                        (list not (list equal2? (list getenv "MES_DEBUG") "1")))
+              (list 'begin
+                    (list core:display-error ";;; read ")
+                    (list core:display-error file)
+                    (list core:display-error "\n")))
+     (list 'primitive-load file)))
+
+(define-macro (include file) (list 'load file))
+
+(define (append . rest)
+  (if (null? rest) '()
+      (if (null? (cdr rest)) (car rest)
+          (append2 (car rest) (apply append (cdr rest))))))
+
+(define %prefix (getenv "MES_PREFIX"))
+(define %moduledir
+  (if (not %prefix) "boe /share/mes/module/"
+      (list->string
+       (append (string->list %prefix) (string->list "/module/" )))))
+
+(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")))
+    (begin
+      (core:display-error ";;; %moduledir=")
+      (core:display-error %moduledir)
+      (core:display-error "\n")))
+
+(define-macro (include-from-path file)
+  (list 'load (list string-append %moduledir file)))
+
+(define (string-join lst infix)
+  (if (null? lst) ""
+      (if (null? (cdr lst)) (car lst)
+          (string-append (car lst) infix (string-join (cdr lst) infix)))))
+
+(include-from-path "mes/module.mes")
+
+(mes-use-module (mes base))
+(mes-use-module (mes quasiquote))
+(mes-use-module (mes let))
+(mes-use-module (mes scm))
+
+(define-macro (define-module module . rest)
+  `(if ,(and (pair? module)
+             (= 1 (length module))
+             (symbol? (car module)))
+       (define (,(car module) . arguments) (main (command-line)))))
+
+(define-macro (use-modules . rest) #t)
+;; end boot-03.scm
+(primitive-load 0)
+(primitive-load 0)

mes/module/mes/display.mes

@@ -50,31 +50,33 @@
          (write? (and (pair? rest) (pair? (cdr rest)) (cadr rest))))
 
     (define (display-char x port write?)
-      (cond ((and write? (or (eq? x #\") (eq? x #\\)))
+      (if write?
+          (cond ((or (eq? x #\") (eq? x #\\))
                  (write-char #\\ port)
                  (write-char x port))
-            ((and write? (eq? x #\nul))
+                ((eq? x #\nul)
                  (write-char #\\ port)
                  (write-char #\0 port))
-            ((and write? (eq? x #\alarm))
+                ((eq? x #\alarm)
                  (write-char #\\ port)
                  (write-char #\a port))
-            ((and write? (eq? x #\backspace))
+                ((eq? x #\backspace)
                  (write-char #\\ port)
                  (write-char #\b port))
-            ((and write? (eq? x #\tab))
+                ((eq? x #\tab)
                  (write-char #\\ port)
                  (write-char #\t port))
-            ((and write? (eq? x #\newline))
+                ((eq? x #\newline)
                  (write-char #\\ port)
                  (write-char #\n port))
-            ((and write? (eq? x #\vtab))
+                ((eq? x #\vtab)
                  (write-char #\\ port)
                  (write-char #\v port))
-            ((and write? (eq? x #\page))
+                ((eq? x #\page)
                  (write-char #\\ port)
                  (write-char #\f port))
-            (#t (write-char x port))))
+                (#t (write-char x port)))
+          (write-char x port)))
 
     (define (d x cont? sep)
       (for-each (display-cut write-char <> port) (string->list sep))
@@ -94,7 +96,10 @@
                                          (#\space . space)))
                                cdr)))
               (write-char #\# port)
-              (write-char #\\ port)
+              (when (or name
+                        (and (>= (char->integer 32))
+                             (<= (char->integer 127))))
+                (write-char #\\ port))
               (if name (display name port)
                   (write-char x port)))))
        ((closure? x)
@@ -163,7 +168,7 @@
         (display ")" port))
        ((function? x)
         (display "#<procedure " port)
-        (display (core:car x) port)
+        (display (core:procedure-name x) port)
         (display " " port)
         (display
          (case (core:arity x)

mes/module/mes/scm.mes

@@ -284,7 +284,7 @@
 
 ;;; Keywords
 (define (keyword->symbol s)
-  (list->symbol (keyword->list s)))
+  (string->symbol (keyword->string s)))
 
 
 ;;; Characters

mes/module/mes/type-0.mes

@@ -26,7 +26,8 @@
 ;;; Code:
 
 (define cell:type-alist
-  (list (cons <cell:char> (quote <cell:char>))
+  (list (cons <cell:bytes> (quote <cell:bytes>))
+        (cons <cell:char> (quote <cell:char>))
         (cons <cell:closure> (quote <cell:closure>))
         (cons <cell:continuation> (quote <cell:continuation>))
         (cons <cell:function> (quote <cell:function>))
@@ -47,6 +48,9 @@
 (define (cell:type-name x)
   (cond ((assq (core:type x) cell:type-alist) => cdr)))
 
+(define (bytes? x)
+  (eq? (core:type x) <cell:bytes>))
+
 (define (char? x)
   (and (eq? (core:type x) <cell:char>)
        (> (char->integer x) -1)))
@@ -102,10 +106,8 @@
 (define (vector? x)
   (eq? (core:type x) <cell:vector>))
 
-;; Non-types
+(define (broken-heart? x)
-;; In core
+  (eq? (core:type x) <cell:broken-heart>))
-;; (define (null? x)
-;;   (eq? x '()))
 
 (define (atom? x)
   (not (pair? x)))
@@ -116,20 +118,13 @@
 
 ;;; core: accessors
 (define (string . lst)
-  (core:make-cell <cell:string> lst 0))
+  (list->string lst))
-
-(define (string->symbol s)
-  (if (not (pair? (core:car s))) '()
-      (list->symbol (core:car s))))
-
-(define (symbol->keyword s)
-  (core:make-cell <cell:keyword> (symbol->list s) 0))
-
-(define (symbol->list s)
-  (core:car s))
 
 (define (keyword->list s)
-  (core:car s))
+  (string->list (keyword->string s)))
+
+(define (symbol->list s)
+  (string->list (symbol->string s)))
 
 (define (integer->char x)
   (core:make-cell <cell:char> 0 x))

mes/module/srfi/srfi-13.mes

@@ -41,10 +41,6 @@
 (define (string-copy s)
   (list->string (string->list s)))
 
-(define (string=? a b)
-    (eq? (string->symbol a)
-         (string->symbol b)))
-
 (define (string= a b . rest)
   (let* ((start1 (and (pair? rest) (car rest)))
          (end1 (and start1 (pair? (cdr rest)) (cadr rest)))

module/mes/getopt-long.scm

@@ -1,24 +1,19 @@
-;;; GNU Mes --- Maxwell Equations of Software
 ;;; Copyright (C) 1998, 2001, 2006 Free Software Foundation, Inc.
 ;;; Copyright (C) 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
-;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
-;;; This file is part of GNU Mes.
+;; This library is free software; you can redistribute it and/or
-;;;
+;; modify it under the terms of the GNU Lesser General Public
-;;; GNU Mes is free software; you can redistribute it and/or modify it
+;; License as published by the Free Software Foundation; either
-;;; under the terms of the GNU General Public License as published by
+;; version 2.1 of the License, or (at your option) any later version.
-;;; the Free Software Foundation; either version 3 of the License, or (at
+;;
-;;; your option) any later version.
+;; This library is distributed in the hope that it will be useful,
-;;;
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; GNU Mes is distributed in the hope that it will be useful, but
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; Lesser General Public License for more details.
-;;; 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 Lesser General Public
-;;;
+;; License along with this library; if not, write to the Free Software
-;;; You should have received a copy of the GNU General Public License
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;;; From Guile-1.8
 
 ;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
 ;;;                      (regexps removed by Jan (janneke) Nieuwenhuizen)

module/mes/guile.scm

@@ -45,6 +45,7 @@
             core:write-error
             core:write-port
             core:type
+            equal2?
             pmatch-car
             pmatch-cdr
             )
@@ -66,6 +67,7 @@
   (define (core:apply f a . m) (apply f a))
   (define (core:car f a . m) (apply f a))
   (define append2 append)
+  (define equal2? equal?)
 
   (define guile:keyword? keyword?)
   (define guile:number? number?)

module/mes/misc.scm

@@ -53,10 +53,11 @@
   (car (last-pair stuff)))
 
 (define (pke . stuff)
+  (display "\n" (current-error-port))
   (newline (current-error-port))
   (display ";;; " (current-error-port))
   (write stuff (current-error-port))
-  (newline (current-error-port))
+  (display "\n" (current-error-port))
   (car (last-pair stuff)))
 
 (define warn pke)

module/mes/optargs.scm

@@ -57,7 +57,7 @@
 
 ;;; Code:
 
-(define-module (ice-9 optargs)
+(define-module (mes optargs)
   #:use-module (system base pmatch)
   #:replace (lambda*)
   #:export-syntax (let-optional
@@ -151,14 +151,13 @@
 				 => cdr)
 				(else
 				 ,(cadr key)))))))
-	  `(let ((,kb-list-gensym (;;(@@ (ice-9 optargs) rest-arg->keyword-binding-list)
+	  `(let ((,kb-list-gensym ((if (not mes?) (@@ (mes optargs) rest-arg->keyword-binding-list)
-                                   rest-arg->keyword-binding-list
+                                       rest-arg->keyword-binding-list)
                                    ,REST-ARG ',(map (lambda (x) (symbol->keyword (if (pair? x) (car x) x)))
                                                     BINDINGS)
                                    ,ALLOW-OTHER-KEYS?)))
 	     ,(let-o-k-template REST-ARG BINDINGS BODY let-type bindfilter)))))
 
-
 (define (rest-arg->keyword-binding-list rest-arg keywords allow-other-keys?)
   (if (null? rest-arg)
       '()

module/mescc/M1.scm

@@ -111,6 +111,7 @@
             (if (equal? o "%0") o       ; FIXME: 64b
                 (error "no such string:" o)))))
     (define (text->M1 o)
+      ;;
       (cond
        ((char? o) (text->M1 (char->integer o)))
        ((string? o) o)
@@ -166,7 +167,8 @@
           ((#:immediate4 ,immediate4) (hex2:immediate4 immediate4))
           ((#:immediate8 ,immediate8) (hex2:immediate8 immediate8))
           (_ (error "text->M1 no match o" o))))
-       ((pair? o) (string-join (map text->M1 o)))))
+       ((pair? o) (string-join (map text->M1 o)))
+       (#t (error "no such text:" o))))
     (define (write-function o)
       (let ((name (car o))
             (text (function:text (cdr o))))

module/mescc/compile.scm

@@ -910,8 +910,7 @@
         ((p-expr (fixed ,value))
          (let* ((value (cstring->int value))
                 (info (allocate-register info))
-                (info (append-text info (append (wrap-as (as info 'value->r value)))))
+                (info (append-text info (wrap-as (as info 'value->r value)))))
-                (reg-size (->size "*" info)))
            (if (or #t (> value 0) (= reg-size 4)) info
                (append-text info (wrap-as (as info 'long-signed-r))))))
 

scaffold/boot/17-equal2.scm

@@ -0,0 +1,25 @@
+;;; 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/>.
+
+(core:write (if (equal2? "" "") #t (exit 1)))
+(core:write "\n")
+(core:write (if (equal2? '("foo" "") '("foo" "")) #t (exit 1)))
+(core:write "\n")
+(core:write (if (equal2? '("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "") '("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "")) #t (exit 1)))
+(core:write "\n")
+(exit 0)

scaffold/boot/17-memq-keyword.scm

@@ -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 (memq '#:bar '(foo #:bar baz))
+    (exit 0))
+(exit 1)

scaffold/boot/17-memq.scm

@@ -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 (memq 'bar '(foo bar baz))
+    (exit 0))
+(exit 1)

scaffold/boot/17-open-input-string.scm

@@ -0,0 +1,36 @@
+;;; 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/>.
+
+((lambda (port)
+   (core:display-error "port:")
+   (core:write-error port)
+   (core:display-error "\n")
+   (set-current-input-port port)
+   (core:display-error "current:")
+   (core:write-error (current-input-port))
+   (core:display-error "\n")
+   (core:display-error "read:")
+   ((lambda (string)
+      (core:write-error string)
+      (core:display-error "\n")
+      (core:display-error "empty:")
+      (core:write-error port)
+      (core:display-error "\n")
+      (exit (if (equal2? string "foo bar\n") 0 1)))
+    ((if (pair? (current-module)) read-string (@ (ice-9 rdelim) read-string)) port)))
+ (open-input-string "foo bar\n"))

scaffold/boot/17-string-equal.scm

@@ -0,0 +1,23 @@
+;;; 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/>.
+
+(core:write (if (string=? "" "") #t (exit 1)))
+(core:write (if (string=? "foo" "foo") #t (exit 1)))
+(core:write (if (string=? "" "foo") (exit 1)))
+(core:write "\n")
+(exit 0)

scaffold/boot/4f-string-split.scm

@@ -91,12 +91,6 @@
 ;;   (if (= 0 n) '()
 ;;       (foo (car x) (ss-list-head (cdr x) (- n 1)))))
 
-(define (string->list s)
-  (core:car s))
-
-(define (list->string lst)
-  (core:make-cell <cell:string> lst 0))
-
 (define (not x) (if x #f #t))
 
 (define (string-split s c)

scaffold/boot/50-keyword.scm

@@ -0,0 +1,23 @@
+;;; 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/>.
+
+(core:display-error "symbol->keyword\n")
+(core:write (symbol->keyword 'foo))
+(core:display-error "\n")
+(core:write (keyword->string #:bar))
+(core:display-error "dun\n")

scaffold/boot/50-make-string.scm

@@ -0,0 +1,59 @@
+;;; 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))))))
+
+(define (make-list n . fill)
+  fill)
+
+(define (make-string n . fill)
+  (list->string (apply make-list n fill)))
+
+;;(make-string 1 (option-spec->single-char spec))
+(core:write-error (make-string 1 #\a))
+;;(core:write-error (list->string '(#\a #\b #\c)))
+
+;; (if (string=? (string-append "foo" "/" "bar") "foo/bar")
+;;     (exit 0))
+;; (exit 1)

scaffold/boot/50-string-append.scm

@@ -0,0 +1,49 @@
+;;; 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)

scaffold/boot/50-string-join.scm

@@ -0,0 +1,53 @@
+;;; 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))))))
+
+  (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))
+(exit 1)

scaffold/boot/51-module.scm

@@ -42,11 +42,8 @@
             (list (quote if) (car x) (cons (quote and) (cdr x))
                   #f))))
 
-  (define (string->list s)
-    (core:car s))
-
   (define (string . lst)
-    (core:make-cell <cell:string> lst 0))
+    (list->string lst))
 
   (define (string-append . rest)
     (apply string (apply append (map string->list rest))))
@@ -60,9 +57,6 @@
 
   (define map map1)
 
-  (define (list->string lst)
-    (core:make-cell <cell:string> lst 0))
-
   (define %moduledir
     (if (not %prefix ) "mes/module/"
         (list->string
@@ -80,24 +74,11 @@
   (define-macro (include-from-path file)
     (list 'load (list string-append %moduledir file)))
 
-  (define (string->symbol s)
-    (list->symbol (core:car s)))
-
-  (define (symbol->list s)
-    (core:car s))
-
-  (define (string . lst)
-    (core:make-cell <cell:string> lst 0))
-
-  (define (symbol->string s)
-    (apply string (symbol->list s)))
-
   (define (getcwd) ".")
 
   (define (display x . rest)
     (if (null? rest) (core:display x)
-        (core:display-port x (car rest))))
+        (core:display-port x (car rest))))))
-  ))
 
 (define (memq x lst)
   (if (null? lst) #f

scaffold/boot/52-define-module.scm

@@ -40,11 +40,8 @@
             (list (quote if) (car x) (cons (quote and) (cdr x))
                   #f))))
 
-  (define (string->list s)
-    (core:car s))
-
   (define (string . lst)
-    (core:make-cell <cell:string> lst 0))
+    (list->string lst))
 
   (define (map1 f lst)
     (if (null? lst) (list)
@@ -54,23 +51,13 @@
 
   (define (string-append . rest)
     (apply string (apply append (map string->list rest))))
-;;;;;;;;;;;;;;;;;;
 
 ;;;;;;;;;;;;;;;;;;
-  (define (symbol->list s)
-    (core:car s))
-
-  (define (symbol->string s)
-    (apply string (symbol->list s)))
-
   (define (string-join lst infix)
     (if (null? (cdr lst)) (car lst)
         (string-append (car lst) infix (string-join (cdr lst) infix))))
 ;;;;;;;;;;;;;;;;;;
 
-  (define (string->symbol s)
-    (list->symbol (core:car s)))
-
   (define-macro (load file)
     (list 'primitive-load file))
 
@@ -83,5 +70,11 @@
   ))
 
 (define %moduledir "./")
+(core:display-error "reading...\n")
 (primitive-load "mes/module/mes/module.mes")
+(core:display-error "dun\n")
+(core:write-error (map symbol->string '(scaffold boot data bar)))
+(core:display-error "\n")
+(core:write-error (string-join (map symbol->string '(scaffold boot data bar)) "/"))
+(core:display-error "\n")
 (mes-use-module (scaffold boot data bar))

scaffold/boot/60-let-syntax-expanded.scm

@@ -46,9 +46,6 @@
   (if (null? rest) (core:write x)
       (core:write-port x (car rest))))
 
-(define (list->string lst)
-  (core:make-cell <cell:string> lst 0))
-
 (define (integer->char x)
   (core:make-cell <cell:character> 0 x))
 
@@ -142,10 +139,6 @@
   (define (symbol? x)
     (eq? (core:type x) <cell:symbol>))
 
-  (define (string->symbol s)
-    (if (not (pair? (core:car s))) '()
-        (list->symbol (core:car s))))
-
   (define <cell:string> 10)
   (define (string? x)
     (eq? (core:type x) <cell:string>))
@@ -232,7 +225,7 @@
           (and (equal2? (car a) (car b))
                (equal2? (cdr a) (cdr b)))
           (if (and (string? a) (string? b))
-              (eq? (string->symbol a) (string->symbol b))
+              (string=? a b)
               (if (and (vector? a) (vector? b))
                   (equal2? (vector->list a) (vector->list b))
                   (eq? a b))))))

scaffold/boot/60-let-syntax.scm

@@ -55,10 +55,6 @@
   (define (symbol? x)
     (eq? (core:type x) <cell:symbol>))
 
-  (define (string->symbol s)
-    (if (not (pair? (core:car s))) '()
-        (list->symbol (core:car s))))
-
   (define (string? x)
     (eq? (core:type x) <cell:string>))
 

scaffold/mini-mes.c

@@ -218,7 +218,7 @@ struct scm scm_symbol_arch = {TSYMBOL, "%arch",0};
 
 struct scm scm_test = {TSYMBOL, "test",0};
 
-#include "mes.mes.symbols.h"
+#include "src/mes.mes.symbols.h"
 
 SCM tmp;
 SCM tmp_num;
@@ -227,19 +227,19 @@ SCM tmp_num2;
 struct function g_functions[200];
 int g_function = 0;
 
-#include "gc.mes.h"
+#include "src/gc.mes.h"
-#include "lib.mes.h"
+#include "src/lib.mes.h"
 #if !MES_MINI
-#include "math.mes.h"
+#include "src/math.mes.h"
 #endif
-#include "mes.mes.h"
+#include "src/mes.mes.h"
 
 SCM gc_init_news ();
 
 // #if !MES_MINI
-// #include "posix.mes.h"
+// #include "src/posix.mes.h"
 // #ndif
-//#include "vector.mes.h"
+//#include "src/vector.mes.h"
 
 #define TYPE(x) g_cells[x].type
 #define CAR(x) g_cells[x].car
@@ -273,7 +273,7 @@ SCM gc_init_news ();
 #define MAKE_CONTINUATION(n) make_cell_ (tmp_num_ (TCONTINUATION), n, g_stack)
 #define MAKE_NUMBER(n) make_cell_ (tmp_num_ (TNUMBER), 0, tmp_num2_ (n))
 #define MAKE_REF(n) make_cell_ (tmp_num_ (TREF), n, 0)
-#define MAKE_STRING(x) make_cell_ (tmp_num_ (TSTRING), x, 0)
+#define MAKE_STRING0(x) make_string (x, strlen (x))
 
 #define CAAR(x) CAR (CAR (x))
 #define CADR(x) CAR (CDR (x))
@@ -809,10 +809,11 @@ make_tmps (struct scm* cells)
 }
 
 #if !MES_MINI
-#include "posix.c"
+#include "src/posix.c"
-#include "math.c"
+#include "src/math.c"
 #endif
-#include "lib.c"
+#include "src/lib.c"
+#include "src/strings.c"
 
 SCM frame_printer (SCM frame)
 {
@@ -861,7 +862,7 @@ mes_symbols () ///((internal))
   gc_init_cells ();
   gc_init_news ();
 
-#include "mes.mes.symbols.i"
+#include "src/mes.mes.symbols.i"
 
   g_symbol_max = g_free;
   make_tmps (g_cells);
@@ -872,7 +873,7 @@ mes_symbols () ///((internal))
 
   SCM a = cell_nil;
 
-#include "mes.mes.symbol-names.i"
+#include "src/mes.mes.symbol-names.i"
 
   a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
   a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
@@ -913,33 +914,35 @@ mes_environment () ///((internal))
 SCM
 mes_builtins (SCM a) ///((internal))
 {
-#include "mes.mes.i"
+#include "src/mes.mes.i"
 
 // Do not sort: Order of these includes define builtins
 #if !MES_MINI
-#include "posix.mes.i"
+#include "src/posix.mes.i"
-#include "math.mes.i"
+#include "src/math.mes.i"
 #endif
-#include "lib.mes.i"
+#include "src/lib.mes.i"
 #if !MES_MINI
-#include "vector.mes.i"
+#include "src/vector.mes.i"
 #endif
-#include "gc.mes.i"
+#include "src/gc.mes.i"
 #if !MES_MINI
-  //#include "reader.mes.i"
+  //#include "src/reader.mes.i"
 #endif
+#include "src/strings.mes.i"
 
-#include "gc.mes.environment.i"
+#include "src/gc.mes.environment.i"
-#include "lib.mes.environment.i"
+#include "src/lib.mes.environment.i"
 #if !MES_MINI
-#include "math.mes.environment.i"
+#include "src/math.mes.environment.i"
 #endif
-#include "mes.mes.environment.i"
+#include "src/mes.mes.environment.i"
 #if !MES_MINI
-#include "posix.mes.environment.i"
+#include "src/posix.mes.environment.i"
-  //#include "reader.mes.environment.i"
+  //#include "src/reader.mes.environment.i"
-#include "vector.mes.environment.i"
+#include "src/vector.mes.environment.i"
 #endif
+#include "src/strings.mes.i"
 
   return a;
 }
@@ -1012,9 +1015,9 @@ bload_env (SCM a) ///((internal))
 }
 
 #if !MES_MINI
-#include "vector.c"
+#include "src/vector.c"
 #endif
-#include "gc.c"
+#include "src/gc.c"
 
 int
 main (int argc, char *argv[])

scripts/mescc.in

@@ -5,6 +5,10 @@ if [ "$V" = 2 ]; then
 fi
 prefix=${prefix-@prefix@}
 program_prefix=${program_prefix-@program_prefix@}
+MES_ARENA=${MES_ARENA-100000000}
+export MES_ARENA
+MES_STACK=${MES_STACK-500000}
+export MES_STACK
 MES_PREFIX=${MES_PREFIX-$prefix/share/mes}
 export MES_PREFIX
 mes_p=$(command -v mes)

src/gc.c

@@ -20,6 +20,8 @@
 
 #include <errno.h>
 
+size_t bytes_cells (size_t length);
+
 SCM
 gc_up_arena () ///((internal))
 {
@@ -79,6 +81,22 @@ gc_copy (SCM old) ///((internal))
       for (long i=0; i<LENGTH (old); i++)
         g_news[g_free++] = g_cells[VECTOR (old)+i];
     }
+  else if (NTYPE (new) == TBYTES)
+    {
+      char const *src = CBYTES (old);
+      char *dest = NCBYTES (new);
+      size_t length = NLENGTH (new);
+      memcpy (dest, src, length + 1);
+      g_free += bytes_cells (length) - 1;
+
+      if (g_debug > 4)
+        {
+          eputs ("gc copy bytes: "); eputs (src); eputs ("\n");
+          eputs ("    length: "); eputs (itoa (LENGTH (old))); eputs ("\n");
+          eputs ("    nlength: "); eputs (itoa (NLENGTH (new))); eputs ("\n");
+          eputs ("        ==> "); eputs (dest); eputs ("\n");
+        }
+    }
   TYPE (old) = TBROKEN_HEART;
   CAR (old) = new;
   return new;
@@ -107,16 +125,10 @@ gc_loop (SCM scan) ///((internal))
     {
       if (NTYPE (scan) == TBROKEN_HEART)
         error (cell_symbol_system_error,  cell_gc);
-      if (NTYPE (scan) == TFUNCTION
+      if (NTYPE (scan) == TMACRO
-          || NTYPE (scan) == TKEYWORD
-          || NTYPE (scan) == TMACRO
           || NTYPE (scan) == TPAIR
-          || NTYPE (scan) == TPORT
           || NTYPE (scan) == TREF
           || scan == 1 // null
-          || NTYPE (scan) == TSPECIAL
-          || NTYPE (scan) == TSTRING
-          || NTYPE (scan) == TSYMBOL
           || NTYPE (scan) == TVARIABLE)
         {
           car = gc_copy (g_news[scan].car);
@@ -124,14 +136,23 @@ gc_loop (SCM scan) ///((internal))
         }
       if ((NTYPE (scan) == TCLOSURE
            || NTYPE (scan) == TCONTINUATION
+           || NTYPE (scan) == TFUNCTION
+           || NTYPE (scan) == TKEYWORD
            || NTYPE (scan) == TMACRO
            || NTYPE (scan) == TPAIR
+           || NTYPE (scan) == TPORT
+           || NTYPE (scan) == TSPECIAL
+           || NTYPE (scan) == TSTRING
+           || NTYPE (scan) == TSYMBOL
+           || scan == 1 // null
            || NTYPE (scan) == TVALUES)
           && g_news[scan].cdr) // allow for 0 terminated list of symbols
         {
           cdr = gc_copy (g_news[scan].cdr);
           gc_relocate_cdr (scan, cdr);
         }
+      if (NTYPE (scan) == TBYTES)
+        scan += bytes_cells (NLENGTH (scan)) - 1;
       scan++;
     }
   gc_flip ();

src/hash.c

@@ -23,11 +23,11 @@ SCM vector_ref_ (SCM x, long i);
 SCM vector_set_x_ (SCM x, long i, SCM e);
 
 int
-hash_list_of_char (SCM lst, long size)
+hash_cstring (char const* s, long size)
 {
-  int hash = VALUE (CAR (lst)) * 37;
+  int hash = s[0] * 37;
-  if (TYPE (CDR (lst)) == TPAIR && TYPE (CADR (lst)) == TCHAR)
+  if (s[0] && s[1])
-    hash = hash + VALUE (CADR (lst)) * 43;
+    hash = hash + s[1] * 43;
   assert (size);
   hash = hash % size;
   return hash;
@@ -38,15 +38,15 @@ hashq_ (SCM x, long size)
 {
   if (TYPE (x) == TSPECIAL
       || TYPE (x) == TSYMBOL)
-    return hash_list_of_char (STRING (x), size);  // FIXME: hash x directly
+    return hash_cstring (CSTRING (x), size);  // FIXME: hash x directly
-  error (cell_symbol_system_error, cons (MAKE_STRING (cstring_to_list ("hashq_: not a symbol")), x));
+  error (cell_symbol_system_error, cons (MAKE_STRING0 ("hashq_: not a symbol"), x));
 }
 
 int
 hash_ (SCM x, long size)
 {
   if (TYPE (x) == TSTRING)
-    return hash_list_of_char (STRING (x), size);
+    return hash_cstring (CSTRING (x), size);
   assert (0);
   return hashq_ (x, size);
 }

src/lib.c

@@ -36,20 +36,25 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
         fdputc (VALUE (x), fd);
       else
         {
-          fdputs ("#\\", fd);
+          fdputs ("#", fd);
           long v = VALUE (x);
-          if (v == '\0') fdputs ("nul", fd);
+          if (v == '\0') fdputs ("\\nul", fd);
-          else if (v == '\a') fdputs ("alarm", fd);
+          else if (v == '\a') fdputs ("\\alarm", fd);
-          else if (v == '\b') fdputs ("backspace", fd);
+          else if (v == '\b') fdputs ("\\backspace", fd);
-          else if (v == '\t') fdputs ("tab", fd);
+          else if (v == '\t') fdputs ("\\tab", fd);
-          else if (v == '\n') fdputs ("newline", fd);
+          else if (v == '\n') fdputs ("\\newline", fd);
-          else if (v == '\v') fdputs ("vtab", fd);
+          else if (v == '\v') fdputs ("\\vtab", fd);
-          else if (v == '\f') fdputs ("page", fd);
+          else if (v == '\f') fdputs ("\\page", fd);
           //Nyacc bug
           // else if (v == '\r') fdputs ("return", fd);
-            else if (v == 13) fdputs ("return", fd);
+          else if (v == 13) fdputs ("\\return", fd);
-          else if (v == ' ') fdputs ("space", fd);
+          else if (v == ' ') fdputs ("\\space", fd);
-          else fdputc (VALUE (x), fd);
+          else
+            {
+              if (v >= 32 && v <= 127)
+                fdputc ('\\', fd);
+              fdputc (VALUE (x), fd);
+            }
         }
     }
   else if (t == TCLOSURE)
@@ -131,20 +136,27 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
            || t == TSTRING
            || t == TSYMBOL)
     {
-      if (TYPE (x) == TPORT)
+      if (t == TPORT)
         {
           fdputs ("#<port ", fd);
           fdputs (itoa (PORT (x)), fd);
           fdputs (" " ,fd);
+          x = STRING (x);
         }
-      if (TYPE (x) == TKEYWORD)
+      if (t == TKEYWORD)
         fdputs ("#:", fd);
-      if ((write_p && TYPE (x) == TSTRING) || TYPE (x) == TPORT)
+      if ((write_p && t == TSTRING) || t == TPORT)
         fdputc ('"', fd);
-      SCM t = CAR (x);
+      char const *s = CSTRING (x);
-      while (t && t != cell_nil)
+#if 0
+      s += START (x);
+      size_t length = LEN (x);
+#else
+      size_t length = LENGTH (x);
+#endif
+      for (size_t i=0; i < length; i++)
         {
-          long v = write_p ? VALUE (CAR (t)) : -1;
+          long v = write_p ? s[i] : -1;
           if (v == '\0') fdputs ("\\0", fd);
           else if (v == '\a') fdputs ("\\a", fd);
           else if (v == '\b') fdputs ("\\b", fd);
@@ -163,12 +175,11 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
 #endif
           else if (v == '\\') fdputs ("\\\\", fd);
           else if (v == '"') fdputs ("\\\"", fd);
-          else fdputc (VALUE (CAR (t)), fd);
+          else fdputc (s[i], fd);
-          t = CDR (t);
         }
-      if ((write_p && TYPE (x) == TSTRING) || TYPE (x) == TPORT)
+      if ((write_p && t == TSTRING) || t == TPORT)
         fdputc ('"', fd);
-      if (TYPE (x) == TPORT)
+      if (t == TPORT)
         fdputs (">", fd);
     }
   else if (t == TREF)
@@ -178,7 +189,8 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
       SCM printer = STRUCT (x) + 1;
       if (TYPE (printer) == TREF)
         printer = REF (printer);
-      if (printer != cell_unspecified)
+      if (TYPE (printer) == TCLOSURE
+          || TYPE (printer) == TFUNCTION)
         apply (printer, cons (x, cell_nil), r0);
       else
         {
@@ -209,7 +221,7 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
   else
     {
       fdputs ("<", fd);
-      fdputs (itoa (TYPE (x)), fd);
+      fdputs (itoa (t), fd);
       fdputs (":", fd);
       fdputs (itoa (x), fd);
       fdputs (">", fd);
@@ -217,6 +229,16 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
   return 0;
 }
 
+SCM
+procedure_name_ (SCM x)
+{
+  assert (TYPE (x) == TFUNCTION);
+  char const *p = "?";
+  if (FUNCTION (x).name != 0)
+    p = FUNCTION (x).name;
+  return MAKE_STRING0 (p);
+}
+
 SCM
 display_ (SCM x)
 {
@@ -273,7 +295,6 @@ exit_ (SCM x) ///((name . "exit"))
   exit (VALUE (x));
 }
 
-#if !MES_MINI
 SCM
 frame_printer (SCM frame)
 {
@@ -349,7 +370,6 @@ stack_ref (SCM stack, SCM index)
   SCM frames = struct_ref_ (stack, 3);
   return vector_ref (frames, index);
 }
-#endif // !MES_MINI
 
 SCM
 xassq (SCM x, SCM a) ///for speed in core only
@@ -372,8 +392,9 @@ memq (SCM x, SCM a)
       }
     else if (t == TKEYWORD)
       {
-        SCM v = STRING (x);
+        while (a != cell_nil
-        while (a != cell_nil && v != STRING (CAR (a)))
+               && (TYPE (CAR (a)) != TKEYWORD
+                   || string_equal_p (x, CAR (a)) == cell_f))
           a = CDR (a);
       }
     else
@@ -399,11 +420,7 @@ equal2_p (SCM a, SCM b)
       return cell_f;
     }
   if (TYPE (a) == TSTRING && TYPE (b) == TSTRING)
-    {
+    return string_equal_p (a, b);
-      a = STRING (a);
-      b = STRING (b);
-      goto equal2;
-    }
   if (TYPE (a) == TVECTOR && TYPE (b) == TVECTOR)
     {
       if (LENGTH (a) != LENGTH (b))

src/module.c

@@ -20,6 +20,7 @@
 
 SCM struct_ref_ (SCM x, long i);
 SCM struct_set_x_ (SCM x, long i, SCM e);
+SCM cstring_to_symbol (char const *s);
 
 SCM
 make_module_type () ///(internal))
@@ -101,7 +102,7 @@ module_variable (SCM module, SCM name)
 SCM
 module_ref (SCM module, SCM name)
 {
-  if (g_debug > 4)
+  if (g_debug > 3)
     {
       eputs ("module_ref: "); display_error_ (name); eputs ("\n");
     }

src/posix.c

@@ -40,7 +40,12 @@ peekchar ()
       return c;
     }
   SCM port = current_input_port ();
-  return VALUE (CAR (STRING (port)));
+  SCM string = STRING (port);
+  size_t length = LENGTH (string);
+  if (!length)
+    return -1;
+  char const *p = CSTRING (string);
+  return p[0];
 }
 
 int
@@ -50,10 +55,12 @@ readchar ()
     return fdgetc (g_stdin);
   SCM port = current_input_port ();
   SCM string = STRING (port);
-  if (string == cell_nil)
+  size_t length = LENGTH (string);
+  if (!length)
     return -1;
-  int c = VALUE (CAR (string));
+  char const *p = CSTRING (string);
-  STRING (port) = CDR (string);
+  int c = *p++;
+  STRING (port) = make_string (p, length-1);
   return c;
 }
 
@@ -63,7 +70,14 @@ unreadchar (int c)
   if (g_stdin >= 0)
     return fdungetc (c, g_stdin);
   SCM port = current_input_port ();
-  STRING (port) = cons (MAKE_CHAR (c), STRING (port));
+  SCM string = STRING (port);
+  size_t length = LENGTH (string);
+  char *p = CSTRING (string);
+  p--;
+  string = make_string (p, length+1);
+  p = CSTRING (string);
+  p[0] = c;
+  STRING (port) = string;
   return c;
 }
 
@@ -117,27 +131,6 @@ write_char (SCM i) ///((arity . n))
   return i;
 }
 
-SCM
-read_string (SCM port) ///((arity . n))
-{
-  int fd = g_stdin;
-  if (TYPE (port) == TPAIR && TYPE (car (port)) == TNUMBER)
-    g_stdin = VALUE (CAR (port));
-  gc_push_frame ();
-  r0 = cell_nil;
-  r1 = read_char (cell_nil);
-  while (VALUE (r1) != -1)
-    {
-      r0 = cons (r1, r0);
-      r1 = read_char (cell_nil);
-      gc_check ();
-    }
-  g_stdin = fd;
-  SCM lst = MAKE_STRING (reverse_x_ (r0, cell_nil));
-  gc_pop_frame ();
-  return lst;
-}
-
 SCM
 write_byte (SCM x) ///((arity . n))
 {
@@ -156,48 +149,27 @@ write_byte (SCM x) ///((arity . n))
   return c;
 }
 
-char string_to_cstring_buf[4096];
-char const*
-string_to_cstring_ (SCM s, char *buf)
-{
-  char *p = buf;
-  s = STRING(s);
-  while (s != cell_nil)
-    {
-      *p++ = VALUE (car (s));
-      s = cdr (s);
-    }
-  *p = 0;
-  return buf;
-}
-
-char const*
-string_to_cstring (SCM s)
-{
-  return string_to_cstring_ (s, string_to_cstring_buf);
-}
-
 SCM
 getenv_ (SCM s) ///((name . "getenv"))
 {
   char *p;
-  p = getenv (string_to_cstring (s));
+  p = getenv (CSTRING (s));
-  return p ? MAKE_STRING (cstring_to_list (p)) : cell_f;
+  return p ? MAKE_STRING0 (p) : cell_f;
 }
 
 SCM
 setenv_ (SCM s, SCM v) ///((name . "setenv"))
 {
   char buf[1024];
-  strcpy (buf, string_to_cstring (s));
+  strcpy (buf, CSTRING (s));
-  setenv (buf, string_to_cstring (v), 1);
+  setenv (buf, CSTRING (v), 1);
   return cell_unspecified;
 }
 
 SCM
 access_p (SCM file_name, SCM mode)
 {
-  return access (string_to_cstring (file_name), VALUE (mode)) == 0 ? cell_t : cell_f;
+  return access (CSTRING (file_name), VALUE (mode)) == 0 ? cell_t : cell_f;
 }
 
 SCM
@@ -206,6 +178,10 @@ current_input_port ()
   if (g_stdin >= 0)
     return MAKE_NUMBER (g_stdin);
   SCM x = g_ports;
+  if (g_debug > 2)
+    {
+      eputs ("ports:"); write_error_ (g_ports); eputs ("\n");
+    }
   while (x && PORT (CAR (x)) != g_stdin)
     x = CDR (x);
   return CAR (x);
@@ -214,13 +190,17 @@ current_input_port ()
 SCM
 open_input_file (SCM file_name)
 {
-  return MAKE_NUMBER (open (string_to_cstring (file_name), O_RDONLY));
+  return MAKE_NUMBER (open (CSTRING (file_name), O_RDONLY));
 }
 
 SCM
 open_input_string (SCM string)
 {
-  SCM port = MAKE_STRING_PORT (STRING (string));
+  SCM port = MAKE_STRING_PORT (string);
+  if (g_debug > 2)
+    {
+      eputs ("new port:"); write_error_ (port); eputs ("\n");
+    }
   g_ports = cons (port, g_ports);
   return port;
 }
@@ -256,7 +236,7 @@ open_output_file (SCM x) ///((arity . n))
   int mode = S_IRUSR|S_IWUSR;
   if (TYPE (x) == TPAIR && TYPE (car (x)) == TNUMBER)
     mode = VALUE (car (x));
-  return MAKE_NUMBER (open (string_to_cstring (file_name), O_WRONLY|O_CREAT|O_TRUNC,mode));
+  return MAKE_NUMBER (open (CSTRING (file_name), O_WRONLY|O_CREAT|O_TRUNC,mode));
 }
 
 SCM
@@ -282,7 +262,7 @@ force_output (SCM p) ///((arity . n))
 SCM
 chmod_ (SCM file_name, SCM mode) ///((name . "chmod"))
 {
-  chmod (string_to_cstring (file_name), VALUE (mode));
+  chmod (CSTRING (file_name), VALUE (mode));
   return cell_unspecified;
 }
 
@@ -303,20 +283,17 @@ execl_ (SCM file_name, SCM args) ///((name . "execl"))
 {
   char *c_argv[1000];           // POSIX minimum 4096
   int i = 0;
-  int n = 0;
 
   if (length__ (args) > 1000)
     error (cell_symbol_system_error,
            cons (file_name,
-                 cons (MAKE_STRING (cstring_to_list ("too many arguments")),
+                 cons (MAKE_STRING0 ("too many arguments"),
                        cons (file_name, args))));
-  c_argv[i++] = (char*)string_to_cstring_ (file_name, string_to_cstring_buf+n);
+  c_argv[i++] = CSTRING (file_name);
-  n += length__ (STRING (file_name)) + 1;
   while (args != cell_nil)
     {
       assert (TYPE (CAR (args)) == TSTRING);
-      c_argv[i++] = (char*)string_to_cstring_ (CAR (args), string_to_cstring_buf+n);
+      c_argv[i++] = CSTRING (CAR (args));
-      n += length__ (STRING (CAR (args))) + 1;
       args = CDR (args);
       if (g_debug > 2)
         {
@@ -386,7 +363,7 @@ SCM
 getcwd_ () ///((name . "getcwd"))
 {
   char buf[PATH_MAX];
-  return MAKE_STRING (cstring_to_list (getcwd (buf, PATH_MAX)));
+  return MAKE_STRING0 (getcwd (buf, PATH_MAX));
 }
 
 SCM
@@ -405,6 +382,6 @@ dup2_ (SCM old, SCM new) ///((name . "dup2"))
 SCM
 delete_file (SCM file_name)
 {
-  unlink (string_to_cstring (file_name));
+  unlink (CSTRING (file_name));
   return cell_unspecified;
 }

src/reader.c

@@ -21,8 +21,6 @@
 
 #include <ctype.h>
 
-#define MAX_STRING 4096
-
 SCM
 read_input_file_env_ (SCM e, SCM a)
 {
@@ -49,7 +47,7 @@ reader_read_line_comment (int c)
       c = readchar ();
     }
   error (cell_symbol_system_error,
-         MAKE_STRING (cstring_to_list ("reader_read_line_comment")));
+         MAKE_STRING0 ("reader_read_line_comment"));
 }
 
 SCM reader_read_block_comment (int s, int c);
@@ -176,7 +174,7 @@ reader_read_list (int c, SCM a)
   if (c == ')')
     return cell_nil;
   if (c == EOF)
-    error (cell_symbol_not_a_pair, MAKE_STRING (cstring_to_list ("EOF in list")));
+    error (cell_symbol_not_a_pair, MAKE_STRING0 ("EOF in list"));
     //return cell_nil;
   SCM s = reader_read_sexp_ (c, a);
   if (s == cell_dot)
@@ -233,7 +231,14 @@ reader_read_hash (int c, SCM a)
     return cons (cell_symbol_quasisyntax,
                  cons (reader_read_sexp_ (readchar (), a), cell_nil));
   if (c == ':')
-    return MAKE_KEYWORD (CAR (reader_read_sexp_ (readchar (), a)));
+    {
+      SCM x = reader_read_identifier_or_number (readchar ());
+      if (TYPE (x) == TNUMBER)
+        error (cell_symbol_system_error, // READ error
+               cons (MAKE_STRING0 ("keyword perifx ':' not followed by a symbol: "),
+                     x));
+      return symbol_to_keyword (x);
+    }
   if (c == 'b')
     return reader_read_binary ();
   if (c == 'o')
@@ -275,6 +280,16 @@ reader_read_character ()
           p = peekchar ();
         }
     }
+  else if (c == 'x'
+           && ((p >= '0' && p <= '9')
+               || (p >= 'a' && p <= 'f')
+               || (p >= 'F' && p <= 'F')))
+    {
+      c = VALUE (reader_read_hex ());
+      eputs ("reading hex c=");
+      eputs (itoa (c));
+      eputs ("\n");
+    }
   else if (((c >= 'a' && c <= 'z')
             || c == '*')
            && ((p >= 'a' && p <= 'z')
@@ -330,7 +345,7 @@ reader_read_character ()
           eputs (buf);
           eputs ("\n");
           error (cell_symbol_system_error,
-                 MAKE_STRING (cstring_to_list ("char not supported")));
+                 MAKE_STRING0 ("char not supported"));
         }
     }
   return MAKE_CHAR (c);
@@ -418,10 +433,12 @@ reader_read_hex ()
 SCM
 reader_read_string ()
 {
-  SCM lst = cell_nil;
+  char buf[MAX_STRING];
+  size_t i = 0;
   int c;
   do
     {
+      assert (i < MAX_STRING);
       c = readchar ();
       if (c == '"')
         break;
@@ -429,40 +446,37 @@ reader_read_string ()
         {
           c = readchar ();
           if (c == '\\' || c == '"')
-            lst = cons (MAKE_CHAR (c), lst);
+            ;
           else if (c == '0')
-            lst = cons (MAKE_CHAR ('\0'), lst);
+            c = '\0';
           else if (c == 'a')
-            lst = cons (MAKE_CHAR ('\a'), lst);
+            c = '\a';
           else if (c == 'b')
-            lst = cons (MAKE_CHAR ('\b'), lst);
+            c = '\b';
           else if (c == 't')
-            lst = cons (MAKE_CHAR ('\t'), lst);
+            c = '\t';
           else if (c == 'n')
-            lst = cons (MAKE_CHAR ('\n'), lst);
+            c = '\n';
           else if (c == 'v')
-            lst = cons (MAKE_CHAR ('\v'), lst);
+            c = '\v';
           else if (c == 'f')
-            lst = cons (MAKE_CHAR ('\f'), lst);
+            c = '\f';
           else if (c == 'r')
             // Nyacc bug
-            // lst = cons (MAKE_CHAR ('\r'), lst);
+            // c = '\r';
-            lst = cons (MAKE_CHAR (13), lst);
+            c = 13;
           else if (c == 'e')
             // Nyacc bug
-            // lst = cons (MAKE_CHAR ('\e'), lst);
+            // c = '\e';
-            lst = cons (MAKE_CHAR (27), lst);
+            c = 27;
           else if (c == 'x')
-            {
+            c = VALUE (reader_read_hex ());
-              SCM x = reader_read_hex ();
-              lst = cons (MAKE_CHAR (VALUE (x)), lst);
         }
-        }
+      buf[i++] = c;
-      else
-        lst = cons (MAKE_CHAR (c), lst);
     }
   while (1);
-  return MAKE_STRING (reverse_x_ (lst, cell_nil));
+  buf[i] = 0;
+  return make_string (buf, i);
 }
 
 int g_tiny = 0;

src/strings.c

@@ -0,0 +1,242 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017,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/>.
+ */
+
+#define MAX_STRING 4096
+
+char const*
+list_to_cstring (SCM list, size_t* size)
+{
+  static char buf[MAX_STRING];
+  size_t i = 0;
+  char *p = buf;
+  while (list != cell_nil)
+    {
+      assert (i < MAX_STRING);
+      buf[i++] = VALUE (car (list));
+      list = cdr (list);
+    }
+  buf[i] = 0;
+  *size = i;
+  return buf;
+}
+
+size_t
+bytes_cells (size_t length)
+{
+  return (1 + sizeof (long) + sizeof (long) + length + sizeof (SCM)) / sizeof (SCM);
+}
+
+SCM
+make_bytes (char const* s, size_t length)
+{
+  size_t size = bytes_cells (length);
+  SCM x = alloc (size);
+  TYPE (x) = TBYTES;
+  LENGTH (x) = length;
+  char *p = &g_cells[x].cdr;
+  if (!length)
+    *(char*)p = 0;
+  else
+    memcpy (p, s, length + 1);
+  if (g_debug > 2)
+    {
+      eputs ("make bytes: "); eputs (s); eputs ("\n");
+      eputs ("     bytes: "); eputs (CBYTES (x)); eputs ("\n");
+      eputs ("    length: "); eputs (itoa (length)); eputs ("\n");
+      eputs ("        ==> "); write_error_ (x);
+      eputs ("\n");
+    }
+  return x;
+}
+
+SCM
+make_string (char const* s, size_t length)
+{
+  assert (length < HALFLONG_MAX);
+  SCM x = make_cell__ (TSTRING, length, 0);
+  SCM v = make_bytes (s, length);
+  CDR (x) = v;
+  return x;
+}
+
+SCM
+string_equal_p (SCM a, SCM b) ///((name . "string=?"))
+{
+  if (! ((TYPE (a) == TSTRING && TYPE (b) == TSTRING)
+         || (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD)))
+    {
+      eputs ("type a: "); eputs (itoa (TYPE (a))); eputs ("\n");
+      eputs ("type b: "); eputs (itoa (TYPE (b))); eputs ("\n");
+      eputs ("a= "); write_error_ (a); eputs ("\n");
+      eputs ("b= "); write_error_ (b); eputs ("\n");
+      assert ((TYPE (a) == TSTRING && TYPE (b) == TSTRING)
+              || (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD));
+    }
+  if (g_debug == -1)
+    {
+      eputs ("string=?: "); eputs (CSTRING (a));
+      eputs (" =? "); eputs (CSTRING (b));
+    }
+  if (a == b
+      || STRING (a) == STRING (b)
+      || (!LENGTH (a) && !LENGTH (b))
+      || (LENGTH (a) == LENGTH (b)
+          && !memcmp (CSTRING (a), CSTRING (b), LENGTH (a))))
+    {
+      if (g_debug == -1)
+        eputs (" => #t\n");
+      return cell_t;
+    }
+  if (g_debug == -1)
+    eputs (" => #f\n");
+  return cell_f;
+}
+
+SCM
+symbol_to_string (SCM symbol)
+{
+  SCM x = make_cell__ (TSTRING, CAR (symbol), CDR (symbol));
+
+  if (g_debug > 2)
+    {
+      eputs ("symbol->string: "); eputs (CSTRING (x)); eputs ("\n");
+      eputs ("  was: "); write_error_ (symbol);
+      eputs ("==> "); write_error_ (x);
+      eputs ("\n");
+    }
+  return x;
+}
+
+SCM
+symbol_to_keyword (SCM symbol)
+{
+  SCM x = make_cell__ (TKEYWORD, CAR (symbol), CDR (symbol));
+
+  if (g_debug > 2)
+    {
+      eputs ("symbol->keyword: "); eputs (CSTRING (x)); eputs ("\n");
+      eputs ("  was: "); write_error_ (symbol);
+      eputs ("==> "); write_error_ (x);
+      eputs ("\n");
+    }
+  return x;
+}
+
+SCM
+keyword_to_string (SCM keyword)
+{
+  SCM x = make_cell__ (TSTRING, CAR (keyword), CDR (keyword));
+
+  if (g_debug > 2)
+    {
+      eputs ("keyword->string: "); eputs (CSTRING (x)); eputs ("\n");
+      eputs ("  was: "); write_error_ (keyword);
+      eputs ("==> "); write_error_ (x);
+      eputs ("\n");
+    }
+  return x;
+}
+
+SCM
+string_to_symbol (SCM string)
+{
+  SCM x = hash_ref (g_symbols, string, cell_f);
+  if (x == cell_f)
+    x = make_symbol (string);
+  return x;
+}
+
+SCM
+make_symbol (SCM string)
+{
+  SCM x = make_cell__ (TSYMBOL, LENGTH (string), STRING (string));
+  hash_set_x (g_symbols, string, x);
+
+  if (g_debug > 3)
+    hash_table_printer (g_symbols);
+
+  if (g_debug > 2)
+    {
+      eputs ("make_symbol: "); eputs (CSTRING (string)); eputs ("\n");
+      eputs ("==> "); write_error_ (x);
+      eputs ("\n");
+    }
+
+  return x;
+}
+
+SCM
+bytes_to_list (char const* s, size_t i)
+{
+  SCM p = cell_nil;
+  while (i--)
+    {
+      int c = (0x100 + s[i]) % 0x100;
+      p = cons (MAKE_CHAR (c), p);
+    }
+  return p;
+}
+
+SCM
+cstring_to_list (char const* s)
+{
+  return bytes_to_list (s, strlen (s));
+}
+
+SCM
+cstring_to_symbol (char const *s)
+{
+  SCM string = MAKE_STRING0 (s);
+  return string_to_symbol (string);
+}
+
+SCM
+string_to_list (SCM string)
+{
+  return bytes_to_list (CSTRING (string), LENGTH (string));
+}
+
+SCM
+list_to_string (SCM list)
+{
+  size_t size;
+  char const *s = list_to_cstring (list, &size);
+  return make_string (s, size);
+}
+
+SCM
+read_string (SCM port) ///((arity . n))
+{
+  int fd = g_stdin;
+  if (TYPE (port) == TPAIR && TYPE (car (port)) == TNUMBER)
+    g_stdin = VALUE (CAR (port));
+  int c = readchar ();
+  static char buf[MAX_STRING];
+  size_t i = 0;
+  while (c != -1)
+    {
+      assert (i < MAX_STRING);
+      buf[i++] = c;
+      c = readchar ();
+    }
+  buf[i] = 0;
+  g_stdin = fd;
+  return make_string (buf, i);
+}

tests/base.test

@@ -1,6 +1,9 @@
 #! /bin/sh
 # -*-scheme-*-
-exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests base)' -s "$0" "$@"
+if [ "$MES" != guile ]; then
+    MES_BOOT=boot-03.scm exec ${MES-mes} < $0
+fi
+exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@"
 !#
 
 ;;; -*-scheme-*-
@@ -27,7 +30,12 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
   #:use-module (mes mes-0)
   #:use-module (mes test))
 
-(mes-use-module (mes test))
+(cond-expand
+ (mes
+  (primitive-load "module/mes/test.scm"))
+ (guile-2)
+ (guile
+  (use-modules (ice-9 syncase))))
 
 (pass-if "first dummy" #t)
 (pass-if-not "second dummy" #f)

tests/boot.test

@@ -1,10 +1,7 @@
 #! /bin/sh
 # -*-scheme-*-
 if [ "$MES" != guile ]; then
-    export MES_BOOT=boot-02.scm
+    MES_BOOT=boot-02.scm exec ${MES-mes} < $0
-    MES=${MES-$(dirname $0)/../src/mes}
-    $MES < $0
-    exit $?
 fi
 exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@"
 !#

tests/macro.test

@@ -57,19 +57,9 @@ exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests macr
 
 ;; type-0.mes
 (define (string . lst)
-  (core:make-cell <cell:string> lst 0))
+  (list->string lst))
-
-(define (string->symbol s)
-  (if (not (pair? (core:car s))) '()
-      (list->symbol (core:car s))))
-
-(define (symbol->list s)
-  (core:car s))
 
 ;; boot-0.scm
-(define (symbol->string s)
-  (apply string (symbol->list s)))
-
 (define (string-append . rest)
   (apply string (apply append (map1 string->list rest))))
 

tests/optargs.test

@@ -24,7 +24,7 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (tests optargs)
-  #:use-module (ice-9 optargs)
+  #:use-module (mes optargs)
   #:use-module (mes mes-0)
   #:use-module (mes test))
 
@@ -71,15 +71,6 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
         (cons <locals> locals)
         (cons <text> text)))
 
-;; (define* (make o #:key (functions '()) (globals '()) (locals '()) (text '()))
-;;   (format (current-error-port) "make\n")
-;;   ((cond ((info? o)
-;;           (list <info>
-;;                 (cons <functions> functions)
-;;                 (cons <globals> globals)
-;;                 (cons <locals> locals)
-;;                 (cons <text> text))))))
-
 (define (.functions o)
   (assq-ref (cdr o) <functions>))
 
@@ -95,23 +86,6 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
 (define (info? o)
   (and (pair? o) (eq? (car o) <info>)))
 
-;; FIXME: psyntax+pmatch+optarg is broken; BINDINGS-> (g1234 g1234)
-;; iso (function function)
-;; (define (clone o . rest)
-;;   (pmatch o
-;;     ((<info>
-;;       (<functions> . ,functions)
-;;       (<globals> . ,globals)
-;;       (<locals> . ,locals)
-;;       (<text> . ,text))
-;;      (let-keywords rest
-;;                    #f
-;;                    ((functions functions)
-;;                     (globals globals)
-;;                     (locals locals)
-;;                     (text text))
-;;                    (make <info> #:functions functions #:globals globals #:locals locals #:text text)))))
-
 (define (clone o . rest)
   (cond ((info? o)
          (let ((functions (.functions o))

tests/perform.test

@@ -1,9 +1,8 @@
 #! /bin/sh
 # -*-scheme-*-
 if [ "$MES" != guile ]; then
-    export MES_BOOT=boot-02.scm
     MES=${MES-$(dirname $0)/../src/mes}
-    $MES < $0
+    MES_BOOT=boot-02.scm exec $MES < $0
     exit $?
 fi
 exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests perform)' -s "$0" "$@"

tests/posix.test

@@ -0,0 +1,40 @@
+#! /bin/sh
+# -*-scheme-*-
+exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests srfi-13)' -s "$0" "$@"
+!#
+
+;;; -*-scheme-*-
+
+;;; 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/>.
+
+(define-module (tests srfi-13)
+  #:use-module (mes mes-0)
+  #:use-module (mes test))
+
+(mes-use-module (srfi srfi-13))
+(mes-use-module (mes test))
+
+(pass-if "first dummy" #t)
+(pass-if-not "second dummy" #f)
+
+(pass-if-eq "system*" 0 (system* "true"))
+
+(pass-if-eq "system*" 256 (system* "false"))
+
+(result 'report)

tests/quasiquote.test

@@ -1,6 +1,9 @@
 #! /bin/sh
 # -*-scheme-*-
-exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests quasiquote)' -s "$0" "$@"
+if [ "$MES" != guile ]; then
+    MES_BOOT=boot-03.scm exec ${MES-mes} < $0
+fi
+exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@"
 !#
 
 ;;; -*-scheme-*-
@@ -27,9 +30,12 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
   #:use-module (mes mes-0)
   #:use-module (mes test))
 
-(mes-use-module (mes base))
+(cond-expand
-(mes-use-module (mes quasiquote))
+ (mes
-(mes-use-module (mes test))
+  (primitive-load "module/mes/test.scm"))
+ (guile-2)
+ (guile
+  (use-modules (ice-9 syncase))))
 
 (pass-if "first dummy" #t)
 (pass-if-not "second dummy" #f)

tests/read.test

@@ -22,9 +22,12 @@
 # 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 [ "$MES" != guile ]; then
     MES=${MES-$(dirname $0)/../src/mes}
-exec $MES -s $0
+    MES_BOOT=boot-02.scm exec $MES < $0
+fi
+
+exec ${MES-mes} --no-auto-compile -s $0
 !#
 
 0

tests/scm.test

@@ -1,6 +1,9 @@
 #! /bin/sh
 # -*-scheme-*-
-exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests scm)' -s "$0" "$@"
+if [ "$MES" != guile ]; then
+    MES_BOOT=boot-03.scm exec ${MES-mes} < $0
+fi
+exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@"
 !#
 
 ;;; -*-scheme-*-
@@ -27,9 +30,12 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
   #:use-module (mes mes-0)
   #:use-module (mes test))
 
-(mes-use-module (mes scm))
+(cond-expand
-(mes-use-module (srfi srfi-0))
+ (mes
-(mes-use-module (mes test))
+  (primitive-load "module/mes/test.scm"))
+ (guile-2)
+ (guile
+  (use-modules (ice-9 syncase))))
 
 (pass-if "first dummy" #t)
 (pass-if-not "second dummy" #f)
@@ -125,22 +131,6 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
 (pass-if-equal "iota -1"
                '() (iota -1))
 
-(pass-if-equal "reverse" '(3 2 1)
-               (reverse '(1 2 3)))
-
-(pass-if-equal "reverse fresh" '(1 2 3)
-               (let ((list '(1 2 3)))
-                 (reverse list)
-                 list))
-
-(pass-if-equal "reverse!" '(1)
-               (let ((list '(1 2 3)))
-                 (reverse! list)
-                 list))
-
-(pass-if-equal "reverse! ()" '()
-  (reverse! '()))
-
 (pass-if "cond-expand" (sequal? (cond-expand (foobar #f) (mes (display ": pass: *YAY*") 'mes) (guile (display ": pass: *GUILE*") 'mes)) 'mes))
 
 (pass-if "apply identity" (seq? (apply identity '(0)) 0))

tests/srfi-13.test

@@ -33,10 +33,18 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
 (pass-if "first dummy" #t)
 (pass-if-not "second dummy" #f)
 
+(pass-if "string=?"
+  (string=? "foo" "foo"))
+
+(pass-if "string=?"
+  (let ((empty ""))
+   (string=? "" empty)))
+
 (pass-if-equal "string-join"
     "foo bar"
   (string-join '("foo" "bar")))
 
+
 (pass-if-equal "string-join infix"
                "foo+bar"
                (string-join '("foo" "bar") "+"))
@@ -73,6 +81,15 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
 (pass-if-equal "number->string INT-MIN" "-2147483648" (number->string -2147483648))
 (pass-if-equal "number->string" "-4" (number->string -4))
 
+(pass-if-eq "string->list" #\A
+            (car (string->list "A")))
+
+(pass-if-eq "string->list high" #\xff
+            (car (string->list (list->string (list (integer->char 255))))))
+
+(pass-if-eq "string->list high" #xff
+            (char->integer (car (string->list (list->string (list (integer->char 255)))))))
+
 (pass-if-equal "string-fold"
     "oof"
   (list->string (string-fold cons '() "foo")))
@@ -108,4 +125,20 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
 (pass-if-equal "string-replace" "fubar"
              (string-replace "foobar" "u" 1 3))
 
+(pass-if-equal "reverse" '(3 2 1)
+               (reverse '(1 2 3)))
+
+(pass-if-equal "reverse fresh" '(1 2 3)
+               (let ((list '(1 2 3)))
+                 (reverse list)
+                 list))
+
+(pass-if-equal "reverse!" '(1)
+               (let ((list '(1 2 3)))
+                 (reverse! list)
+                 list))
+
+(pass-if-equal "reverse! ()" '()
+  (reverse! '()))
+
 (result 'report (if (and (or #t (equal? %compiler "gnuc")) (equal? %arch "x86")) 1 0))