core: String as array of bytes.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sun, 11 Nov 2018 15:25:36 +0000 (16:25 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sun, 11 Nov 2018 15:25:36 +0000 (16:25 +0100)
* src/strings.c: New file.
* src/mes.c: Use it.  Update users.

61 files changed:
build-aux/build-mes.sh
build-aux/check-boot.sh
build-aux/check-mes.sh
build-aux/config.sh
build-aux/mes-snarf.scm
build-aux/snarf.sh
include/linux/x86_64/syscall.h
include/signal.h
lib/linux/gettimeofday.c
lib/linux/gnu.c
mes/module/mes/base.mes
mes/module/mes/boot-0.scm.in
mes/module/mes/boot-01.scm
mes/module/mes/boot-02.scm
mes/module/mes/boot-03.scm [new file with mode: 0644]
mes/module/mes/display.mes
mes/module/mes/optargs.scm [deleted file]
mes/module/mes/scm.mes
mes/module/mes/type-0.mes
mes/module/srfi/srfi-13.mes
module/mes/getopt-long.scm
module/mes/guile.scm
module/mes/misc.scm
module/mes/optargs.scm [new file with mode: 0644]
module/mescc/M1.scm
module/mescc/compile.scm
scaffold/boot/17-equal2.scm [new file with mode: 0644]
scaffold/boot/17-memq-keyword.scm [new file with mode: 0644]
scaffold/boot/17-memq.scm [new file with mode: 0644]
scaffold/boot/17-open-input-string.scm [new file with mode: 0644]
scaffold/boot/17-string-equal.scm [new file with mode: 0644]
scaffold/boot/4f-string-split.scm
scaffold/boot/50-keyword.scm [new file with mode: 0644]
scaffold/boot/50-make-string.scm [new file with mode: 0644]
scaffold/boot/50-string-append.scm [new file with mode: 0644]
scaffold/boot/50-string-join.scm [new file with mode: 0644]
scaffold/boot/51-module.scm
scaffold/boot/52-define-module.scm
scaffold/boot/60-let-syntax-expanded.scm
scaffold/boot/60-let-syntax.scm
scaffold/mini-mes.c
scripts/mescc.in
src/gc.c
src/hash.c
src/lib.c
src/mes.c
src/module.c
src/posix.c
src/reader.c
src/strings.c [new file with mode: 0644]
tests/base.test
tests/boot.test
tests/macro.test
tests/optargs.test
tests/perform.test
tests/posix.test [new file with mode: 0755]
tests/quasiquote.test
tests/read.test
tests/scm.test
tests/srfi-13.test
tests/srfi-14.test

index e839bbd6248dc680c71081537702c4b814451db3..ff19ec1200a17486f1e6dd1b00eac66627fa44ff 100755 (executable)
@@ -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" ] && link scaffold/mini-mes
+#[ "$mes_p" ] && compile scaffold/mini-mes
+#[ "$mes_p" ] && link scaffold/mini-mes
 
 compile src/mes
 link src/mes
index 7b9ca5560b84028c2da62dae2ebe6c7cf8cfa654..630567fde9bf6ec7c56ee4289135704b844656b7 100755 (executable)
@@ -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
index 2e8128e4ebf0470be6f1174b00ed5b5eacd9a8a2..1555f31b26b09efb9e6675290653114b8b734b81 100755 (executable)
@@ -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
 "
index 99ac740e99d943771a79b9b1e4a7e32b37bc023d..75d1d42b0fa40c17033e23807a5d339fa0b736af 100644 (file)
@@ -87,8 +87,7 @@ CPPFLAGS=${CPPFLAGS-"
 -D 'VERSION=\"$VERSION\"'
 -D 'MODULEDIR=\"$moduledir\"'
 -D 'PREFIX=\"$prefix\"'
--I src
--I ${srcdest}src
+-I ${srcdest}.
 -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
index d01d337ccd2bcd4ef262714f9cdcc7e5373659b5..0730108f91b89e81b47c47af5840179f2f3e0292 100755 (executable)
@@ -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 "g_cells[cell_~a].car = cstring_to_list (scm_~a.car);\n" s s)))
+      (format #f "NAME_SYMBOL (cell_~a, scm_~a.name);\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.car = 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.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 "g_cells[cell_~a].car = MAKE_STRING (scm_~a.car);\n" (function.name f) (function.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)))))
+       (format #f "a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_~a)), ~a, a);\n\n" (function.name f) (function-cell-name f))
+       (format #f "a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_~a)), ~a, a);\n\n" (function.name f) (function-cell-name f)))))
 
 (define (disjoin . predicates)
   (lambda (. arguments)
index a77677f423f13a2f9469b19cc120c4fa189b6c74..07f8f78df7576fbe66dd39b3b7a9a2e2c2fe3e80 100755 (executable)
@@ -27,13 +27,14 @@ snarf="    "
 if [ -n "$1" ]; then
     snarf=.mes
 fi
-trace "SNARF$snarf  gc.c"     ${srcdest}build-aux/mes-snarf.scm $1 src/gc.c
-trace "SNARF$snarf  hash.c"   ${srcdest}build-aux/mes-snarf.scm $1 src/hash.c
-trace "SNARF$snarf  lib.c"    ${srcdest}build-aux/mes-snarf.scm $1 src/lib.c
-trace "SNARF$snarf  math.c"   ${srcdest}build-aux/mes-snarf.scm $1 src/math.c
-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  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
+trace "SNARF$snarf  gc.c"      ${srcdest}build-aux/mes-snarf.scm $1 src/gc.c
+trace "SNARF$snarf  hash.c"    ${srcdest}build-aux/mes-snarf.scm $1 src/hash.c
+trace "SNARF$snarf  lib.c"     ${srcdest}build-aux/mes-snarf.scm $1 src/lib.c
+trace "SNARF$snarf  math.c"    ${srcdest}build-aux/mes-snarf.scm $1 src/math.c
+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
index 0c73df784b57cd0341ff28e26e24d34cf221bf28..5737ecbbf5fca22f6b32a66fb89abacc34917d3a 100644 (file)
@@ -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
index bfb18b1c518545456d3b8bbd9a3f076553dcad60..e6ed807084b6fbfbc1033f47e5bedfd6184f5aa5 100644 (file)
@@ -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
index 0e42785609b8de5d883a98d5b981f45ad78bef47..81cf0fc05365c03b0b27cf3b555b0c21e6b8e0c4 100644 (file)
@@ -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)
index 402f30e131291028cffe278dbbce1699e1b6db36..7d4f08c5ddc231445c050531f0eb89fec52ecdd9 100644 (file)
@@ -63,19 +63,13 @@ getgid ()
   return _sys_call (SYS_getgid);
 }
 
-// long _sys_call (long sys_call);
-// 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
-
+#if __x86_64__
 void
 _restorer (void)
 {
   _sys_call (SYS_rt_sigreturn);
 }
+#endif
 
 # define __sigmask(sig) \
   (((unsigned long int) 1) << (((sig) - 1) % (8 * sizeof (unsigned long int))))
index 15af15d1d02b521057c620664dbf04e26f673881..9591ffad38b179a337513b57de8d4b10e74cecdb 100644 (file)
   (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)))
index 9351c3b36da6bb4e7d02ac8d8ac0e9e738d38e71..0d5d9c960192c1f459f18704923a3e3c7ac2648f 100644 (file)
   (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)
   #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)
 
   (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")
       (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/"
 (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")))
 (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))
index edad5e3cde7801d38f1ed341c30315a1b7a2ed40..74641c22f70c286c0689f9d6095600f0870a9ed2 100644 (file)
   (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)
index e400db43edde432892656ef4db52d8449c4991a2..4e691b40088594edb4500135796b7060f3b11829 100644 (file)
   (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)
diff --git a/mes/module/mes/boot-03.scm b/mes/module/mes/boot-03.scm
new file mode 100644 (file)
index 0000000..4bfc6a3
--- /dev/null
@@ -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)
index 5245b52f4a5756b81de7e24b7a708fbf16c11e0d..71a1fb0e3de9eed8b8b663793b2b6a9cf40edd05 100644 (file)
          (write? (and (pair? rest) (pair? (cdr rest)) (cadr rest))))
 
     (define (display-char x port write?)
-      (cond ((and write? (or (eq? x #\") (eq? x #\\)))
-             (write-char #\\ port)
-             (write-char x port))
-            ((and write? (eq? x #\nul))
-             (write-char #\\ port)
-             (write-char #\0 port))
-            ((and write? (eq? x #\alarm))
-             (write-char #\\ port)
-             (write-char #\a port))
-            ((and write? (eq? x #\backspace))
-             (write-char #\\ port)
-             (write-char #\b port))
-            ((and write? (eq? x #\tab))
-             (write-char #\\ port)
-             (write-char #\t port))
-            ((and write? (eq? x #\newline))
-             (write-char #\\ port)
-             (write-char #\n port))
-            ((and write? (eq? x #\vtab))
-             (write-char #\\ port)
-             (write-char #\v port))
-            ((and write? (eq? x #\page))
-             (write-char #\\ port)
-             (write-char #\f port))
-            (#t (write-char x port))))
+      (if write?
+          (cond ((or (eq? x #\") (eq? x #\\))
+                 (write-char #\\ port)
+                 (write-char x port))
+                ((eq? x #\nul)
+                 (write-char #\\ port)
+                 (write-char #\0 port))
+                ((eq? x #\alarm)
+                 (write-char #\\ port)
+                 (write-char #\a port))
+                ((eq? x #\backspace)
+                 (write-char #\\ port)
+                 (write-char #\b port))
+                ((eq? x #\tab)
+                 (write-char #\\ port)
+                 (write-char #\t port))
+                ((eq? x #\newline)
+                 (write-char #\\ port)
+                 (write-char #\n port))
+                ((eq? x #\vtab)
+                 (write-char #\\ port)
+                 (write-char #\v port))
+                ((eq? x #\page)
+                 (write-char #\\ port)
+                 (write-char #\f 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))
                                          (#\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)
         (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)
diff --git a/mes/module/mes/optargs.scm b/mes/module/mes/optargs.scm
deleted file mode 100644 (file)
index 943e21f..0000000
+++ /dev/null
@@ -1,500 +0,0 @@
-;;;; optargs.scm -- support for optional arguments
-;;;;
-;;;;   Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by 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
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;;;; Lesser 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
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;;;
-;;;; Contributed by Maciej Stachowiak <mstachow@alum.mit.edu>
-
-\f
-
-;;; Commentary:
-
-;;; {Optional Arguments}
-;;;
-;;; The C interface for creating Guile procedures has a very handy
-;;; "optional argument" feature. This module attempts to provide
-;;; similar functionality for procedures defined in Scheme with
-;;; a convenient and attractive syntax.
-;;;
-;;; exported macros are:
-;;;   let-optional
-;;;   let-optional*
-;;;   let-keywords
-;;;   let-keywords*
-;;;   lambda*
-;;;   define*
-;;;   define*-public
-;;;   defmacro*
-;;;   defmacro*-public
-;;;
-;;;
-;;; Summary of the lambda* extended parameter list syntax (brackets
-;;; are used to indicate grouping only):
-;;;
-;;; ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]?
-;;;   [#:key [ext-var-decl]+ [#:allow-other-keys]?]?
-;;;   [[#:rest identifier]|[. identifier]]?
-;;;
-;;; ext-var-decl ::= identifier | ( identifier expression )
-;;;
-;;; The characters `*', `+' and `?' are not to be taken literally; they
-;;; mean respectively, zero or more occurences, one or more occurences,
-;;; and one or zero occurences.
-;;;
-
-;;; Code:
-
-(define-module (ice-9 optargs)
-  #:use-module (system base pmatch)
-  #:replace (lambda*)
-  #:export-syntax (let-optional
-                 let-optional*
-                 let-keywords
-                 let-keywords*
-                 define*
-                  define*-public
-                 defmacro*
-                 defmacro*-public))
-
-;; let-optional rest-arg (binding ...) . body
-;; let-optional* rest-arg (binding ...) . body
-;;   macros used to bind optional arguments
-;;
-;; These two macros give you an optional argument interface that is
-;; very "Schemey" and introduces no fancy syntax. They are compatible
-;; with the scsh macros of the same name, but are slightly
-;; extended. Each of binding may be of one of the forms <var> or
-;; (<var> <default-value>). rest-arg should be the rest-argument of
-;; the procedures these are used from. The items in rest-arg are
-;; sequentially bound to the variable namess are given. When rest-arg
-;; runs out, the remaining vars are bound either to the default values
-;; or to `#f' if no default value was specified. rest-arg remains
-;; bound to whatever may have been left of rest-arg.
-;;
-
-(defmacro let-optional (REST-ARG BINDINGS . BODY)
-  (let-optional-template REST-ARG BINDINGS BODY 'let))
-
-(defmacro let-optional* (REST-ARG BINDINGS . BODY)
-  (let-optional-template REST-ARG BINDINGS BODY 'let*))
-
-
-
-;; let-keywords rest-arg allow-other-keys? (binding ...) . body
-;; let-keywords* rest-arg allow-other-keys? (binding ...) . body
-;;   macros used to bind keyword arguments
-;;
-;; These macros pick out keyword arguments from rest-arg, but do not
-;; modify it. This is consistent at least with Common Lisp, which
-;; duplicates keyword args in the rest arg. More explanation of what
-;; keyword arguments in a lambda list look like can be found below in
-;; the documentation for lambda*.  Bindings can have the same form as
-;; for let-optional. If allow-other-keys? is false, an error will be
-;; thrown if anything that looks like a keyword argument but does not
-;; match a known keyword parameter will result in an error.
-;;
-
-
-(defmacro let-keywords (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
-  (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let))
-
-(defmacro let-keywords* (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
-  (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let*))
-
-
-;; some utility procedures for implementing the various let-forms.
-
-(define (let-o-k-template REST-ARG BINDINGS BODY let-type proc)
-  (let ((bindings (map (lambda (x)
-                        (if (list? x)
-                            x
-                            (list x #f)))
-                      BINDINGS)))
-    `(,let-type ,(map proc bindings) ,@BODY)))
-
-(define (let-optional-template REST-ARG BINDINGS BODY let-type)
-    (if (null? BINDINGS)
-       `(let () ,@BODY)
-       (let-o-k-template REST-ARG BINDINGS BODY let-type
-                         (lambda (optional)
-                           `(,(car optional)
-                             (cond
-                              ((not (null? ,REST-ARG))
-                               (let ((result (car ,REST-ARG)))
-                                 ,(list 'set! REST-ARG
-                                        `(cdr ,REST-ARG))
-                                 result))
-                              (else
-                               ,(cadr optional))))))))
-
-(define (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY let-type)
-    (if (null? BINDINGS)
-       `(let () ,@BODY)
-       (let* ((kb-list-gensym (gensym "kb:G"))
-              (bindfilter (lambda (key)
-                            `(,(car key)
-                              (cond
-                               ((assq ',(car key) ,kb-list-gensym)
-                                => cdr)
-                               (else
-                                ,(cadr key)))))))
-         `(let ((,kb-list-gensym (;;(@@ (ice-9 optargs) 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)
-      '()
-      (let loop ((first (car rest-arg))
-                (rest (cdr rest-arg))
-                (accum '()))
-       (let ((next (lambda (a)
-                     (if (null? (cdr rest))
-                         a
-                         (loop (cadr rest) (cddr rest) a)))))
-         (if (keyword? first)
-             (cond
-              ((memq first keywords)
-               (if (null? rest)
-                    (error "Keyword argument has no value:" first)
-                   (next (cons (cons (keyword->symbol first)
-                                     (car rest)) accum))))
-              ((not allow-other-keys?)
-                (error "Unknown keyword in arguments:" first))
-              (else (if (null? rest)
-                        accum
-                        (next accum))))
-             (if (null? rest)
-                 accum
-                 (loop (car rest) (cdr rest) accum)))))))
-
-
-;; lambda* args . body
-;;   lambda extended for optional and keyword arguments
-;;
-;; lambda* creates a procedure that takes optional arguments. These
-;; are specified by putting them inside brackets at the end of the
-;; paramater list, but before any dotted rest argument. For example,
-;;   (lambda* (a b #:optional c d . e) '())
-;; creates a procedure with fixed arguments a and b, optional arguments c
-;; and d, and rest argument e. If the optional arguments are omitted
-;; in a call, the variables for them are bound to `#f'.
-;;
-;; lambda* can also take keyword arguments. For example, a procedure
-;; defined like this:
-;;   (lambda* (#:key xyzzy larch) '())
-;; can be called with any of the argument lists (#:xyzzy 11)
-;; (#:larch 13) (#:larch 42 #:xyzzy 19) (). Whichever arguments
-;; are given as keywords are bound to values.
-;;
-;; Optional and keyword arguments can also be given default values
-;; which they take on when they are not present in a call, by giving a
-;; two-item list in place of an optional argument, for example in:
-;;   (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz))
-;; foo is a fixed argument, bar is an optional argument with default
-;; value 42, and baz is a keyword argument with default value 73.
-;; Default value expressions are not evaluated unless they are needed
-;; and until the procedure is called.
-;;
-;; lambda* now supports two more special parameter list keywords.
-;;
-;; lambda*-defined procedures now throw an error by default if a
-;; keyword other than one of those specified is found in the actual
-;; passed arguments. However, specifying #:allow-other-keys
-;; immediately after the keyword argument declarations restores the
-;; previous behavior of ignoring unknown keywords. lambda* also now
-;; guarantees that if the same keyword is passed more than once, the
-;; last one passed is the one that takes effect. For example,
-;;   ((lambda* (#:key (heads 0) (tails 0)) (display (list heads tails)))
-;;    #:heads 37 #:tails 42 #:heads 99)
-;; would result in (99 47) being displayed.
-;;
-;; #:rest is also now provided as a synonym for the dotted syntax rest
-;; argument. The argument lists (a . b) and (a #:rest b) are equivalent in
-;; all respects to lambda*. This is provided for more similarity to DSSSL,
-;; MIT-Scheme and Kawa among others, as well as for refugees from other
-;; Lisp dialects.
-
-
-(defmacro lambda* (ARGLIST . BODY)
-  (parse-arglist
-   ARGLIST
-   (lambda (non-optional-args optionals keys aok? rest-arg)
-     ;; Check for syntax errors.
-     (if (not (every? symbol? non-optional-args))
-        (error "Syntax error in fixed argument declaration."))
-     (if (not (every? ext-decl? optionals))
-        (error "Syntax error in optional argument declaration."))
-     (if (not (every? ext-decl? keys))
-        (error "Syntax error in keyword argument declaration."))
-     (if (not (or (symbol? rest-arg) (eq? #f rest-arg)))
-        (error "Syntax error in rest argument declaration."))
-     ;; generate the code.
-     (let ((rest-gensym (or rest-arg (gensym "lambda*:G")))
-          (lambda-gensym (gensym "lambda*:L")))
-       (if (not (and (null? optionals) (null? keys)))
-          `(let ((,lambda-gensym
-                  (lambda (,@non-optional-args . ,rest-gensym)
-                    ;; Make sure that if the proc had a docstring, we put it
-                    ;; here where it will be visible.
-                    ,@(if (and (not (null? BODY))
-                               (string? (car BODY)))
-                          (list (car BODY))
-                          '())
-                    (let-optional*
-                     ,rest-gensym
-                     ,optionals
-                     (let-keywords* ,rest-gensym
-                                    ,aok?
-                                    ,keys
-                                    ,@(if (and (not rest-arg) (null? keys))
-                                          `((if (not (null? ,rest-gensym))
-                                                (error "Too many arguments.")))
-                                          '())
-                                    (let ()
-                                      ,@BODY))))))
-             (set-procedure-property! ,lambda-gensym 'arglist
-                                      '(,non-optional-args
-                                        ,optionals
-                                        ,keys
-                                        ,aok?
-                                        ,rest-arg))
-             ,lambda-gensym)
-          `(lambda (,@non-optional-args . ,(if rest-arg rest-arg '()))
-             ,@BODY))))))
-
-
-(define (every? pred lst)
-  (or (null? lst)
-      (and (pred (car lst))
-          (every? pred (cdr lst)))))
-
-(define (ext-decl? obj)
-  (or (symbol? obj)
-      (and (list? obj) (= 2 (length obj)) (symbol? (car obj)))))
-
-;; XXX - not tail recursive
-(define (improper-list-copy obj)
-  (if (pair? obj)
-      (cons (car obj) (improper-list-copy (cdr obj)))
-      obj))
-
-(define (parse-arglist arglist cont)
-  (define (split-list-at val lst cont)
-    (cond
-     ((memq val lst)
-      => (lambda (pos)
-          (if (memq val (cdr pos))
-              (error (with-output-to-string
-                       (lambda ()
-                         (map display `(,val
-                                        " specified more than once in argument list.")))))
-              (cont (reverse (cdr (memq val (reverse lst)))) (cdr pos) #t))))
-     (else (cont lst '() #f))))
-  (define (parse-opt-and-fixed arglist keys aok? rest cont)
-    (split-list-at
-     #:optional arglist
-     (lambda (before after split?)
-       (if (and split? (null? after))
-          (error "#:optional specified but no optional arguments declared.")
-          (cont before after keys aok? rest)))))
-  (define (parse-keys arglist rest cont)
-    (split-list-at
-     #:allow-other-keys arglist
-     (lambda (aok-before aok-after aok-split?)
-       (if (and aok-split? (not (null? aok-after)))
-          (error "#:allow-other-keys not at end of keyword argument declarations.")
-          (split-list-at
-           #:key aok-before
-           (lambda (key-before key-after key-split?)
-             (cond
-              ((and aok-split? (not key-split?))
-               (error "#:allow-other-keys specified but no keyword arguments declared."))
-              (key-split?
-               (cond
-                ((null? key-after) (error "#:key specified but no keyword arguments declared."))
-                ((memq #:optional key-after) (error "#:optional arguments declared after #:key arguments."))
-                (else (parse-opt-and-fixed key-before key-after aok-split? rest cont))))
-              (else (parse-opt-and-fixed arglist '() #f rest cont)))))))))
-  (define (parse-rest arglist cont)
-    (cond
-     ((null? arglist) (cont '() '() '() #f #f))
-     ((not (pair? arglist)) (cont '() '() '() #f arglist))
-     ((not (list? arglist))
-         (let* ((copy (improper-list-copy arglist))
-                (lp (last-pair copy))
-                (ra (cdr lp)))
-           (set-cdr! lp '())
-           (if (memq #:rest copy)
-               (error "Cannot specify both #:rest and dotted rest argument.")
-               (parse-keys copy ra cont))))
-     (else (split-list-at
-           #:rest arglist
-           (lambda (before after split?)
-             (if split?
-                 (case (length after)
-                   ((0) (error "#:rest not followed by argument."))
-                   ((1) (parse-keys before (car after) cont))
-                   (else (error "#:rest argument must be declared last.")))
-                 (parse-keys before #f cont)))))))
-
-  (parse-rest arglist cont))
-
-
-
-;; define* args . body
-;; define*-public args . body
-;;   define and define-public extended for optional and keyword arguments
-;;
-;; define* and define*-public support optional arguments with
-;; a similar syntax to lambda*. They also support arbitrary-depth
-;; currying, just like Guile's define. Some examples:
-;;   (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u)))
-;; defines a procedure x with a fixed argument y, an optional agument
-;; a, another optional argument z with default value 3, a keyword argument w,
-;; and a rest argument u.
-;;   (define-public* ((foo #:optional bar) #:optional baz) '())
-;; This illustrates currying. A procedure foo is defined, which,
-;; when called with an optional argument bar, returns a procedure that
-;; takes an optional argument baz.
-;;
-;; Of course, define*[-public] also supports #:rest and #:allow-other-keys
-;; in the same way as lambda*.
-
-(defmacro define* (ARGLIST . BODY)
-  (define*-guts 'define ARGLIST BODY))
-
-(defmacro define*-public (ARGLIST . BODY)
-  (define*-guts 'define-public ARGLIST BODY))
-
-;; The guts of define* and define*-public.
-(define (define*-guts DT ARGLIST BODY)
-  (define (nest-lambda*s arglists)
-    (if (null? arglists)
-        BODY
-        `((lambda* ,(car arglists) ,@(nest-lambda*s (cdr arglists))))))
-  (define (define*-guts-helper ARGLIST arglists)
-    (let ((first (car ARGLIST))
-         (al (cons (cdr ARGLIST) arglists)))
-      (if (symbol? first)
-         `(,DT ,first ,@(nest-lambda*s al))
-         (define*-guts-helper first al))))
-  (if (symbol? ARGLIST)
-      `(,DT ,ARGLIST ,@BODY)
-      (define*-guts-helper ARGLIST '())))
-
-
-
-;; defmacro* name args . body
-;; defmacro*-public args . body
-;;   defmacro and defmacro-public extended for optional and keyword arguments
-;;
-;; These are just like defmacro and defmacro-public except that they
-;; take lambda*-style extended paramter lists, where #:optional,
-;; #:key, #:allow-other-keys and #:rest are allowed with the usual
-;; semantics. Here is an example of a macro with an optional argument:
-;;   (defmacro* transmorgify (a #:optional b)
-
-(defmacro defmacro* (NAME ARGLIST . BODY)
-  `(define-macro ,NAME #f (lambda* ,ARGLIST ,@BODY)))
-
-(defmacro defmacro*-public (NAME ARGLIST . BODY)
-  `(begin
-     (defmacro* ,NAME ,ARGLIST ,@BODY)
-     (export-syntax ,NAME)))
-
-;;; Support for optional & keyword args with the interpreter.
-(define *uninitialized* (list 'uninitialized))
-(define (parse-lambda-case spec inits predicate args)
-  (pmatch spec
-    ((,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
-     (define (req args prev tail n)
-       (cond
-        ((zero? n)
-         (if prev (set-cdr! prev '()))
-         (let ((slots-tail (make-list (- nargs nreq) *uninitialized*)))
-           (opt (if prev (append! args slots-tail) slots-tail)
-                slots-tail tail nopt inits)))
-        ((null? tail)
-         #f) ;; fail
-        (else
-         (req args tail (cdr tail) (1- n)))))
-     (define (opt slots slots-tail args-tail n inits)
-       (cond
-        ((zero? n)
-         (rest-or-key slots slots-tail args-tail inits rest-idx))
-        ((null? args-tail)
-         (set-car! slots-tail (apply (car inits) slots))
-         (opt slots (cdr slots-tail) '() (1- n) (cdr inits)))
-        (else
-         (set-car! slots-tail (car args-tail))
-         (opt slots (cdr slots-tail) (cdr args-tail) (1- n) (cdr inits)))))
-     (define (rest-or-key slots slots-tail args-tail inits rest-idx)
-       (cond
-        (rest-idx
-         ;; it has to be this way, vars are allocated in this order
-         (set-car! slots-tail args-tail)
-         (if (pair? kw-indices)
-             (key slots (cdr slots-tail) args-tail inits)
-             (rest-or-key slots (cdr slots-tail) '() inits #f)))
-        ((pair? kw-indices)
-         ;; fail early here, because once we're in keyword land we throw
-         ;; errors instead of failing
-         (and (or (null? args-tail) rest-idx (keyword? (car args-tail)))
-              (key slots slots-tail args-tail inits)))
-        ((pair? args-tail)
-         #f) ;; fail
-        (else
-         (pred slots))))
-     (define (key slots slots-tail args-tail inits)
-       (cond
-        ((null? args-tail)
-         (if (null? inits)
-             (pred slots)
-             (begin
-               (if (eq? (car slots-tail) *uninitialized*)
-                   (set-car! slots-tail (apply (car inits) slots)))
-               (key slots (cdr slots-tail) '() (cdr inits)))))
-        ((not (keyword? (car args-tail)))
-         (if rest-idx
-             ;; no error checking, everything goes to the rest..
-             (key slots slots-tail '() inits)
-             (error "bad keyword argument list" args-tail)))
-        ((and (keyword? (car args-tail))
-              (pair? (cdr args-tail))
-              (assq-ref kw-indices (car args-tail)))
-         => (lambda (i)
-              (list-set! slots i (cadr args-tail))
-              (key slots slots-tail (cddr args-tail) inits)))
-        ((and (keyword? (car args-tail))
-              (pair? (cdr args-tail))
-              allow-other-keys?)
-         (key slots slots-tail (cddr args-tail) inits))
-        (else (error "unrecognized keyword" args-tail))))
-     (define (pred slots)
-       (cond
-        (predicate
-         (if (apply predicate slots)
-             slots
-             #f))
-        (else slots)))
-     (let ((args (list-copy args)))
-       (req args #f args nreq)))
-    (else (error "unexpected spec" spec))))
index 740a358f6eef081738a23024d4d8b8cb456d6dab..25dcb2fa3f3f4befd00763a00f3852003c727664 100644 (file)
 \f
 ;;; Keywords
 (define (keyword->symbol s)
-  (list->symbol (keyword->list s)))
+  (string->symbol (keyword->string s)))
 
 \f
 ;;; Characters
index 0a0159948a2c269e290b3b1fecf821cbfb7a9653..e81868fdfbf69a3e663186b64d21c3cca0337204 100644 (file)
@@ -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)))
 (define (vector? x)
   (eq? (core:type x) <cell:vector>))
 
-;; Non-types
-;; In core
-;; (define (null? x)
-;;   (eq? x '()))
+(define (broken-heart? x)
+  (eq? (core:type x) <cell:broken-heart>))
 
 (define (atom? x)
   (not (pair? x)))
 \f
 ;;; core: accessors
 (define (string . lst)
-  (core:make-cell <cell:string> lst 0))
-
-(define (string->symbol s)
-  (if (not (pair? (core:car s))) '()
-      (list->symbol (core:car s))))
+  (list->string lst))
 
-(define (symbol->keyword s)
-  (core:make-cell <cell:keyword> (symbol->list s) 0))
+(define (keyword->list s)
+  (string->list (keyword->string s)))
 
 (define (symbol->list s)
-  (core:car s))
-
-(define (keyword->list s)
-  (core:car s))
+  (string->list (symbol->string s)))
 
 (define (integer->char x)
   (core:make-cell <cell:char> 0 x))
index 2735cfcc2046d71a1c50dffa60430bdd7111c1ff..dfd1c545c92848df9c8dfa0a4ddde3336d52257e 100644 (file)
 (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)))
index eaa9337af5ac50c3eb3a14da764f056f79106a35..71e0443892e08c1faf42b26e61c7b957f2047f08 100644 (file)
@@ -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.
-;;;
-;;; 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/>.
-
-;;; From Guile-1.8
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 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
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser 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
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
 ;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
 ;;;                      (regexps removed by Jan (janneke) Nieuwenhuizen)
index d6518c85b71d9d54435ea3d5fdce09740c2f658c..9c60077df7217925b607732c601bc34022f18f18 100644 (file)
@@ -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?)
index c3dae084ef38a909d7d6eba79b1b001288d7583e..386476debefbe08002f8b4b284fb9b7ecfd76b6f 100644 (file)
   (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)
diff --git a/module/mes/optargs.scm b/module/mes/optargs.scm
new file mode 100644 (file)
index 0000000..148c986
--- /dev/null
@@ -0,0 +1,499 @@
+;;;; optargs.scm -- support for optional arguments
+;;;;
+;;;;   Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by 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
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser 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
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+;;;; Contributed by Maciej Stachowiak <mstachow@alum.mit.edu>
+
+\f
+
+;;; Commentary:
+
+;;; {Optional Arguments}
+;;;
+;;; The C interface for creating Guile procedures has a very handy
+;;; "optional argument" feature. This module attempts to provide
+;;; similar functionality for procedures defined in Scheme with
+;;; a convenient and attractive syntax.
+;;;
+;;; exported macros are:
+;;;   let-optional
+;;;   let-optional*
+;;;   let-keywords
+;;;   let-keywords*
+;;;   lambda*
+;;;   define*
+;;;   define*-public
+;;;   defmacro*
+;;;   defmacro*-public
+;;;
+;;;
+;;; Summary of the lambda* extended parameter list syntax (brackets
+;;; are used to indicate grouping only):
+;;;
+;;; ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]?
+;;;   [#:key [ext-var-decl]+ [#:allow-other-keys]?]?
+;;;   [[#:rest identifier]|[. identifier]]?
+;;;
+;;; ext-var-decl ::= identifier | ( identifier expression )
+;;;
+;;; The characters `*', `+' and `?' are not to be taken literally; they
+;;; mean respectively, zero or more occurences, one or more occurences,
+;;; and one or zero occurences.
+;;;
+
+;;; Code:
+
+(define-module (mes optargs)
+  #:use-module (system base pmatch)
+  #:replace (lambda*)
+  #:export-syntax (let-optional
+                 let-optional*
+                 let-keywords
+                 let-keywords*
+                 define*
+                  define*-public
+                 defmacro*
+                 defmacro*-public))
+
+;; let-optional rest-arg (binding ...) . body
+;; let-optional* rest-arg (binding ...) . body
+;;   macros used to bind optional arguments
+;;
+;; These two macros give you an optional argument interface that is
+;; very "Schemey" and introduces no fancy syntax. They are compatible
+;; with the scsh macros of the same name, but are slightly
+;; extended. Each of binding may be of one of the forms <var> or
+;; (<var> <default-value>). rest-arg should be the rest-argument of
+;; the procedures these are used from. The items in rest-arg are
+;; sequentially bound to the variable namess are given. When rest-arg
+;; runs out, the remaining vars are bound either to the default values
+;; or to `#f' if no default value was specified. rest-arg remains
+;; bound to whatever may have been left of rest-arg.
+;;
+
+(defmacro let-optional (REST-ARG BINDINGS . BODY)
+  (let-optional-template REST-ARG BINDINGS BODY 'let))
+
+(defmacro let-optional* (REST-ARG BINDINGS . BODY)
+  (let-optional-template REST-ARG BINDINGS BODY 'let*))
+
+
+
+;; let-keywords rest-arg allow-other-keys? (binding ...) . body
+;; let-keywords* rest-arg allow-other-keys? (binding ...) . body
+;;   macros used to bind keyword arguments
+;;
+;; These macros pick out keyword arguments from rest-arg, but do not
+;; modify it. This is consistent at least with Common Lisp, which
+;; duplicates keyword args in the rest arg. More explanation of what
+;; keyword arguments in a lambda list look like can be found below in
+;; the documentation for lambda*.  Bindings can have the same form as
+;; for let-optional. If allow-other-keys? is false, an error will be
+;; thrown if anything that looks like a keyword argument but does not
+;; match a known keyword parameter will result in an error.
+;;
+
+
+(defmacro let-keywords (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
+  (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let))
+
+(defmacro let-keywords* (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
+  (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let*))
+
+
+;; some utility procedures for implementing the various let-forms.
+
+(define (let-o-k-template REST-ARG BINDINGS BODY let-type proc)
+  (let ((bindings (map (lambda (x)
+                        (if (list? x)
+                            x
+                            (list x #f)))
+                      BINDINGS)))
+    `(,let-type ,(map proc bindings) ,@BODY)))
+
+(define (let-optional-template REST-ARG BINDINGS BODY let-type)
+    (if (null? BINDINGS)
+       `(let () ,@BODY)
+       (let-o-k-template REST-ARG BINDINGS BODY let-type
+                         (lambda (optional)
+                           `(,(car optional)
+                             (cond
+                              ((not (null? ,REST-ARG))
+                               (let ((result (car ,REST-ARG)))
+                                 ,(list 'set! REST-ARG
+                                        `(cdr ,REST-ARG))
+                                 result))
+                              (else
+                               ,(cadr optional))))))))
+
+(define (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY let-type)
+    (if (null? BINDINGS)
+       `(let () ,@BODY)
+       (let* ((kb-list-gensym (gensym "kb:G"))
+              (bindfilter (lambda (key)
+                            `(,(car key)
+                              (cond
+                               ((assq ',(car key) ,kb-list-gensym)
+                                => cdr)
+                               (else
+                                ,(cadr key)))))))
+         `(let ((,kb-list-gensym ((if (not mes?) (@@ (mes optargs) 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)
+      '()
+      (let loop ((first (car rest-arg))
+                (rest (cdr rest-arg))
+                (accum '()))
+       (let ((next (lambda (a)
+                     (if (null? (cdr rest))
+                         a
+                         (loop (cadr rest) (cddr rest) a)))))
+         (if (keyword? first)
+             (cond
+              ((memq first keywords)
+               (if (null? rest)
+                    (error "Keyword argument has no value:" first)
+                   (next (cons (cons (keyword->symbol first)
+                                     (car rest)) accum))))
+              ((not allow-other-keys?)
+                (error "Unknown keyword in arguments:" first))
+              (else (if (null? rest)
+                        accum
+                        (next accum))))
+             (if (null? rest)
+                 accum
+                 (loop (car rest) (cdr rest) accum)))))))
+
+
+;; lambda* args . body
+;;   lambda extended for optional and keyword arguments
+;;
+;; lambda* creates a procedure that takes optional arguments. These
+;; are specified by putting them inside brackets at the end of the
+;; paramater list, but before any dotted rest argument. For example,
+;;   (lambda* (a b #:optional c d . e) '())
+;; creates a procedure with fixed arguments a and b, optional arguments c
+;; and d, and rest argument e. If the optional arguments are omitted
+;; in a call, the variables for them are bound to `#f'.
+;;
+;; lambda* can also take keyword arguments. For example, a procedure
+;; defined like this:
+;;   (lambda* (#:key xyzzy larch) '())
+;; can be called with any of the argument lists (#:xyzzy 11)
+;; (#:larch 13) (#:larch 42 #:xyzzy 19) (). Whichever arguments
+;; are given as keywords are bound to values.
+;;
+;; Optional and keyword arguments can also be given default values
+;; which they take on when they are not present in a call, by giving a
+;; two-item list in place of an optional argument, for example in:
+;;   (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz))
+;; foo is a fixed argument, bar is an optional argument with default
+;; value 42, and baz is a keyword argument with default value 73.
+;; Default value expressions are not evaluated unless they are needed
+;; and until the procedure is called.
+;;
+;; lambda* now supports two more special parameter list keywords.
+;;
+;; lambda*-defined procedures now throw an error by default if a
+;; keyword other than one of those specified is found in the actual
+;; passed arguments. However, specifying #:allow-other-keys
+;; immediately after the keyword argument declarations restores the
+;; previous behavior of ignoring unknown keywords. lambda* also now
+;; guarantees that if the same keyword is passed more than once, the
+;; last one passed is the one that takes effect. For example,
+;;   ((lambda* (#:key (heads 0) (tails 0)) (display (list heads tails)))
+;;    #:heads 37 #:tails 42 #:heads 99)
+;; would result in (99 47) being displayed.
+;;
+;; #:rest is also now provided as a synonym for the dotted syntax rest
+;; argument. The argument lists (a . b) and (a #:rest b) are equivalent in
+;; all respects to lambda*. This is provided for more similarity to DSSSL,
+;; MIT-Scheme and Kawa among others, as well as for refugees from other
+;; Lisp dialects.
+
+
+(defmacro lambda* (ARGLIST . BODY)
+  (parse-arglist
+   ARGLIST
+   (lambda (non-optional-args optionals keys aok? rest-arg)
+     ;; Check for syntax errors.
+     (if (not (every? symbol? non-optional-args))
+        (error "Syntax error in fixed argument declaration."))
+     (if (not (every? ext-decl? optionals))
+        (error "Syntax error in optional argument declaration."))
+     (if (not (every? ext-decl? keys))
+        (error "Syntax error in keyword argument declaration."))
+     (if (not (or (symbol? rest-arg) (eq? #f rest-arg)))
+        (error "Syntax error in rest argument declaration."))
+     ;; generate the code.
+     (let ((rest-gensym (or rest-arg (gensym "lambda*:G")))
+          (lambda-gensym (gensym "lambda*:L")))
+       (if (not (and (null? optionals) (null? keys)))
+          `(let ((,lambda-gensym
+                  (lambda (,@non-optional-args . ,rest-gensym)
+                    ;; Make sure that if the proc had a docstring, we put it
+                    ;; here where it will be visible.
+                    ,@(if (and (not (null? BODY))
+                               (string? (car BODY)))
+                          (list (car BODY))
+                          '())
+                    (let-optional*
+                     ,rest-gensym
+                     ,optionals
+                     (let-keywords* ,rest-gensym
+                                    ,aok?
+                                    ,keys
+                                    ,@(if (and (not rest-arg) (null? keys))
+                                          `((if (not (null? ,rest-gensym))
+                                                (error "Too many arguments.")))
+                                          '())
+                                    (let ()
+                                      ,@BODY))))))
+             (set-procedure-property! ,lambda-gensym 'arglist
+                                      '(,non-optional-args
+                                        ,optionals
+                                        ,keys
+                                        ,aok?
+                                        ,rest-arg))
+             ,lambda-gensym)
+          `(lambda (,@non-optional-args . ,(if rest-arg rest-arg '()))
+             ,@BODY))))))
+
+
+(define (every? pred lst)
+  (or (null? lst)
+      (and (pred (car lst))
+          (every? pred (cdr lst)))))
+
+(define (ext-decl? obj)
+  (or (symbol? obj)
+      (and (list? obj) (= 2 (length obj)) (symbol? (car obj)))))
+
+;; XXX - not tail recursive
+(define (improper-list-copy obj)
+  (if (pair? obj)
+      (cons (car obj) (improper-list-copy (cdr obj)))
+      obj))
+
+(define (parse-arglist arglist cont)
+  (define (split-list-at val lst cont)
+    (cond
+     ((memq val lst)
+      => (lambda (pos)
+          (if (memq val (cdr pos))
+              (error (with-output-to-string
+                       (lambda ()
+                         (map display `(,val
+                                        " specified more than once in argument list.")))))
+              (cont (reverse (cdr (memq val (reverse lst)))) (cdr pos) #t))))
+     (else (cont lst '() #f))))
+  (define (parse-opt-and-fixed arglist keys aok? rest cont)
+    (split-list-at
+     #:optional arglist
+     (lambda (before after split?)
+       (if (and split? (null? after))
+          (error "#:optional specified but no optional arguments declared.")
+          (cont before after keys aok? rest)))))
+  (define (parse-keys arglist rest cont)
+    (split-list-at
+     #:allow-other-keys arglist
+     (lambda (aok-before aok-after aok-split?)
+       (if (and aok-split? (not (null? aok-after)))
+          (error "#:allow-other-keys not at end of keyword argument declarations.")
+          (split-list-at
+           #:key aok-before
+           (lambda (key-before key-after key-split?)
+             (cond
+              ((and aok-split? (not key-split?))
+               (error "#:allow-other-keys specified but no keyword arguments declared."))
+              (key-split?
+               (cond
+                ((null? key-after) (error "#:key specified but no keyword arguments declared."))
+                ((memq #:optional key-after) (error "#:optional arguments declared after #:key arguments."))
+                (else (parse-opt-and-fixed key-before key-after aok-split? rest cont))))
+              (else (parse-opt-and-fixed arglist '() #f rest cont)))))))))
+  (define (parse-rest arglist cont)
+    (cond
+     ((null? arglist) (cont '() '() '() #f #f))
+     ((not (pair? arglist)) (cont '() '() '() #f arglist))
+     ((not (list? arglist))
+         (let* ((copy (improper-list-copy arglist))
+                (lp (last-pair copy))
+                (ra (cdr lp)))
+           (set-cdr! lp '())
+           (if (memq #:rest copy)
+               (error "Cannot specify both #:rest and dotted rest argument.")
+               (parse-keys copy ra cont))))
+     (else (split-list-at
+           #:rest arglist
+           (lambda (before after split?)
+             (if split?
+                 (case (length after)
+                   ((0) (error "#:rest not followed by argument."))
+                   ((1) (parse-keys before (car after) cont))
+                   (else (error "#:rest argument must be declared last.")))
+                 (parse-keys before #f cont)))))))
+
+  (parse-rest arglist cont))
+
+
+
+;; define* args . body
+;; define*-public args . body
+;;   define and define-public extended for optional and keyword arguments
+;;
+;; define* and define*-public support optional arguments with
+;; a similar syntax to lambda*. They also support arbitrary-depth
+;; currying, just like Guile's define. Some examples:
+;;   (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u)))
+;; defines a procedure x with a fixed argument y, an optional agument
+;; a, another optional argument z with default value 3, a keyword argument w,
+;; and a rest argument u.
+;;   (define-public* ((foo #:optional bar) #:optional baz) '())
+;; This illustrates currying. A procedure foo is defined, which,
+;; when called with an optional argument bar, returns a procedure that
+;; takes an optional argument baz.
+;;
+;; Of course, define*[-public] also supports #:rest and #:allow-other-keys
+;; in the same way as lambda*.
+
+(defmacro define* (ARGLIST . BODY)
+  (define*-guts 'define ARGLIST BODY))
+
+(defmacro define*-public (ARGLIST . BODY)
+  (define*-guts 'define-public ARGLIST BODY))
+
+;; The guts of define* and define*-public.
+(define (define*-guts DT ARGLIST BODY)
+  (define (nest-lambda*s arglists)
+    (if (null? arglists)
+        BODY
+        `((lambda* ,(car arglists) ,@(nest-lambda*s (cdr arglists))))))
+  (define (define*-guts-helper ARGLIST arglists)
+    (let ((first (car ARGLIST))
+         (al (cons (cdr ARGLIST) arglists)))
+      (if (symbol? first)
+         `(,DT ,first ,@(nest-lambda*s al))
+         (define*-guts-helper first al))))
+  (if (symbol? ARGLIST)
+      `(,DT ,ARGLIST ,@BODY)
+      (define*-guts-helper ARGLIST '())))
+
+
+
+;; defmacro* name args . body
+;; defmacro*-public args . body
+;;   defmacro and defmacro-public extended for optional and keyword arguments
+;;
+;; These are just like defmacro and defmacro-public except that they
+;; take lambda*-style extended paramter lists, where #:optional,
+;; #:key, #:allow-other-keys and #:rest are allowed with the usual
+;; semantics. Here is an example of a macro with an optional argument:
+;;   (defmacro* transmorgify (a #:optional b)
+
+(defmacro defmacro* (NAME ARGLIST . BODY)
+  `(define-macro ,NAME #f (lambda* ,ARGLIST ,@BODY)))
+
+(defmacro defmacro*-public (NAME ARGLIST . BODY)
+  `(begin
+     (defmacro* ,NAME ,ARGLIST ,@BODY)
+     (export-syntax ,NAME)))
+
+;;; Support for optional & keyword args with the interpreter.
+(define *uninitialized* (list 'uninitialized))
+(define (parse-lambda-case spec inits predicate args)
+  (pmatch spec
+    ((,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
+     (define (req args prev tail n)
+       (cond
+        ((zero? n)
+         (if prev (set-cdr! prev '()))
+         (let ((slots-tail (make-list (- nargs nreq) *uninitialized*)))
+           (opt (if prev (append! args slots-tail) slots-tail)
+                slots-tail tail nopt inits)))
+        ((null? tail)
+         #f) ;; fail
+        (else
+         (req args tail (cdr tail) (1- n)))))
+     (define (opt slots slots-tail args-tail n inits)
+       (cond
+        ((zero? n)
+         (rest-or-key slots slots-tail args-tail inits rest-idx))
+        ((null? args-tail)
+         (set-car! slots-tail (apply (car inits) slots))
+         (opt slots (cdr slots-tail) '() (1- n) (cdr inits)))
+        (else
+         (set-car! slots-tail (car args-tail))
+         (opt slots (cdr slots-tail) (cdr args-tail) (1- n) (cdr inits)))))
+     (define (rest-or-key slots slots-tail args-tail inits rest-idx)
+       (cond
+        (rest-idx
+         ;; it has to be this way, vars are allocated in this order
+         (set-car! slots-tail args-tail)
+         (if (pair? kw-indices)
+             (key slots (cdr slots-tail) args-tail inits)
+             (rest-or-key slots (cdr slots-tail) '() inits #f)))
+        ((pair? kw-indices)
+         ;; fail early here, because once we're in keyword land we throw
+         ;; errors instead of failing
+         (and (or (null? args-tail) rest-idx (keyword? (car args-tail)))
+              (key slots slots-tail args-tail inits)))
+        ((pair? args-tail)
+         #f) ;; fail
+        (else
+         (pred slots))))
+     (define (key slots slots-tail args-tail inits)
+       (cond
+        ((null? args-tail)
+         (if (null? inits)
+             (pred slots)
+             (begin
+               (if (eq? (car slots-tail) *uninitialized*)
+                   (set-car! slots-tail (apply (car inits) slots)))
+               (key slots (cdr slots-tail) '() (cdr inits)))))
+        ((not (keyword? (car args-tail)))
+         (if rest-idx
+             ;; no error checking, everything goes to the rest..
+             (key slots slots-tail '() inits)
+             (error "bad keyword argument list" args-tail)))
+        ((and (keyword? (car args-tail))
+              (pair? (cdr args-tail))
+              (assq-ref kw-indices (car args-tail)))
+         => (lambda (i)
+              (list-set! slots i (cadr args-tail))
+              (key slots slots-tail (cddr args-tail) inits)))
+        ((and (keyword? (car args-tail))
+              (pair? (cdr args-tail))
+              allow-other-keys?)
+         (key slots slots-tail (cddr args-tail) inits))
+        (else (error "unrecognized keyword" args-tail))))
+     (define (pred slots)
+       (cond
+        (predicate
+         (if (apply predicate slots)
+             slots
+             #f))
+        (else slots)))
+     (let ((args (list-copy args)))
+       (req args #f args nreq)))
+    (else (error "unexpected spec" spec))))
index 894c6cc91fc20f39c9b6a48f0a8d9349a0284841..ef53ad747695c22fad7f7d1854acef71fd92f578 100644 (file)
             (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)
           ((#: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))))
index 93f749e78660f3a9a3f9b72483349536ef3ec391..736c8053c5ae212d25d9288b6dacc19c6fe945ab 100644 (file)
         ((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)))))
-                (reg-size (->size "*" info)))
+                (info (append-text info (wrap-as (as info 'value->r value)))))
            (if (or #t (> value 0) (= reg-size 4)) info
                (append-text info (wrap-as (as info 'long-signed-r))))))
 
         ((rshift ,a ,b) ((binop->r info) a b 'r0>>r1))
         ((div ,a ,b)
          ((binop->r info) a b 'r0/r1
-                      (or (signed? (ast->type a info)) (signed? (ast->type b info)))))
+          (or (signed? (ast->type a info)) (signed? (ast->type b info)))))
         ((mod ,a ,b) ((binop->r info) a b 'r0%r1
                       (or (signed? (ast->type a info)) (signed? (ast->type b info)))))
         ((mul ,a ,b) ((binop->r info) a b 'r0*r1))
diff --git a/scaffold/boot/17-equal2.scm b/scaffold/boot/17-equal2.scm
new file mode 100644 (file)
index 0000000..e788e21
--- /dev/null
@@ -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)
diff --git a/scaffold/boot/17-memq-keyword.scm b/scaffold/boot/17-memq-keyword.scm
new file mode 100644 (file)
index 0000000..3114ec5
--- /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 (memq '#:bar '(foo #:bar baz))
+    (exit 0))
+(exit 1)
diff --git a/scaffold/boot/17-memq.scm b/scaffold/boot/17-memq.scm
new file mode 100644 (file)
index 0000000..d071c41
--- /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 (memq 'bar '(foo bar baz))
+    (exit 0))
+(exit 1)
diff --git a/scaffold/boot/17-open-input-string.scm b/scaffold/boot/17-open-input-string.scm
new file mode 100644 (file)
index 0000000..8e2cc7e
--- /dev/null
@@ -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"))
diff --git a/scaffold/boot/17-string-equal.scm b/scaffold/boot/17-string-equal.scm
new file mode 100644 (file)
index 0000000..3e30edb
--- /dev/null
@@ -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)
index 98a28f61ce676feab354f9506b6cfe5296db7207..c6396b78c6039ff88a9e9be22b2fc2689ea21fc5 100644 (file)
 ;;   (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)
diff --git a/scaffold/boot/50-keyword.scm b/scaffold/boot/50-keyword.scm
new file mode 100644 (file)
index 0000000..b670b20
--- /dev/null
@@ -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")
diff --git a/scaffold/boot/50-make-string.scm b/scaffold/boot/50-make-string.scm
new file mode 100644 (file)
index 0000000..bedf7f1
--- /dev/null
@@ -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)
diff --git a/scaffold/boot/50-string-append.scm b/scaffold/boot/50-string-append.scm
new file mode 100644 (file)
index 0000000..48edbea
--- /dev/null
@@ -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)
diff --git a/scaffold/boot/50-string-join.scm b/scaffold/boot/50-string-join.scm
new file mode 100644 (file)
index 0000000..4699ed7
--- /dev/null
@@ -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)
index 2457d75f1d3ada1e237bee3bf76e828820f42e52..50ff9e803a524e12446f923697f9151f2c63130d 100644 (file)
             (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
   (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
index a7150162ece6bd859bfdf5441548e4be84170717..57e55dbfa58f11c71eb7c2efeb4b36db7d977c14 100644 (file)
             (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)
 
   (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))
 
   ))
 
 (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))
index 9cec17fd5477ada67c762d850512db582f8968f5..52049287f44b55bd084ee6a19e2677fca3b0a185 100644 (file)
@@ -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))
 
   (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>))
           (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))))))
index 4710a86aa44ad17aa555f2f07c25d1270bd7d8c2..72f57b044f73d92809c9a5a3c8c1ea88ba9d6caa 100644 (file)
   (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>))
 
index e1366dd1ea416ca652eecfdac1ab572afe33995d..70e5ce040ac6a0b3d0c7d38c0a43dcc778355e3b 100644 (file)
@@ -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 "lib.mes.h"
+#include "src/gc.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 "math.c"
+#include "src/posix.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 "math.mes.i"
+#include "src/posix.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 "lib.mes.environment.i"
+#include "src/gc.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 "reader.mes.environment.i"
-#include "vector.mes.environment.i"
+#include "src/posix.mes.environment.i"
+  //#include "src/reader.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[])
index 4ea84daa7ae2457531f1aa829d70113c4ee6032b..738b49d0ea0a133c2ee7394c0d6de1b28ad1f3cd 100755 (executable)
@@ -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)
index 7dfb5831322e1ca7b0e6539ac547c11666be276d..498bd859167889d71deca3b3b1e85dd970f583a3 100644 (file)
--- a/src/gc.c
+++ b/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
-          || NTYPE (scan) == TKEYWORD
-          || NTYPE (scan) == TMACRO
+      if (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 ();
index f2dee09c8857073c292fa1e86d18e7bcfcf5c23c..ab963c3801989802ef74e6a69768347fb22cc20f 100644 (file)
@@ -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;
-  if (TYPE (CDR (lst)) == TPAIR && TYPE (CADR (lst)) == TCHAR)
-    hash = hash + VALUE (CADR (lst)) * 43;
+  int hash = s[0] * 37;
+  if (s[0] && s[1])
+    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
-  error (cell_symbol_system_error, cons (MAKE_STRING (cstring_to_list ("hashq_: not a symbol")), x));
+    return hash_cstring (CSTRING (x), size);  // FIXME: hash x directly
+  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);
 }
index 3dd6dd3548ce50e8020f48e63ef816cc679709fa..e16dc653f4c3251b6b073b22f70f007f6009e003 100644 (file)
--- a/src/lib.c
+++ b/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);
-          else if (v == '\a') fdputs ("alarm", fd);
-          else if (v == '\b') fdputs ("backspace", fd);
-          else if (v == '\t') fdputs ("tab", fd);
-          else if (v == '\n') fdputs ("newline", fd);
-          else if (v == '\v') fdputs ("vtab", fd);
-          else if (v == '\f') fdputs ("page", fd);
+          if (v == '\0') fdputs ("\\nul", fd);
+          else if (v == '\a') fdputs ("\\alarm", fd);
+          else if (v == '\b') fdputs ("\\backspace", fd);
+          else if (v == '\t') fdputs ("\\tab", fd);
+          else if (v == '\n') fdputs ("\\newline", fd);
+          else if (v == '\v') fdputs ("\\vtab", 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 == ' ') fdputs ("space", fd);
-          else fdputc (VALUE (x), fd);
+          else if (v == 13) fdputs ("\\return", fd);
+          else if (v == ' ') fdputs ("\\space", 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);
-      while (t && t != cell_nil)
+      char const *s = CSTRING (x);
+#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);
-          t = CDR (t);
+          else fdputc (s[i], fd);
         }
-      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 && v != STRING (CAR (a)))
+        while (a != cell_nil
+               && (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)
-    {
-      a = STRING (a);
-      b = STRING (b);
-      goto equal2;
-    }
+    return string_equal_p (a, b);
   if (TYPE (a) == TVECTOR && TYPE (b) == TVECTOR)
     {
       if (LENGTH (a) != LENGTH (b))
index 48a91e2466bb4e521a13caea28dc31f5e3e01d36..e1752c9470fae3dd07d6d5014f047c44b0b9790f 100644 (file)
--- a/src/mes.c
+++ b/src/mes.c
@@ -20,6 +20,7 @@
 
 #include <stdio.h>
 #include <assert.h>
+#include <stdint.h>
 #include <stdlib.h>
 #include <string.h>
 #include <libmes.h>
@@ -62,27 +63,36 @@ SCM m0 = 0;
 SCM g_macros = 0;
 SCM g_ports = 1;
 
+#if __x86_64__
+#define HALFLONG_MAX UINT_MAX
+typedef int halflong;
+#else
+#define HALFLONG_MAX UINT16_MAX
+typedef short halflong;
+#endif
+
 #if __M2_PLANET__
-CONSTANT TCHAR          0
-CONSTANT TCLOSURE       1
-CONSTANT TCONTINUATION  2
-CONSTANT TFUNCTION      3
-CONSTANT TKEYWORD       4
-CONSTANT TMACRO         5
-CONSTANT TNUMBER        6
-CONSTANT TPAIR          7
-CONSTANT TPORT          8
-CONSTANT TREF           9
-CONSTANT TSPECIAL      10
-CONSTANT TSTRING       11
-CONSTANT TSTRUCT       12
-CONSTANT TSYMBOL       13
-CONSTANT TVALUES       14
-CONSTANT TVARIABLE     15
-CONSTANT TVECTOR       16
-CONSTANT TBROKEN_HEART 17
+CONSTANT TBYTES         0
+CONSTANT TCHAR          1
+CONSTANT TCLOSURE       2
+CONSTANT TCONTINUATION  3
+CONSTANT TFUNCTION      4
+CONSTANT TKEYWORD       5
+CONSTANT TMACRO         6
+CONSTANT TNUMBER        7
+CONSTANT TPAIR          8
+CONSTANT TPORT          9
+CONSTANT TREF          10
+CONSTANT TSPECIAL      11
+CONSTANT TSTRING       12
+CONSTANT TSTRUCT       13
+CONSTANT TSYMBOL       14
+CONSTANT TVALUES       15
+CONSTANT TVARIABLE     16
+CONSTANT TVECTOR       17
+CONSTANT TBROKEN_HEART 18
 #else // !__M2_PLANET__
-enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSTRUCT, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
+enum type_t {TBYTES, TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSTRUCT, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
 #endif // !__M2_PLANET__
 
 typedef SCM (*function0_t) (void);
@@ -119,22 +129,32 @@ struct function {
 };
 struct scm {
   enum type_t type;
-  union {
-    char const* name;
+  union
+  {
+#if 0
+    struct
+    {
+      unsigned halflong start;
+      unsigned halflong end;
+    };
+#endif
+    unsigned long function;
+    unsigned long length;
+    long port;
     SCM car;
+    SCM macro;
     SCM ref;
-    SCM string;
     SCM variable;
-    long length;
   };
-  union {
+  union
+  {
     long value;
-    long function;
-    long port;
+    char const* name;
+    char const* bytes;
     SCM cdr;
     SCM closure;
     SCM continuation;
-    SCM macro;
+    SCM string;
     SCM vector;
   };
 };
@@ -150,169 +170,172 @@ struct scm *g_cells = 0;
 struct scm *g_news = 0;
 #endif
 
-struct scm scm_nil = {TSPECIAL, "()",0};
-struct scm scm_f = {TSPECIAL, "#f",0};
-struct scm scm_t = {TSPECIAL, "#t",0};
-struct scm scm_dot = {TSPECIAL, ".",0};
-struct scm scm_arrow = {TSPECIAL, "=>",0};
-struct scm scm_undefined = {TSPECIAL, "*undefined*",0};
-struct scm scm_unspecified = {TSPECIAL, "*unspecified*",0};
-struct scm scm_closure = {TSPECIAL, "*closure*",0};
-struct scm scm_circular = {TSPECIAL, "*circular*",0};
-struct scm scm_begin = {TSPECIAL, "*begin*",0};
-
-struct scm scm_symbol_dot = {TSYMBOL, "*dot*",0};
-struct scm scm_symbol_lambda = {TSYMBOL, "lambda",0};
-struct scm scm_symbol_begin = {TSYMBOL, "begin",0};
-struct scm scm_symbol_if = {TSYMBOL, "if",0};
-struct scm scm_symbol_quote = {TSYMBOL, "quote",0};
-struct scm scm_symbol_define = {TSYMBOL, "define",0};
-struct scm scm_symbol_define_macro = {TSYMBOL, "define-macro",0};
-
-struct scm scm_symbol_quasiquote = {TSYMBOL, "quasiquote", 0};
-struct scm scm_symbol_unquote = {TSYMBOL, "unquote", 0};
-struct scm scm_symbol_unquote_splicing = {TSYMBOL, "unquote-splicing", 0};
-struct scm scm_symbol_syntax = {TSYMBOL, "syntax",0};
-struct scm scm_symbol_quasisyntax = {TSYMBOL, "quasisyntax", 0};
-struct scm scm_symbol_unsyntax = {TSYMBOL, "unsyntax", 0};
-struct scm scm_symbol_unsyntax_splicing = {TSYMBOL, "unsyntax-splicing", 0};
-
-struct scm scm_symbol_set_x = {TSYMBOL, "set!",0};
-
-struct scm scm_symbol_sc_expand = {TSYMBOL, "sc-expand",0};
-struct scm scm_symbol_macro_expand = {TSYMBOL, "macro-expand",0};
-struct scm scm_symbol_portable_macro_expand = {TSYMBOL, "portable-macro-expand",0};
-struct scm scm_symbol_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0};
-
-struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0};
-struct scm scm_call_with_current_continuation = {TSPECIAL, "*call/cc*",0};
-struct scm scm_symbol_call_with_current_continuation = {TSYMBOL, "call-with-current-continuation",0};
-struct scm scm_symbol_boot_module = {TSYMBOL, "boot-module",0};
-struct scm scm_symbol_current_module = {TSYMBOL, "current-module",0};
-struct scm scm_symbol_primitive_load = {TSYMBOL, "primitive-load",0};
-struct scm scm_symbol_read_input_file = {TSYMBOL, "read-input-file",0};
-struct scm scm_symbol_write = {TSYMBOL, "write",0};
-struct scm scm_symbol_display = {TSYMBOL, "display",0};
-
-struct scm scm_symbol_throw = {TSYMBOL, "throw",0};
-struct scm scm_symbol_not_a_number = {TSYMBOL, "not-a-number",0};
-struct scm scm_symbol_not_a_pair = {TSYMBOL, "not-a-pair",0};
-struct scm scm_symbol_system_error = {TSYMBOL, "system-error",0};
-struct scm scm_symbol_wrong_number_of_args = {TSYMBOL, "wrong-number-of-args",0};
-struct scm scm_symbol_wrong_type_arg = {TSYMBOL, "wrong-type-arg",0};
-struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0};
-
-struct scm scm_symbol_hashq_table = {TSYMBOL, "<hashq-table>",0};
-struct scm scm_symbol_record_type = {TSYMBOL, "<record-type>",0};
-struct scm scm_symbol_frame = {TSYMBOL, "<frame>",0};
-struct scm scm_symbol_module = {TSYMBOL, "<module>",0};
-struct scm scm_symbol_stack = {TSYMBOL, "<stack>",0};
-struct scm scm_symbol_buckets = {TSYMBOL, "buckets",0};
-struct scm scm_symbol_procedure = {TSYMBOL, "procedure",0};
-struct scm scm_symbol_size = {TSYMBOL, "size",0};
-
-struct scm scm_symbol_argv = {TSYMBOL, "%argv",0};
-struct scm scm_symbol_mes_prefix = {TSYMBOL, "%prefix",0};
-struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0};
-
-struct scm scm_symbol_car = {TSYMBOL, "car",0};
-struct scm scm_symbol_cdr = {TSYMBOL, "cdr",0};
-struct scm scm_symbol_pmatch_car = {TSYMBOL, "pmatch-car",0};
-struct scm scm_symbol_pmatch_cdr = {TSYMBOL, "pmatch-cdr",0};
-
-struct scm scm_vm_evlis = {TSPECIAL, "*vm-evlis*",0};
-struct scm scm_vm_evlis2 = {TSPECIAL, "*vm-evlis2*",0};
-struct scm scm_vm_evlis3 = {TSPECIAL, "*vm-evlis3*",0};
-struct scm scm_vm_apply = {TSPECIAL, "core:apply",0};
-struct scm scm_vm_apply2 = {TSPECIAL, "*vm-apply2*",0};
-struct scm scm_vm_eval = {TSPECIAL, "core:eval-expanded",0};
-
-struct scm scm_vm_eval_pmatch_car = {TSPECIAL, "*vm-eval-pmatch-car*",0};
-struct scm scm_vm_eval_pmatch_cdr = {TSPECIAL, "*vm-eval-pmatch-cdr*",0};
-struct scm scm_vm_eval_define = {TSPECIAL, "*vm-eval-define*",0};
-
-struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0};
-struct scm scm_vm_eval_macro_expand_eval = {TSPECIAL, "*vm:eval-macro-expand-eval*",0};
-struct scm scm_vm_eval_macro_expand_expand = {TSPECIAL, "*vm:eval-macro-expand-expand*",0};
-struct scm scm_vm_eval_check_func = {TSPECIAL, "*vm-eval-check-func*",0};
-struct scm scm_vm_eval2 = {TSPECIAL, "*vm-eval2*",0};
-struct scm scm_vm_macro_expand = {TSPECIAL, "core:macro-expand",0};
-struct scm scm_vm_macro_expand_define = {TSPECIAL, "*vm:core:macro-expand-define*",0};
-struct scm scm_vm_macro_expand_define_macro = {TSPECIAL, "*vm:core:macro-expand-define-macro*",0};
-struct scm scm_vm_macro_expand_lambda = {TSPECIAL, "*vm:core:macro-expand-lambda*",0};
-struct scm scm_vm_macro_expand_set_x = {TSPECIAL, "*vm:core:macro-expand-set!*",0};
-struct scm scm_vm_begin_expand_primitive_load = {TSPECIAL, "*vm:core:begin-expand-primitive-load*",0};
-struct scm scm_vm_begin_primitive_load = {TSPECIAL, "*vm:core:begin-primitive-load*",0};
-struct scm scm_vm_macro_expand_car = {TSPECIAL, "*vm:core:macro-expand-car*",0};
-struct scm scm_vm_macro_expand_cdr = {TSPECIAL, "*vm:macro-expand-cdr*",0};
-struct scm scm_vm_begin_expand = {TSPECIAL, "core:eval",0};
-struct scm scm_vm_begin_expand_eval = {TSPECIAL, "*vm:begin-expand-eval*",0};
-struct scm scm_vm_begin_expand_macro = {TSPECIAL, "*vm:begin-expand-macro*",0};
-struct scm scm_vm_begin = {TSPECIAL, "*vm-begin*",0};
-struct scm scm_vm_begin_read_input_file = {TSPECIAL, "*vm-begin-read-input-file*",0};
-struct scm scm_vm_begin_eval = {TSPECIAL, "*vm:begin-eval*",0};
-struct scm scm_vm_if = {TSPECIAL, "*vm-if*",0};
-struct scm scm_vm_if_expr = {TSPECIAL, "*vm-if-expr*",0};
-struct scm scm_vm_call_with_values2 = {TSPECIAL, "*vm-call-with-values2*",0};
-struct scm scm_vm_call_with_current_continuation2 = {TSPECIAL, "*vm-call-with-current-continuation2*",0};
-struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0};
-
-struct scm scm_type_char = {TSYMBOL, "<cell:char>",0};
-struct scm scm_type_closure = {TSYMBOL, "<cell:closure>",0};
-struct scm scm_type_continuation = {TSYMBOL, "<cell:continuation>",0};
-struct scm scm_type_function = {TSYMBOL, "<cell:function>",0};
-struct scm scm_type_keyword = {TSYMBOL, "<cell:keyword>",0};
-struct scm scm_type_macro = {TSYMBOL, "<cell:macro>",0};
-struct scm scm_type_number = {TSYMBOL, "<cell:number>",0};
-struct scm scm_type_pair = {TSYMBOL, "<cell:pair>",0};
-struct scm scm_type_port = {TSYMBOL, "<cell:port>",0};
-struct scm scm_type_ref = {TSYMBOL, "<cell:ref>",0};
-struct scm scm_type_special = {TSYMBOL, "<cell:special>",0};
-struct scm scm_type_string = {TSYMBOL, "<cell:string>",0};
-struct scm scm_type_struct = {TSYMBOL, "<cell:struct>",0};
-struct scm scm_type_symbol = {TSYMBOL, "<cell:symbol>",0};
-struct scm scm_type_values = {TSYMBOL, "<cell:values>",0};
-struct scm scm_type_variable = {TSYMBOL, "<cell:variable>",0};
-struct scm scm_type_vector = {TSYMBOL, "<cell:vector>",0};
-struct scm scm_type_broken_heart = {TSYMBOL, "<cell:broken-heart>",0};
-
-struct scm scm_symbol_internal_time_units_per_second = {TSYMBOL, "internal-time-units-per-second",0};
-struct scm scm_symbol_compiler = {TSYMBOL, "%compiler",0};
-struct scm scm_symbol_arch = {TSYMBOL, "%arch",0};
-
-struct scm scm_test = {TSYMBOL, "%%test",0};
-
-#if !_POSIX_SOURCE
-#include "mes.mes.symbols.h"
+struct scm scm_nil = {TSPECIAL, 0, "()"};
+struct scm scm_f = {TSPECIAL, 0, "#f"};
+struct scm scm_t = {TSPECIAL, 0, "#t"};
+struct scm scm_dot = {TSPECIAL, 0, "."};
+struct scm scm_arrow = {TSPECIAL, 0, "=>"};
+struct scm scm_undefined = {TSPECIAL, 0, "*undefined*"};
+struct scm scm_unspecified = {TSPECIAL, 0, "*unspecified*"};
+struct scm scm_closure = {TSPECIAL, 0, "*closure*"};
+struct scm scm_circular = {TSPECIAL, 0, "*circular*"};
+struct scm scm_begin = {TSPECIAL, 0, "*begin*"};
+
+struct scm scm_symbol_dot = {TSYMBOL, 0, "*dot*"};
+struct scm scm_symbol_lambda = {TSYMBOL, 0, "lambda"};
+struct scm scm_symbol_begin = {TSYMBOL, 0, "begin"};
+struct scm scm_symbol_if = {TSYMBOL, 0, "if"};
+struct scm scm_symbol_quote = {TSYMBOL, 0, "quote"};
+struct scm scm_symbol_define = {TSYMBOL, 0, "define"};
+struct scm scm_symbol_define_macro = {TSYMBOL, 0, "define-macro"};
+
+struct scm scm_symbol_quasiquote = {TSYMBOL, 0, "quasiquote"};
+struct scm scm_symbol_unquote = {TSYMBOL, 0, "unquote"};
+struct scm scm_symbol_unquote_splicing = {TSYMBOL, 0, "unquote-splicing"};
+struct scm scm_symbol_syntax = {TSYMBOL, 0, "syntax"};
+struct scm scm_symbol_quasisyntax = {TSYMBOL, 0, "quasisyntax"};
+struct scm scm_symbol_unsyntax = {TSYMBOL, 0, "unsyntax"};
+struct scm scm_symbol_unsyntax_splicing = {TSYMBOL, 0, "unsyntax-splicing"};
+
+struct scm scm_symbol_set_x = {TSYMBOL, 0, "set!"};
+
+struct scm scm_symbol_sc_expand = {TSYMBOL, 0, "sc-expand"};
+struct scm scm_symbol_macro_expand = {TSYMBOL, 0, "macro-expand"};
+struct scm scm_symbol_portable_macro_expand = {TSYMBOL, 0, "portable-macro-expand"};
+struct scm scm_symbol_sc_expander_alist = {TSYMBOL, 0, "*sc-expander-alist*"};
+
+struct scm scm_symbol_call_with_values = {TSYMBOL, 0, "call-with-values"};
+struct scm scm_call_with_current_continuation = {TSPECIAL, 0, "*call/cc*"};
+struct scm scm_symbol_call_with_current_continuation = {TSYMBOL, 0, "call-with-current-continuation"};
+struct scm scm_symbol_boot_module = {TSYMBOL, 0, "boot-module"};
+struct scm scm_symbol_current_module = {TSYMBOL, 0, "current-module"};
+struct scm scm_symbol_primitive_load = {TSYMBOL, 0, "primitive-load"};
+struct scm scm_symbol_read_input_file = {TSYMBOL, 0, "read-input-file"};
+struct scm scm_symbol_write = {TSYMBOL, 0, "write"};
+struct scm scm_symbol_display = {TSYMBOL, 0, "display"};
+
+struct scm scm_symbol_throw = {TSYMBOL, 0, "throw"};
+struct scm scm_symbol_not_a_number = {TSYMBOL, 0, "not-a-number"};
+struct scm scm_symbol_not_a_pair = {TSYMBOL, 0, "not-a-pair"};
+struct scm scm_symbol_system_error = {TSYMBOL, 0, "system-error"};
+struct scm scm_symbol_wrong_number_of_args = {TSYMBOL, 0, "wrong-number-of-args"};
+struct scm scm_symbol_wrong_type_arg = {TSYMBOL, 0, "wrong-type-arg"};
+struct scm scm_symbol_unbound_variable = {TSYMBOL, 0, "unbound-variable"};
+
+struct scm scm_symbol_hashq_table = {TSYMBOL, 0, "<hashq-table>"};
+struct scm scm_symbol_record_type = {TSYMBOL, 0, "<record-type>"};
+struct scm scm_symbol_frame = {TSYMBOL, 0, "<frame>"};
+struct scm scm_symbol_module = {TSYMBOL, 0, "<module>"};
+struct scm scm_symbol_stack = {TSYMBOL, 0, "<stack>"};
+struct scm scm_symbol_buckets = {TSYMBOL, 0, "buckets"};
+struct scm scm_symbol_procedure = {TSYMBOL, 0, "procedure"};
+struct scm scm_symbol_size = {TSYMBOL, 0, "size"};
+
+struct scm scm_symbol_argv = {TSYMBOL, 0, "%argv"};
+struct scm scm_symbol_mes_prefix = {TSYMBOL, 0, "%prefix"};
+struct scm scm_symbol_mes_version = {TSYMBOL, 0, "%version"};
+
+struct scm scm_symbol_car = {TSYMBOL, 0, "car"};
+struct scm scm_symbol_cdr = {TSYMBOL, 0, "cdr"};
+struct scm scm_symbol_pmatch_car = {TSYMBOL, 0, "pmatch-car"};
+struct scm scm_symbol_pmatch_cdr = {TSYMBOL, 0, "pmatch-cdr"};
+
+struct scm scm_vm_evlis = {TSPECIAL, 0, "*vm-evlis*"};
+struct scm scm_vm_evlis2 = {TSPECIAL, 0, "*vm-evlis2*"};
+struct scm scm_vm_evlis3 = {TSPECIAL, 0, "*vm-evlis3*"};
+struct scm scm_vm_apply = {TSPECIAL, 0, "core:apply"};
+struct scm scm_vm_apply2 = {TSPECIAL, 0, "*vm-apply2*"};
+struct scm scm_vm_eval = {TSPECIAL, 0, "core:eval-expanded"};
+
+struct scm scm_vm_eval_pmatch_car = {TSPECIAL, 0, "*vm-eval-pmatch-car*"};
+struct scm scm_vm_eval_pmatch_cdr = {TSPECIAL, 0, "*vm-eval-pmatch-cdr*"};
+struct scm scm_vm_eval_define = {TSPECIAL, 0, "*vm-eval-define*"};
+
+struct scm scm_vm_eval_set_x = {TSPECIAL, 0, "*vm-eval-set!*"};
+struct scm scm_vm_eval_macro_expand_eval = {TSPECIAL, 0, "*vm:eval-macro-expand-eval*"};
+struct scm scm_vm_eval_macro_expand_expand = {TSPECIAL, 0, "*vm:eval-macro-expand-expand*"};
+struct scm scm_vm_eval_check_func = {TSPECIAL, 0, "*vm-eval-check-func*"};
+struct scm scm_vm_eval2 = {TSPECIAL, 0, "*vm-eval2*"};
+struct scm scm_vm_macro_expand = {TSPECIAL, 0, "core:macro-expand"};
+struct scm scm_vm_macro_expand_define = {TSPECIAL, 0, "*vm:core:macro-expand-define*"};
+struct scm scm_vm_macro_expand_define_macro = {TSPECIAL, 0, "*vm:core:macro-expand-define-macro*"};
+struct scm scm_vm_macro_expand_lambda = {TSPECIAL, 0, "*vm:core:macro-expand-lambda*"};
+struct scm scm_vm_macro_expand_set_x = {TSPECIAL, 0, "*vm:core:macro-expand-set!*"};
+struct scm scm_vm_begin_expand_primitive_load = {TSPECIAL, 0, "*vm:core:begin-expand-primitive-load*"};
+struct scm scm_vm_begin_primitive_load = {TSPECIAL, 0, "*vm:core:begin-primitive-load*"};
+struct scm scm_vm_macro_expand_car = {TSPECIAL, 0, "*vm:core:macro-expand-car*"};
+struct scm scm_vm_macro_expand_cdr = {TSPECIAL, 0, "*vm:macro-expand-cdr*"};
+struct scm scm_vm_begin_expand = {TSPECIAL, 0, "core:eval"};
+struct scm scm_vm_begin_expand_eval = {TSPECIAL, 0, "*vm:begin-expand-eval*"};
+struct scm scm_vm_begin_expand_macro = {TSPECIAL, 0, "*vm:begin-expand-macro*"};
+struct scm scm_vm_begin = {TSPECIAL, 0, "*vm-begin*"};
+struct scm scm_vm_begin_read_input_file = {TSPECIAL, 0, "*vm-begin-read-input-file*"};
+struct scm scm_vm_begin_eval = {TSPECIAL, 0, "*vm:begin-eval*"};
+struct scm scm_vm_if = {TSPECIAL, 0, "*vm-if*"};
+struct scm scm_vm_if_expr = {TSPECIAL, 0, "*vm-if-expr*"};
+struct scm scm_vm_call_with_values2 = {TSPECIAL, 0, "*vm-call-with-values2*"};
+struct scm scm_vm_call_with_current_continuation2 = {TSPECIAL, 0, "*vm-call-with-current-continuation2*"};
+struct scm scm_vm_return = {TSPECIAL, 0, "*vm-return*"};
+
+struct scm scm_type_bytes = {TSYMBOL, 0, "<cell:bytes>"};
+struct scm scm_type_char = {TSYMBOL, 0, "<cell:char>"};
+struct scm scm_type_closure = {TSYMBOL, 0, "<cell:closure>"};
+struct scm scm_type_continuation = {TSYMBOL, 0, "<cell:continuation>"};
+struct scm scm_type_function = {TSYMBOL, 0, "<cell:function>"};
+struct scm scm_type_keyword = {TSYMBOL, 0, "<cell:keyword>"};
+struct scm scm_type_macro = {TSYMBOL, 0, "<cell:macro>"};
+struct scm scm_type_number = {TSYMBOL, 0, "<cell:number>"};
+struct scm scm_type_pair = {TSYMBOL, 0, "<cell:pair>"};
+struct scm scm_type_port = {TSYMBOL, 0, "<cell:port>"};
+struct scm scm_type_ref = {TSYMBOL, 0, "<cell:ref>"};
+struct scm scm_type_special = {TSYMBOL, 0, "<cell:special>"};
+struct scm scm_type_string = {TSYMBOL, 0, "<cell:string>"};
+struct scm scm_type_struct = {TSYMBOL, 0, "<cell:struct>"};
+struct scm scm_type_symbol = {TSYMBOL, 0, "<cell:symbol>"};
+struct scm scm_type_values = {TSYMBOL, 0, "<cell:values>"};
+struct scm scm_type_variable = {TSYMBOL, 0, "<cell:variable>"};
+struct scm scm_type_vector = {TSYMBOL, 0, "<cell:vector>"};
+struct scm scm_type_broken_heart = {TSYMBOL, 0, "<cell:broken-heart>"};
+
+struct scm scm_symbol_internal_time_units_per_second = {TSYMBOL, 0, "internal-time-units-per-second"};
+struct scm scm_symbol_compiler = {TSYMBOL, 0, "%compiler"};
+struct scm scm_symbol_arch = {TSYMBOL, 0, "%arch"};
+
+struct scm scm_test = {TSYMBOL, 0, "%%test"};
+
+#if !POSIX
+#include "src/mes.mes.symbols.h"
 #else
-#include "mes.symbols.h"
+#include "src/mes.symbols.h"
 #endif
 
 struct function g_functions[200];
 int g_function = 0;
 
-#if !__GNUC__ || !_POSIX_SOURCE
-#include "gc.mes.h"
-#include "hash.mes.h"
-#include "lib.mes.h"
-#include "math.mes.h"
-#include "mes.mes.h"
-#include "module.mes.h"
-#include "posix.mes.h"
-#include "reader.mes.h"
-#include "struct.mes.h"
-#include "vector.mes.h"
+#if !__GNUC__ || !POSIX
+#include "src/gc.mes.h"
+#include "src/hash.mes.h"
+#include "src/lib.mes.h"
+#include "src/math.mes.h"
+#include "src/mes.mes.h"
+#include "src/module.mes.h"
+#include "src/posix.mes.h"
+#include "src/reader.mes.h"
+#include "src/strings.mes.h"
+#include "src/struct.mes.h"
+#include "src/vector.mes.h"
 #else
-#include "gc.h"
-#include "hash.h"
-#include "lib.h"
-#include "math.h"
-#include "mes.h"
-#include "module.h"
-#include "posix.h"
-#include "reader.h"
-#include "struct.h"
-#include "vector.h"
+#include "src/gc.h"
+#include "src/hash.h"
+#include "src/lib.h"
+#include "src/math.h"
+#include "src/mes.h"
+#include "src/module.h"
+#include "src/posix.h"
+#include "src/reader.h"
+#include "src/strings.h"
+#include "src/struct.h"
+#include "src/vector.h"
 #endif
 
 #define TYPE(x) g_cells[x].type
@@ -323,60 +346,77 @@ int g_function = 0;
 #define NCAR(x) g_news[x].car
 #define NCDR(x) g_news[x].cdr
 
-#if !_POSIX_SOURCE
+#if !POSIX
+#define BYTES(x) g_cells[x].car
 #define LENGTH(x) g_cells[x].car
 #define REF(x) g_cells[x].car
-#define STRING(x) g_cells[x].car
+#define START(x) (g_cells[x].car >> 16)
+#define LEN(x) (g_cells[x].car & 0xffff)
 #define VARIABLE(x) g_cells[x].car
 
 #define CLOSURE(x) g_cells[x].cdr
 #define CONTINUATION(x) g_cells[x].cdr
 
-#define FUNCTION(x) g_functions[g_cells[x].cdr]
-#define FUNCTION0(x) g_functions[g_cells[x].cdr].function
-#define MACRO(x) g_cells[x].cdr
-#define PORT(x) g_cells[x].cdr
+#define CBYTES(x) &g_cells[x].cdr
+#define CSTRING_STRUCT(x) &g_cells[x.cdr].cdr
+
+#define FUNCTION(x) g_functions[g_cells[x].car]
+#define FUNCTION0(x) g_functions[g_cells[x].car].function
+#define MACRO(x) g_cells[x].car
+#define NAME(x) g_cells[x].cdr
+#define PORT(x) g_cells[x].car
+#define STRING(x) g_cells[x].cdr
 #define STRUCT(x) g_cells[x].cdr
 #define VALUE(x) g_cells[x].cdr
 #define VECTOR(x) g_cells[x].cdr
 
 #define NLENGTH(x) g_news[x].car
-
+#define NCBYTES(x) &g_news[x].cdr
 #define NVALUE(x) g_news[x].cdr
+#define NSTRING(x) g_news[x].cdr
 #define NVECTOR(x) g_news[x].cdr
 
 #else
-#define CONTINUATION(x) g_cells[x].cdr
-#define HITS(x) g_cells[x].hits
+#define BYTES(x) g_cells[x].bytes
+#define FUNCTION(x) g_functions[g_cells[x].function]
+#define FUNCTION0(x) g_functions[g_cells[x].function].function0
 #define LENGTH(x) g_cells[x].length
-#define NAME(x) g_cells[x].name
-#define STRING(x) g_cells[x].string
+#define REF(x) g_cells[x].ref
+#define START(x) g_cells[x].start
+#define LEN(x) g_cells[x].end
 #define VARIABLE(x) g_cells[x].variable
 
 #define CLOSURE(x) g_cells[x].closure
+#define CBYTES(x) &g_cells[x].bytes
+#define CSTRING_STRUCT(x) &g_cells[x.string].string
+#define CONTINUATION(x) g_cells[x].continuation
 #define MACRO(x) g_cells[x].macro
+#define NAME(x) g_cells[x].name
 #define PORT(x) g_cells[x].port
-#define REF(x) g_cells[x].ref
+#define STRING(x) g_cells[x].string
 #define STRUCT(x) g_cells[x].vector
 #define VALUE(x) g_cells[x].value
 #define VECTOR(x) g_cells[x].vector
-#define FUNCTION(x) g_functions[g_cells[x].function]
-#define FUNCTION0(x) g_functions[g_cells[x].function].function0
 
 #define NLENGTH(x) g_news[x].length
 
+#define NCBYTES(x) &g_news[x].bytes
 #define NVALUE(x) g_news[x].value
 #define NVECTOR(x) g_news[x].vector
 #endif
 
+#define CSTRING(x) CBYTES (STRING (x))
+
+#define MAKE_BYTES0(x) make_bytes (x, strlen (x))
+#define NAME_SYMBOL(symbol,name) {size_t s = strlen (name); CAR (symbol) = s; CDR (symbol) = make_bytes (name, s);}
+
 #define MAKE_CHAR(n) make_cell__ (TCHAR, 0, n)
 #define MAKE_CONTINUATION(n) make_cell__ (TCONTINUATION, n, g_stack)
 #define MAKE_NUMBER(n) make_cell__ (TNUMBER, 0, n)
 #define MAKE_REF(n) make_cell__ (TREF, n, 0)
-#define MAKE_STRING(x) make_cell__ (TSTRING, x, 0)
-#define MAKE_KEYWORD(x) make_cell__ (TKEYWORD, x, 0)
-#define MAKE_STRING_PORT(x) make_cell__ (TPORT, x, -length__ (g_ports) - 2)
-#define MAKE_MACRO(name, x) make_cell__ (TMACRO, STRING (name), x)
+#define MAKE_STRING0(x) make_string (x, strlen (x))
+#define MAKE_STRING_PORT(x) make_cell__ (TPORT, -length__ (g_ports) - 2, x)
+#define MAKE_MACRO(name, x) make_cell__ (TMACRO, x, STRING (name))
 
 #define CAAR(x) CAR (CAR (x))
 #define CADR(x) CAR (CDR (x))
@@ -386,6 +426,10 @@ int g_function = 0;
 #define CADDR(x) CAR (CDR (CDR (x)))
 #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
 
+SCM make_bytes (char const* s, size_t length);
+SCM cstring_to_list (char const* s);
+SCM string_equal_p (SCM a, SCM b);
+
 SCM
 alloc (long n)
 {
@@ -416,57 +460,45 @@ make_cell_ (SCM type, SCM car, SCM cdr)
   return make_cell__ (t, car, cdr);
 }
 
-SCM
-make_symbol_ (SCM string) ///((internal))
-{
-  SCM x = make_cell__ (TSYMBOL, STRING (string), 0);
-  hash_set_x (g_symbols, string, x);
-
-  if (g_debug > 3)
-    hash_table_printer (g_symbols);
-
-  return x;
-}
-
-SCM
-list_of_char_equal_p (SCM a, SCM b) ///((internal))
-{
-  assert (TYPE (CAR (a)) == TCHAR);
-  if (TYPE (CAR (b)) == TCHAR)
-    while (a != cell_nil && b != cell_nil && VALUE (CAR (a)) == VALUE (CAR (b)))
-      {
-        assert (TYPE (CAR (a)) == TCHAR);
-        assert (TYPE (CAR (b)) == TCHAR);
-        a = CDR (a);
-        b = CDR (b);
-      }
-  return (a == cell_nil && b == cell_nil) ? cell_t : cell_f;
-}
-
 SCM
 assoc_string (SCM x, SCM a) ///((internal))
 {
-  while (a != cell_nil && list_of_char_equal_p (STRING (x), STRING (CAAR (a))) == cell_f)
+  while (a != cell_nil && (TYPE (CAAR (a)) != TSTRING
+                           || string_equal_p (x, CAAR (a)) == cell_f))
     a = CDR (a);
   return a != cell_nil ? CAR (a) : cell_f;
 }
 
-SCM
-list_to_symbol (SCM lst)
-{
-  SCM key = MAKE_STRING (lst);
-  SCM x = hash_ref (g_symbols, key, cell_f);
-  if (x == cell_f)
-    x = make_symbol_ (key);
-  return x;
-}
-
 SCM
 type_ (SCM x)
 {
   return MAKE_NUMBER (TYPE (x));
 }
 
+// SCM
+// car_to_cell_ (SCM x)
+// {
+//   return CAR (x);
+// }
+
+// SCM
+// cdr_to_cell_ (SCM x)
+// {
+//   return CDR (x);
+// }
+
+// SCM
+// car_to_number_ (SCM x)
+// {
+//   return MAKE_NUMBER (CAR (x));
+// }
+
+// SCM
+// cdr_to_number_ (SCM x)
+// {
+//   return MAKE_NUMBER (CDR (x));
+// }
+
 SCM
 car_ (SCM x)
 {
@@ -541,7 +573,7 @@ eq_p (SCM x, SCM y)
 {
   return (x == y
           || ((TYPE (x) == TKEYWORD && TYPE (y) == TKEYWORD
-               && STRING (x) == STRING (y)))
+               && string_equal_p (x, y) == cell_t))
           || (TYPE (x) == TCHAR && TYPE (y) == TCHAR
               && VALUE (x) == VALUE (y))
           || (TYPE (x) == TNUMBER && TYPE (y) == TNUMBER
@@ -601,27 +633,6 @@ error (SCM key, SCM x)
   exit (1);
 }
 
-SCM
-string_to_list (char const* s, long i)
-{
-  SCM p = cell_nil;
-  while (i--)
-    p = cons (MAKE_CHAR (s[i]), p);
-  return p;
-}
-
-SCM
-cstring_to_list (char const* s)
-{
-  return string_to_list (s, strlen (s));
-}
-
-SCM
-cstring_to_symbol (char const *s)
-{
-  return list_to_symbol (cstring_to_list (s));
-}
-
 // \f extra lib
 SCM
 assert_defined (SCM x, SCM e) ///((internal))
@@ -631,6 +642,8 @@ assert_defined (SCM x, SCM e) ///((internal))
   return e;
 }
 
+SCM make_string (char const* s, size_t length);
+
 SCM
 check_formals (SCM f, SCM formals, SCM args) ///((internal))
 {
@@ -645,7 +658,7 @@ check_formals (SCM f, SCM formals, SCM args) ///((internal))
       eputs (itoa (alen));
       eputs ("\n");
       write_error_ (f);
-      SCM e = MAKE_STRING (cstring_to_list (s));
+      SCM e = MAKE_STRING0 (s);
       return error (cell_symbol_wrong_number_of_args, cons (e, f));
     }
   return cell_unspecified;
@@ -682,7 +695,7 @@ check_apply (SCM f, SCM e) ///((internal))
       eputs ("[");
       write_error_ (e);
       eputs ("]\n");
-      SCM e = MAKE_STRING (cstring_to_list (s));
+      SCM e = MAKE_STRING0 (s);
       return error (cell_symbol_wrong_type_arg, cons (e, f));
     }
   return cell_unspecified;
@@ -870,8 +883,7 @@ assq (SCM x, SCM a)
       }
   else if (t == TKEYWORD)
     {
-      SCM v = STRING (x);
-      while (a != cell_nil && v != STRING (CAAR (a)))
+      while (a != cell_nil && string_equal_p (x, CAAR (a)) == cell_f)
         a = CDR (a);
     }
   else
@@ -979,8 +991,6 @@ push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
   return cell_unspecified;
 }
 
-char const* string_to_cstring (SCM s);
-
 SCM
 add_formals (SCM formals, SCM x)
 {
@@ -1139,7 +1149,7 @@ eval_apply ()
   else if (r3 == cell_unspecified) return r1;
   else
     error (cell_symbol_system_error,
-           MAKE_STRING (cstring_to_list ("eval/apply unknown continuation")));
+           MAKE_STRING0 ("eval/apply unknown continuation"));
 
  evlis:
   if (r1 == cell_nil)
@@ -1683,11 +1693,11 @@ mes_g_stack (SCM a) ///((internal))
 
 //\f Environment setup
 
-#include "hash.c"
-#include "module.c"
-#include "posix.c"
-#include "math.c"
-#include "lib.c"
+#include "src/hash.c"
+#include "src/module.c"
+#include "src/posix.c"
+#include "src/math.c"
+#include "src/lib.c"
 
 //\f Jam Collector
 SCM g_symbol_max;
@@ -1776,8 +1786,6 @@ g_cells[cell_symbol_unquote] = scm_symbol_unquote;
 g_free++;
 g_cells[cell_symbol_unquote_splicing] = scm_symbol_unquote_splicing;
 
-
-////// for GC
 g_free++;
 g_cells[cell_symbol_syntax] = scm_symbol_syntax;
 
@@ -1859,12 +1867,21 @@ g_cells[cell_symbol_hashq_table] = scm_symbol_hashq_table;
 g_free++;
 g_cells[cell_symbol_record_type] = scm_symbol_record_type;
 
+g_free++;
+g_cells[cell_symbol_frame] = scm_symbol_frame;
+
 g_free++;
 g_cells[cell_symbol_module] = scm_symbol_module;
 
+g_free++;
+g_cells[cell_symbol_stack] = scm_symbol_stack;
+
 g_free++;
 g_cells[cell_symbol_buckets] = scm_symbol_buckets;
 
+g_free++;
+g_cells[cell_symbol_procedure] = scm_symbol_procedure;
+
 g_free++;
 g_cells[cell_symbol_size] = scm_symbol_size;
 
@@ -1991,6 +2008,66 @@ g_cells[cell_vm_call_with_current_continuation2] = scm_vm_call_with_current_cont
 g_free++;
 g_cells[cell_vm_return] = scm_vm_return;
 
+g_free++;
+g_cells[cell_type_bytes] = scm_type_bytes;
+
+g_free++;
+g_cells[cell_type_char] = scm_type_char;
+
+g_free++;
+g_cells[cell_type_closure] = scm_type_closure;
+
+g_free++;
+g_cells[cell_type_continuation] = scm_type_continuation;
+
+g_free++;
+g_cells[cell_type_function] = scm_type_function;
+
+g_free++;
+g_cells[cell_type_keyword] = scm_type_keyword;
+
+g_free++;
+g_cells[cell_type_macro] = scm_type_macro;
+
+g_free++;
+g_cells[cell_type_number] = scm_type_number;
+
+g_free++;
+g_cells[cell_type_pair] = scm_type_pair;
+
+g_free++;
+g_cells[cell_type_port] = scm_type_port;
+
+g_free++;
+g_cells[cell_type_ref] = scm_type_ref;
+
+g_free++;
+g_cells[cell_type_special] = scm_type_special;
+
+g_free++;
+g_cells[cell_type_string] = scm_type_string;
+
+g_free++;
+g_cells[cell_type_struct] = scm_type_struct;
+
+g_free++;
+g_cells[cell_type_symbol] = scm_type_symbol;
+
+g_free++;
+g_cells[cell_type_values] = scm_type_values;
+
+g_free++;
+g_cells[cell_type_variable] = scm_type_variable;
+
+g_free++;
+g_cells[cell_type_vector] = scm_type_vector;
+
+g_free++;
+g_cells[cell_type_broken_heart] = scm_type_broken_heart;
+
+g_free++;
+g_cells[cell_symbol_internal_time_units_per_second] = scm_symbol_internal_time_units_per_second;
+
 g_free++;
 g_cells[cell_symbol_compiler] = scm_symbol_compiler;
 
@@ -2000,129 +2077,151 @@ g_cells[cell_symbol_arch] = scm_symbol_arch;
 g_free++;
 g_cells[cell_test] = scm_test;
 
-#elif !_POSIX_SOURCE
-#include "mes.mes.symbols.i"
+#elif !POSIX
+#include "src/mes.mes.symbols.i"
 #else
-#include "mes.symbols.i"
+#include "src/mes.symbols.i"
 #endif
 
-  g_symbol_max = g_free++;
+g_symbol_max = g_free++;
 
 #if MES_MINI
 
-g_cells[cell_nil].car = cstring_to_list (scm_nil.car);
-g_cells[cell_f].car = cstring_to_list (scm_f.car);
-g_cells[cell_t].car = cstring_to_list (scm_t.car);
-g_cells[cell_dot].car = cstring_to_list (scm_dot.car);
-g_cells[cell_arrow].car = cstring_to_list (scm_arrow.car);
-g_cells[cell_undefined].car = cstring_to_list (scm_undefined.car);
-g_cells[cell_unspecified].car = cstring_to_list (scm_unspecified.car);
-g_cells[cell_closure].car = cstring_to_list (scm_closure.car);
-g_cells[cell_circular].car = cstring_to_list (scm_circular.car);
-g_cells[cell_begin].car = cstring_to_list (scm_begin.car);
-g_cells[cell_symbol_dot].car = cstring_to_list (scm_symbol_dot.car);
-g_cells[cell_symbol_lambda].car = cstring_to_list (scm_symbol_lambda.car);
-g_cells[cell_symbol_begin].car = cstring_to_list (scm_symbol_begin.car);
-g_cells[cell_symbol_if].car = cstring_to_list (scm_symbol_if.car);
-g_cells[cell_symbol_quote].car = cstring_to_list (scm_symbol_quote.car);
-g_cells[cell_symbol_define].car = cstring_to_list (scm_symbol_define.car);
-g_cells[cell_symbol_define_macro].car = cstring_to_list (scm_symbol_define_macro.car);
-g_cells[cell_symbol_quasiquote].car = cstring_to_list (scm_symbol_quasiquote.car);
-g_cells[cell_symbol_unquote].car = cstring_to_list (scm_symbol_unquote.car);
-g_cells[cell_symbol_unquote_splicing].car = cstring_to_list (scm_symbol_unquote_splicing.car);
-
-//// FOR GCC
 #if !POSIX
- #define name car
+ #define name cdr
 #endif
-g_cells[cell_symbol_syntax].car = cstring_to_list (scm_symbol_syntax.name);
-g_cells[cell_symbol_quasisyntax].car = cstring_to_list (scm_symbol_quasisyntax.name);
-g_cells[cell_symbol_unsyntax].car = cstring_to_list (scm_symbol_unsyntax.name);
-g_cells[cell_symbol_unsyntax_splicing].car = cstring_to_list (scm_symbol_unsyntax_splicing.name);
-g_cells[cell_symbol_set_x].car = cstring_to_list (scm_symbol_set_x.name);
-g_cells[cell_symbol_sc_expand].car = cstring_to_list (scm_symbol_sc_expand.name);
-g_cells[cell_symbol_macro_expand].car = cstring_to_list (scm_symbol_macro_expand.name);
-g_cells[cell_symbol_portable_macro_expand].car = cstring_to_list (scm_symbol_portable_macro_expand.name);
-g_cells[cell_symbol_sc_expander_alist].car = cstring_to_list (scm_symbol_sc_expander_alist.name);
-g_cells[cell_symbol_call_with_values].car = cstring_to_list (scm_symbol_call_with_values.name);
-g_cells[cell_call_with_current_continuation].car = cstring_to_list (scm_call_with_current_continuation.name);
-g_cells[cell_symbol_call_with_current_continuation].car = cstring_to_list (scm_symbol_call_with_current_continuation.name);
-g_cells[cell_symbol_boot_module].car = cstring_to_list (scm_symbol_boot_module.name);
-g_cells[cell_symbol_current_module].car = cstring_to_list (scm_symbol_current_module.name);
-g_cells[cell_symbol_primitive_load].car = cstring_to_list (scm_symbol_primitive_load.name);
-g_cells[cell_symbol_read_input_file].car = cstring_to_list (scm_symbol_read_input_file.name);
-g_cells[cell_symbol_write].car = cstring_to_list (scm_symbol_write.name);
-g_cells[cell_symbol_display].car = cstring_to_list (scm_symbol_display.name);
-g_cells[cell_symbol_throw].car = cstring_to_list (scm_symbol_throw.name);
-g_cells[cell_symbol_not_a_number].car = cstring_to_list (scm_symbol_not_a_number.name);
-g_cells[cell_symbol_not_a_pair].car = cstring_to_list (scm_symbol_not_a_pair.name);
-g_cells[cell_symbol_system_error].car = cstring_to_list (scm_symbol_system_error.name);
-g_cells[cell_symbol_wrong_number_of_args].car = cstring_to_list (scm_symbol_wrong_number_of_args.name);
-g_cells[cell_symbol_wrong_type_arg].car = cstring_to_list (scm_symbol_wrong_type_arg.name);
-g_cells[cell_symbol_unbound_variable].car = cstring_to_list (scm_symbol_unbound_variable.name);
-g_cells[cell_symbol_hashq_table].car = cstring_to_list (scm_symbol_hashq_table.name);
-g_cells[cell_symbol_record_type].car = cstring_to_list (scm_symbol_record_type.name);
-g_cells[cell_symbol_module].car = cstring_to_list (scm_symbol_module.name);
-g_cells[cell_symbol_buckets].car = cstring_to_list (scm_symbol_buckets.name);
-g_cells[cell_symbol_size].car = cstring_to_list (scm_symbol_size.name);
-g_cells[cell_symbol_argv].car = cstring_to_list (scm_symbol_argv.name);
-g_cells[cell_symbol_mes_prefix].car = cstring_to_list (scm_symbol_mes_prefix.name);
-g_cells[cell_symbol_mes_version].car = cstring_to_list (scm_symbol_mes_version.name);
-g_cells[cell_symbol_car].car = cstring_to_list (scm_symbol_car.name);
-g_cells[cell_symbol_cdr].car = cstring_to_list (scm_symbol_cdr.name);
-g_cells[cell_symbol_pmatch_car].car = cstring_to_list (scm_symbol_pmatch_car.name);
-g_cells[cell_symbol_pmatch_cdr].car = cstring_to_list (scm_symbol_pmatch_cdr.name);
+
+NAME_SYMBOL (cell_nil, scm_nil.name);
+NAME_SYMBOL (cell_f, scm_f.name);
+NAME_SYMBOL (cell_t, scm_t.name);
+NAME_SYMBOL (cell_dot, scm_dot.name);
+NAME_SYMBOL (cell_arrow, scm_arrow.name);
+NAME_SYMBOL (cell_undefined, scm_undefined.name);
+NAME_SYMBOL (cell_unspecified, scm_unspecified.name);
+NAME_SYMBOL (cell_closure, scm_closure.name);
+NAME_SYMBOL (cell_circular, scm_circular.name);
+NAME_SYMBOL (cell_begin, scm_begin.name);
+NAME_SYMBOL (cell_symbol_dot, scm_symbol_dot.name);
+NAME_SYMBOL (cell_symbol_lambda, scm_symbol_lambda.name);
+NAME_SYMBOL (cell_symbol_begin, scm_symbol_begin.name);
+NAME_SYMBOL (cell_symbol_if, scm_symbol_if.name);
+NAME_SYMBOL (cell_symbol_quote, scm_symbol_quote.name);
+NAME_SYMBOL (cell_symbol_define, scm_symbol_define.name);
+NAME_SYMBOL (cell_symbol_define_macro, scm_symbol_define_macro.name);
+NAME_SYMBOL (cell_symbol_quasiquote, scm_symbol_quasiquote.name);
+NAME_SYMBOL (cell_symbol_unquote, scm_symbol_unquote.name);
+NAME_SYMBOL (cell_symbol_unquote_splicing, scm_symbol_unquote_splicing.name);
+NAME_SYMBOL (cell_symbol_syntax, scm_symbol_syntax.name);
+NAME_SYMBOL (cell_symbol_quasisyntax, scm_symbol_quasisyntax.name);
+NAME_SYMBOL (cell_symbol_unsyntax, scm_symbol_unsyntax.name);
+NAME_SYMBOL (cell_symbol_unsyntax_splicing, scm_symbol_unsyntax_splicing.name);
+NAME_SYMBOL (cell_symbol_set_x, scm_symbol_set_x.name);
+NAME_SYMBOL (cell_symbol_sc_expand, scm_symbol_sc_expand.name);
+NAME_SYMBOL (cell_symbol_macro_expand, scm_symbol_macro_expand.name);
+NAME_SYMBOL (cell_symbol_portable_macro_expand, scm_symbol_portable_macro_expand.name);
+NAME_SYMBOL (cell_symbol_sc_expander_alist, scm_symbol_sc_expander_alist.name);
+NAME_SYMBOL (cell_symbol_call_with_values, scm_symbol_call_with_values.name);
+NAME_SYMBOL (cell_call_with_current_continuation, scm_call_with_current_continuation.name);
+NAME_SYMBOL (cell_symbol_call_with_current_continuation, scm_symbol_call_with_current_continuation.name);
+NAME_SYMBOL (cell_symbol_boot_module, scm_symbol_boot_module.name);
+NAME_SYMBOL (cell_symbol_current_module, scm_symbol_current_module.name);
+NAME_SYMBOL (cell_symbol_primitive_load, scm_symbol_primitive_load.name);
+NAME_SYMBOL (cell_symbol_read_input_file, scm_symbol_read_input_file.name);
+NAME_SYMBOL (cell_symbol_write, scm_symbol_write.name);
+NAME_SYMBOL (cell_symbol_display, scm_symbol_display.name);
+NAME_SYMBOL (cell_symbol_throw, scm_symbol_throw.name);
+NAME_SYMBOL (cell_symbol_not_a_number, scm_symbol_not_a_number.name);
+NAME_SYMBOL (cell_symbol_not_a_pair, scm_symbol_not_a_pair.name);
+NAME_SYMBOL (cell_symbol_system_error, scm_symbol_system_error.name);
+NAME_SYMBOL (cell_symbol_wrong_number_of_args, scm_symbol_wrong_number_of_args.name);
+NAME_SYMBOL (cell_symbol_wrong_type_arg, scm_symbol_wrong_type_arg.name);
+NAME_SYMBOL (cell_symbol_unbound_variable, scm_symbol_unbound_variable.name);
+NAME_SYMBOL (cell_symbol_hashq_table, scm_symbol_hashq_table.name);
+NAME_SYMBOL (cell_symbol_record_type, scm_symbol_record_type.name);
+NAME_SYMBOL (cell_symbol_frame, scm_symbol_frame.name);
+NAME_SYMBOL (cell_symbol_module, scm_symbol_module.name);
+NAME_SYMBOL (cell_symbol_stack, scm_symbol_stack.name);
+NAME_SYMBOL (cell_symbol_buckets, scm_symbol_buckets.name);
+NAME_SYMBOL (cell_symbol_procedure, scm_symbol_procedure.name);
+NAME_SYMBOL (cell_symbol_size, scm_symbol_size.name);
+NAME_SYMBOL (cell_symbol_argv, scm_symbol_argv.name);
+NAME_SYMBOL (cell_symbol_mes_prefix, scm_symbol_mes_prefix.name);
+NAME_SYMBOL (cell_symbol_mes_version, scm_symbol_mes_version.name);
+NAME_SYMBOL (cell_symbol_car, scm_symbol_car.name);
+NAME_SYMBOL (cell_symbol_cdr, scm_symbol_cdr.name);
+NAME_SYMBOL (cell_symbol_pmatch_car, scm_symbol_pmatch_car.name);
+NAME_SYMBOL (cell_symbol_pmatch_cdr, scm_symbol_pmatch_cdr.name);
+NAME_SYMBOL (cell_vm_evlis, scm_vm_evlis.name);
+NAME_SYMBOL (cell_vm_evlis2, scm_vm_evlis2.name);
+NAME_SYMBOL (cell_vm_evlis3, scm_vm_evlis3.name);
+NAME_SYMBOL (cell_vm_apply, scm_vm_apply.name);
+NAME_SYMBOL (cell_vm_apply2, scm_vm_apply2.name);
+NAME_SYMBOL (cell_vm_eval, scm_vm_eval.name);
+NAME_SYMBOL (cell_vm_eval_pmatch_car, scm_vm_eval_pmatch_car.name);
+NAME_SYMBOL (cell_vm_eval_pmatch_cdr, scm_vm_eval_pmatch_cdr.name);
+NAME_SYMBOL (cell_vm_eval_define, scm_vm_eval_define.name);
+NAME_SYMBOL (cell_vm_eval_set_x, scm_vm_eval_set_x.name);
+NAME_SYMBOL (cell_vm_eval_macro_expand_eval, scm_vm_eval_macro_expand_eval.name);
+NAME_SYMBOL (cell_vm_eval_macro_expand_expand, scm_vm_eval_macro_expand_expand.name);
+NAME_SYMBOL (cell_vm_eval_check_func, scm_vm_eval_check_func.name);
+NAME_SYMBOL (cell_vm_eval2, scm_vm_eval2.name);
+NAME_SYMBOL (cell_vm_macro_expand, scm_vm_macro_expand.name);
+NAME_SYMBOL (cell_vm_macro_expand_define, scm_vm_macro_expand_define.name);
+NAME_SYMBOL (cell_vm_macro_expand_define_macro, scm_vm_macro_expand_define_macro.name);
+NAME_SYMBOL (cell_vm_macro_expand_lambda, scm_vm_macro_expand_lambda.name);
+NAME_SYMBOL (cell_vm_macro_expand_set_x, scm_vm_macro_expand_set_x.name);
+NAME_SYMBOL (cell_vm_begin_expand_primitive_load, scm_vm_begin_expand_primitive_load.name);
+NAME_SYMBOL (cell_vm_begin_primitive_load, scm_vm_begin_primitive_load.name);
+NAME_SYMBOL (cell_vm_macro_expand_car, scm_vm_macro_expand_car.name);
+NAME_SYMBOL (cell_vm_macro_expand_cdr, scm_vm_macro_expand_cdr.name);
+NAME_SYMBOL (cell_vm_begin_expand, scm_vm_begin_expand.name);
+NAME_SYMBOL (cell_vm_begin_expand_eval, scm_vm_begin_expand_eval.name);
+NAME_SYMBOL (cell_vm_begin_expand_macro, scm_vm_begin_expand_macro.name);
+NAME_SYMBOL (cell_vm_begin, scm_vm_begin.name);
+NAME_SYMBOL (cell_vm_begin_read_input_file, scm_vm_begin_read_input_file.name);
+NAME_SYMBOL (cell_vm_begin_eval, scm_vm_begin_eval.name);
+NAME_SYMBOL (cell_vm_if, scm_vm_if.name);
+NAME_SYMBOL (cell_vm_if_expr, scm_vm_if_expr.name);
+NAME_SYMBOL (cell_vm_call_with_values2, scm_vm_call_with_values2.name);
+NAME_SYMBOL (cell_vm_call_with_current_continuation2, scm_vm_call_with_current_continuation2.name);
+NAME_SYMBOL (cell_vm_return, scm_vm_return.name);
+NAME_SYMBOL (cell_type_bytes, scm_type_bytes.name);
+NAME_SYMBOL (cell_type_char, scm_type_char.name);
+NAME_SYMBOL (cell_type_closure, scm_type_closure.name);
+NAME_SYMBOL (cell_type_continuation, scm_type_continuation.name);
+NAME_SYMBOL (cell_type_function, scm_type_function.name);
+NAME_SYMBOL (cell_type_keyword, scm_type_keyword.name);
+NAME_SYMBOL (cell_type_macro, scm_type_macro.name);
+NAME_SYMBOL (cell_type_number, scm_type_number.name);
+NAME_SYMBOL (cell_type_pair, scm_type_pair.name);
+NAME_SYMBOL (cell_type_port, scm_type_port.name);
+NAME_SYMBOL (cell_type_ref, scm_type_ref.name);
+NAME_SYMBOL (cell_type_special, scm_type_special.name);
+NAME_SYMBOL (cell_type_string, scm_type_string.name);
+NAME_SYMBOL (cell_type_struct, scm_type_struct.name);
+NAME_SYMBOL (cell_type_symbol, scm_type_symbol.name);
+NAME_SYMBOL (cell_type_values, scm_type_values.name);
+NAME_SYMBOL (cell_type_variable, scm_type_variable.name);
+NAME_SYMBOL (cell_type_vector, scm_type_vector.name);
+NAME_SYMBOL (cell_type_broken_heart, scm_type_broken_heart.name);
+NAME_SYMBOL (cell_symbol_internal_time_units_per_second, scm_symbol_internal_time_units_per_second.name);
+NAME_SYMBOL (cell_symbol_compiler, scm_symbol_compiler.name);
+NAME_SYMBOL (cell_symbol_arch, scm_symbol_arch.name);
+NAME_SYMBOL (cell_test, scm_test.name);
 
 #if !POSIX
  #undef name
 #endif
 
-g_cells[cell_vm_evlis].car = cstring_to_list (scm_vm_evlis.car);
-g_cells[cell_vm_evlis2].car = cstring_to_list (scm_vm_evlis2.car);
-g_cells[cell_vm_evlis3].car = cstring_to_list (scm_vm_evlis3.car);
-g_cells[cell_vm_apply].car = cstring_to_list (scm_vm_apply.car);
-g_cells[cell_vm_apply2].car = cstring_to_list (scm_vm_apply2.car);
-g_cells[cell_vm_eval].car = cstring_to_list (scm_vm_eval.car);
-g_cells[cell_vm_eval_pmatch_car].car = cstring_to_list (scm_vm_eval_pmatch_car.car);
-g_cells[cell_vm_eval_pmatch_cdr].car = cstring_to_list (scm_vm_eval_pmatch_cdr.car);
-g_cells[cell_vm_eval_define].car = cstring_to_list (scm_vm_eval_define.car);
-g_cells[cell_vm_eval_set_x].car = cstring_to_list (scm_vm_eval_set_x.car);
-g_cells[cell_vm_eval_macro_expand_eval].car = cstring_to_list (scm_vm_eval_macro_expand_eval.car);
-g_cells[cell_vm_eval_macro_expand_expand].car = cstring_to_list (scm_vm_eval_macro_expand_expand.car);
-g_cells[cell_vm_eval_check_func].car = cstring_to_list (scm_vm_eval_check_func.car);
-g_cells[cell_vm_eval2].car = cstring_to_list (scm_vm_eval2.car);
-g_cells[cell_vm_macro_expand].car = cstring_to_list (scm_vm_macro_expand.car);
-g_cells[cell_vm_macro_expand_define].car = cstring_to_list (scm_vm_macro_expand_define.car);
-g_cells[cell_vm_macro_expand_define_macro].car = cstring_to_list (scm_vm_macro_expand_define_macro.car);
-g_cells[cell_vm_macro_expand_lambda].car = cstring_to_list (scm_vm_macro_expand_lambda.car);
-g_cells[cell_vm_macro_expand_set_x].car = cstring_to_list (scm_vm_macro_expand_set_x.car);
-g_cells[cell_vm_begin_expand_primitive_load].car = cstring_to_list (scm_vm_begin_expand_primitive_load.car);
-g_cells[cell_vm_begin_primitive_load].car = cstring_to_list (scm_vm_begin_primitive_load.car);
-g_cells[cell_vm_macro_expand_car].car = cstring_to_list (scm_vm_macro_expand_car.car);
-g_cells[cell_vm_macro_expand_cdr].car = cstring_to_list (scm_vm_macro_expand_cdr.car);
-g_cells[cell_vm_begin_expand].car = cstring_to_list (scm_vm_begin_expand.car);
-g_cells[cell_vm_begin_expand_eval].car = cstring_to_list (scm_vm_begin_expand_eval.car);
-g_cells[cell_vm_begin_expand_macro].car = cstring_to_list (scm_vm_begin_expand_macro.car);
-g_cells[cell_vm_begin].car = cstring_to_list (scm_vm_begin.car);
-g_cells[cell_vm_begin_read_input_file].car = cstring_to_list (scm_vm_begin_read_input_file.car);
-g_cells[cell_vm_begin_eval].car = cstring_to_list (scm_vm_begin_eval.car);
-g_cells[cell_vm_if].car = cstring_to_list (scm_vm_if.car);
-g_cells[cell_vm_if_expr].car = cstring_to_list (scm_vm_if_expr.car);
-g_cells[cell_vm_call_with_values2].car = cstring_to_list (scm_vm_call_with_values2.car);
-g_cells[cell_vm_call_with_current_continuation2].car = cstring_to_list (scm_vm_call_with_current_continuation2.car);
-g_cells[cell_vm_return].car = cstring_to_list (scm_vm_return.car);
-
-////////////////// gc
-
-#elif !_POSIX_SOURCE
-#include "mes.mes.symbol-names.i"
+#elif !POSIX
+#include "src/mes.mes.symbol-names.i"
 #else
-#include "mes.symbol-names.i"
+#include "src/mes.symbol-names.i"
 #endif
 
   g_symbols = make_hash_table_ (500);
   for (int i=1; i<g_symbol_max; i++)
-    hash_set_x (g_symbols, MAKE_STRING (STRING (i)), i);
+    hash_set_x (g_symbols, symbol_to_string (i), i);
 
   SCM a = cell_nil;
   a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a);
@@ -2130,9 +2229,10 @@ g_cells[cell_vm_return].car = cstring_to_list (scm_vm_return.car);
   a = acons (cell_symbol_current_module, cell_symbol_current_module, a);
   a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
 
-  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);
+  a = acons (cell_symbol_mes_version, MAKE_STRING0 (VERSION), a);
+  a = acons (cell_symbol_mes_prefix, MAKE_STRING0 (PREFIX), a);
 
+  a = acons (cell_type_bytes, MAKE_NUMBER (TBYTES), a);
   a = acons (cell_type_char, MAKE_NUMBER (TCHAR), a);
   a = acons (cell_type_closure, MAKE_NUMBER (TCLOSURE), a);
   a = acons (cell_type_continuation, MAKE_NUMBER (TCONTINUATION), a);
@@ -2168,18 +2268,18 @@ mes_environment (int argc, char *argv[])
 #elif __TINYC__
   compiler = "tcc";
 #endif
-  a = acons (cell_symbol_compiler, MAKE_STRING (cstring_to_list (compiler)), a);
+  a = acons (cell_symbol_compiler, MAKE_STRING0 (compiler), a);
 
   char *arch = "x86";
 #if __x86_64__
   arch = "x86_64";
 #endif
-  a = acons (cell_symbol_arch, MAKE_STRING (cstring_to_list (arch)), a);
+  a = acons (cell_symbol_arch, MAKE_STRING0 (arch), a);
 
 #if !MES_MINI
   SCM lst = cell_nil;
   for (int i=argc-1; i>=0; i--)
-    lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst);
+    lst = cons (MAKE_STRING0 (argv[i]), lst);
   a = acons (cell_symbol_argv, lst, a);
 #endif
 
@@ -2192,9 +2292,7 @@ mes_builtins (SCM a) ///((internal))
 #if MES_MINI
 
 #if !POSIX
- #define function cdr
- #define name car
- #define string car
+ #define function car
 #endif
 
 //mes
@@ -2258,109 +2356,103 @@ g_cells[cell_getenv_] = scm_getenv_;
 
 #if !POSIX
  #undef name
+ #define string cdr
 #endif
 
 //mes.environment
-scm_cons.string = cstring_to_list (fun_cons.name);
-g_cells[cell_cons].string = MAKE_STRING (scm_cons.string);
-a = acons (list_to_symbol (scm_cons.string), cell_cons, a);
+scm_cons.string = MAKE_BYTES0 (fun_cons.name);
+a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_cons)), cell_cons, a);
 
-scm_car.string = cstring_to_list (fun_car.name);
-g_cells[cell_car].string = MAKE_STRING (scm_car.string);
-a = acons (list_to_symbol (scm_car.string), cell_car, a);
+scm_car.string = MAKE_BYTES0 (fun_car.name);
+a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_car)), cell_car, a);
 
-scm_cdr.string = cstring_to_list (fun_cdr.name);
-g_cells[cell_cdr].string = MAKE_STRING (scm_cdr.string);
-a = acons (list_to_symbol (scm_cdr.string), cell_cdr, a);
+scm_cdr.string = MAKE_BYTES0 (fun_cdr.name);
+a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_cdr)), cell_cdr, a);
 
-scm_list.string = cstring_to_list (fun_list.name);
-g_cells[cell_list].string = MAKE_STRING (scm_list.string);
-a = acons (list_to_symbol (scm_list.string), cell_list, a);
+scm_list.string = MAKE_BYTES0 (fun_list.name);
+a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_list)), cell_list, a);
 
-scm_null_p.string = cstring_to_list (fun_null_p.name);
-g_cells[cell_null_p].string = MAKE_STRING (scm_null_p.string);
-a = acons (list_to_symbol (scm_null_p.string), cell_null_p, a);
+scm_null_p.string = MAKE_BYTES0 (fun_null_p.name);
+a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_null_p)), cell_null_p, a);
 
-scm_eq_p.string = cstring_to_list (fun_eq_p.name);
-g_cells[cell_eq_p].string = MAKE_STRING (scm_eq_p.string);
-a = acons (list_to_symbol (scm_eq_p.string), cell_eq_p, a);
+scm_eq_p.string = MAKE_BYTES0 (fun_eq_p.name);
+ a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_eq_p)), cell_eq_p, a);
 
 //math.environment
- scm_minus.string = cstring_to_list (fun_minus.name);
-g_cells[cell_minus].string = MAKE_STRING (scm_minus.string);
-a = acons (list_to_symbol (scm_minus.string), cell_minus, a);
+scm_minus.string = MAKE_BYTES0 (fun_minus.name);
+a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_minus)), cell_minus, a);
 
-scm_plus.string = cstring_to_list (fun_plus.name);
-g_cells[cell_plus].string = MAKE_STRING (scm_plus.string);
-a = acons (list_to_symbol (scm_plus.string), cell_plus, a);
+scm_plus.string = MAKE_BYTES0 (fun_plus.name);
+a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_plus)), cell_plus, a);
 
 //lib.environment
-scm_display_.string = cstring_to_list (fun_display_.name);
-g_cells[cell_display_].string = MAKE_STRING (scm_display_.string);
-a = acons (list_to_symbol (scm_display_.string), cell_display_, a);
+scm_display_.string = MAKE_BYTES0 (fun_display_.name);
+a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_display_)), cell_display_, a);
 
-scm_display_error_.string = cstring_to_list (fun_display_error_.name);
-g_cells[cell_display_error_].string = MAKE_STRING (scm_display_error_.string);
-a = acons (list_to_symbol (scm_display_error_.string), cell_display_error_, a);
+scm_display_error_.string = MAKE_BYTES0 (fun_display_error_.name);
+a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_display_error_)), cell_display_error_, a);
 
 //posix.environment
-scm_getenv_.string = cstring_to_list (fun_getenv_.name);
-g_cells[cell_getenv_].string = MAKE_STRING (scm_getenv_.string);
-a = acons (list_to_symbol (scm_getenv_.string), cell_getenv_, a);
+scm_getenv_.string = MAKE_BYTES0 (fun_getenv_.name);
+a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_getenv_)), cell_getenv_, a);
 
 #if !POSIX
  #undef function
  #undef string
 #endif
 
-#elif !__GNUC__ || !_POSIX_SOURCE
-#include "mes.mes.i"
+#elif !__GNUC__ || !POSIX
+#include "src/mes.mes.i"
 
   // Do not sort: Order of these includes define builtins
-#include "hash.mes.i"
-#include "module.mes.i"
-#include "posix.mes.i"
-#include "math.mes.i"
-#include "lib.mes.i"
-#include "vector.mes.i"
-#include "struct.mes.i"
-#include "gc.mes.i"
-#include "reader.mes.i"
-
-#include "gc.mes.environment.i"
-#include "hash.mes.environment.i"
-#include "lib.mes.environment.i"
-#include "math.mes.environment.i"
-#include "mes.mes.environment.i"
-#include "module.mes.environment.i"
-#include "posix.mes.environment.i"
-#include "reader.mes.environment.i"
-#include "struct.mes.environment.i"
-#include "vector.mes.environment.i"
+#include "src/hash.mes.i"
+#include "src/module.mes.i"
+#include "src/posix.mes.i"
+#include "src/math.mes.i"
+#include "src/lib.mes.i"
+#include "src/vector.mes.i"
+#include "src/strings.mes.i"
+#include "src/struct.mes.i"
+#include "src/gc.mes.i"
+#include "src/reader.mes.i"
+
+#include "src/gc.mes.environment.i"
+#include "src/hash.mes.environment.i"
+#include "src/lib.mes.environment.i"
+#include "src/math.mes.environment.i"
+#include "src/mes.mes.environment.i"
+#include "src/module.mes.environment.i"
+#include "src/posix.mes.environment.i"
+#include "src/reader.mes.environment.i"
+#include "src/strings.mes.environment.i"
+#include "src/struct.mes.environment.i"
+#include "src/vector.mes.environment.i"
 #else
-#include "mes.i"
+#include "src/mes.i"
 
   // Do not sort: Order of these includes define builtins
-#include "hash.i"
-#include "module.i"
-#include "posix.i"
-#include "math.i"
-#include "lib.i"
-#include "vector.i"
-#include "struct.i"
-#include "gc.i"
-#include "reader.i"
-
-#include "gc.environment.i"
-#include "hash.environment.i"
-#include "lib.environment.i"
-#include "math.environment.i"
-#include "mes.environment.i"
-#include "module.environment.i"
-#include "posix.environment.i"
-#include "reader.environment.i"
-#include "struct.environment.i"
-#include "vector.environment.i"
+#include "src/hash.i"
+#include "src/module.i"
+#include "src/posix.i"
+#include "src/math.i"
+#include "src/lib.i"
+#include "src/vector.i"
+#include "src/strings.i"
+#include "src/struct.i"
+#include "src/gc.i"
+#include "src/reader.i"
+
+#include "src/gc.environment.i"
+#include "src/hash.environment.i"
+#include "src/lib.environment.i"
+#include "src/math.environment.i"
+#include "src/mes.environment.i"
+#include "src/module.environment.i"
+#include "src/posix.environment.i"
+#include "src/reader.environment.i"
+#include "src/strings.environment.i"
+#include "src/struct.environment.i"
+#include "src/vector.environment.i"
 #endif
 
   if (g_debug > 3)
@@ -2455,7 +2547,7 @@ load_env () ///((internal))
 SCM
 bload_env () ///((internal))
 {
-#if !_POSIX_SOURCE
+#if !POSIX
   char *mo = "mes/boot-0.32-mo";
   g_stdin = open ("module/mes/boot-0.32-mo", O_RDONLY);
   char *read0 = MODULEDIR "/mes/boot-0.32-mo";
@@ -2518,10 +2610,11 @@ bload_env () ///((internal))
   return r2;
 }
 
-#include "vector.c"
-#include "struct.c"
-#include "gc.c"
-#include "reader.c"
+#include "src/vector.c"
+#include "src/strings.c"
+#include "src/struct.c"
+#include "src/gc.c"
+#include "src/reader.c"
 
 int
 main (int argc, char *argv[])
@@ -2580,12 +2673,12 @@ main (int argc, char *argv[])
       write_error_ (r1);
       eputs ("\n");
     }
-  if (g_debug > 3)
-    {
-      eputs ("symbols: ");
-      write_error_ (g_symbols);
-      eputs ("\n");
-    }
+  // if (g_debug > 3)
+  //   {
+  //     eputs ("symbols: ");
+  //     write_error_ (g_symbols);
+  //     eputs ("\n");
+  //   }
   r3 = cell_vm_begin_expand;
   r1 = eval_apply ();
   if (g_debug)
@@ -2595,13 +2688,42 @@ main (int argc, char *argv[])
     }
   if (g_debug)
     {
+      if (g_debug > 3)
+        module_printer (m0);
+
       eputs ("\ngc stats: [");
       eputs (itoa (g_free));
       MAX_ARENA_SIZE = 0;
+
+      gc (g_stack);
+      eputs (" => ");
+      eputs (itoa (g_free));
+      eputs ("]\n");
+      if (g_debug > 3)
+        module_printer (m0);
+      eputs ("\n");
+
+      gc (g_stack);
+      eputs (" => ");
+      eputs (itoa (g_free));
+      eputs ("]\n");
+      if (g_debug > 3)
+        module_printer (m0);
+      eputs ("\n");
+
       gc (g_stack);
       eputs (" => ");
       eputs (itoa (g_free));
       eputs ("]\n");
+      if (g_debug > 3)
+        module_printer (m0);
+      if (g_debug > 3)
+        {
+          eputs ("ports:"); write_error_ (g_ports); eputs ("\n");
+        }
+      eputs ("\n");
+
+
     }
   return 0;
 }
index 484b121b0e38a3699144fc03890307c493f94c42..fcff11492d5d949cfb9a70a09287f16d2fcd060e 100644 (file)
@@ -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");
     }
index 407d20c631d67de1a239b25d5820e305d9e3c797..b7a3dac32448e895083d6f96be9fb39c3f19271e 100644 (file)
@@ -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));
-  STRING (port) = CDR (string);
+  char const *p = CSTRING (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));
-  return p ? MAKE_STRING (cstring_to_list (p)) : cell_f;
+  p = getenv (CSTRING (s));
+  return p ? MAKE_STRING0 (p) : cell_f;
 }
 
 SCM
 setenv_ (SCM s, SCM v) ///((name . "setenv"))
 {
   char buf[1024];
-  strcpy (buf, string_to_cstring (s));
-  setenv (buf, string_to_cstring (v), 1);
+  strcpy (buf, CSTRING (s));
+  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);
-  n += length__ (STRING (file_name)) + 1;
+  c_argv[i++] = CSTRING (file_name);
   while (args != cell_nil)
     {
       assert (TYPE (CAR (args)) == TSTRING);
-      c_argv[i++] = (char*)string_to_cstring_ (CAR (args), string_to_cstring_buf+n);
-      n += length__ (STRING (CAR (args))) + 1;
+      c_argv[i++] = CSTRING (CAR (args));
       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;
 }
index 5f4e3bec157e34f0fc474617143017858c4c86a7..86254ff8a9c1bcec6dec18aa36b9522fa72421db 100644 (file)
@@ -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);
-            lst = cons (MAKE_CHAR (13), lst);
+            // c = '\r';
+            c = 13;
           else if (c == 'e')
             // Nyacc bug
-            // lst = cons (MAKE_CHAR ('\e'), lst);
-            lst = cons (MAKE_CHAR (27), lst);
+            // c = '\e';
+            c = 27;
           else if (c == 'x')
-            {
-              SCM x = reader_read_hex ();
-              lst = cons (MAKE_CHAR (VALUE (x)), lst);
-            }
+            c = VALUE (reader_read_hex ());
         }
-      else
-        lst = cons (MAKE_CHAR (c), lst);
+      buf[i++] = c;
     }
   while (1);
-  return MAKE_STRING (reverse_x_ (lst, cell_nil));
+  buf[i] = 0;
+  return make_string (buf, i);
 }
 
 int g_tiny = 0;
diff --git a/src/strings.c b/src/strings.c
new file mode 100644 (file)
index 0000000..fe86311
--- /dev/null
@@ -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);
+}
index 54cad53c20bccf42745f40946ddeab356a3d47a8..37a459ec37835829b4a5012e458f0bd6af63cacb 100755 (executable)
@@ -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)
index da6a25cdffa8d8de083d3cf10b53562946a4633a..97a0ee186c4e61ee8da6dfea363288c45befce35 100755 (executable)
@@ -1,10 +1,7 @@
 #! /bin/sh
 # -*-scheme-*-
 if [ "$MES" != guile ]; then
-    export MES_BOOT=boot-02.scm
-    MES=${MES-$(dirname $0)/../src/mes}
-    $MES < $0
-    exit $?
+    MES_BOOT=boot-02.scm exec ${MES-mes} < $0
 fi
 exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@"
 !#
index 0c874215551b213fe6f3e23c3e164547080ca081..1ebaba92e3d2bf2ae762db5d318e5310cb042dbf 100755 (executable)
@@ -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))
-
-(define (string->symbol s)
-  (if (not (pair? (core:car s))) '()
-      (list->symbol (core:car s))))
-
-(define (symbol->list s)
-  (core:car s))
+  (list->string lst))
 
 ;; boot-0.scm
-(define (symbol->string s)
-  (apply string (symbol->list s)))
-
 (define (string-append . rest)
   (apply string (apply append (map1 string->list rest))))
 
index 0207776e6e6aaf2d8e8082b766e890eaca70008a..06f1c53b91176b326ae4ce97b318cddf820a9c1f 100755 (executable)
@@ -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))
index b97195323a79eee499645723d76072acef6ba6bd..1021b1f76738eb619080dbf3ed4cbc5033ab9981 100755 (executable)
@@ -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" "$@"
diff --git a/tests/posix.test b/tests/posix.test
new file mode 100755 (executable)
index 0000000..648306c
--- /dev/null
@@ -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)
index 85786b0b8e1538d1abc02f73dfd78b92a36a87c7..38719ceec416424fd247825e5a873ea48de0f274 100755 (executable)
@@ -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))
-(mes-use-module (mes quasiquote))
-(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)
index a6af905d6190645312f489c8633586d6dc0fe23d..f307c12279133074ab874e8dd7f7c4b95c9f05ef 100755 (executable)
 # 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}
+    MES_BOOT=boot-02.scm exec $MES < $0
+fi
 
-MES=${MES-$(dirname $0)/../src/mes}
-exec $MES -s $0
+exec ${MES-mes} --no-auto-compile -s $0
 !#
 
 0
index c572eaeb6354f3b078f749ede0ba8e767081d9e9..88c6b0dbca664e3856df7dc0937cecd86520e81f 100755 (executable)
@@ -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))
-(mes-use-module (srfi srfi-0))
-(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)
@@ -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))
index c1987f62b9015cbfd1f5d418c3271c38844320fe..25bdc660d828c880df8a0ef140f80abdd557b60d 100755 (executable)
@@ -33,9 +33,17 @@ 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")))
+    "foo bar"
+  (string-join '("foo" "bar")))
+
 
 (pass-if-equal "string-join infix"
                "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))
index dd62034a9e14b9a965bf4303bd9536707ce9b230..4ef1493aec7a30096a310c4deaecc447cace2ae1 100755 (executable)
@@ -47,6 +47,6 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
   (char-set= (char-set #\a #\b #\c) (list->char-set '(#\a #\b #\c))))
 
 (pass-if "string->char-set!"
-  (char-set= (char-set #\a #\b #\c #\d) (string->char-set! "d" (string->char-set "abc"))))
+         (char-set= (char-set #\a #\b #\c #\d) (string->char-set! "d" (string->char-set "abc"))))
 
 (result 'report)