diff --git a/build-aux/build-mes.sh b/build-aux/build-mes.sh index e839bbd6..ff19ec12 100755 --- a/build-aux/build-mes.sh +++ b/build-aux/build-mes.sh @@ -75,8 +75,8 @@ compile scaffold/argv [ "$mes_p" ] && link scaffold/micro-mes [ "$mes_p" ] && compile scaffold/tiny-mes [ "$mes_p" ] && link scaffold/tiny-mes -[ "$mes_p" ] && compile scaffold/mini-mes -[ "$mes_p" ] && link scaffold/mini-mes +#[ "$mes_p" ] && compile scaffold/mini-mes +#[ "$mes_p" ] && link scaffold/mini-mes compile src/mes link src/mes diff --git a/build-aux/check-boot.sh b/build-aux/check-boot.sh index 7b9ca556..630567fd 100755 --- a/build-aux/check-boot.sh +++ b/build-aux/check-boot.sh @@ -46,6 +46,12 @@ tests=" 16-if-eq-quote.scm +17-memq.scm +17-memq-keyword.scm +17-string-equal.scm +17-equal2.scm +17-open-input-string.scm + 20-define.scm 20-define-quoted.scm 20-define-quote.scm @@ -99,6 +105,8 @@ tests=" 4e-let-global.scm 4f-string-split.scm +50-string-append.scm +50-string-join.scm 50-primitive-load.scm 51-module.scm 52-define-module.scm diff --git a/build-aux/check-mes.sh b/build-aux/check-mes.sh index 2e8128e4..1555f31b 100755 --- a/build-aux/check-mes.sh +++ b/build-aux/check-mes.sh @@ -52,6 +52,7 @@ tests/guile.test tests/syntax.test tests/let-syntax.test tests/pmatch.test +tests/posix.test tests/match.test tests/psyntax.test " diff --git a/build-aux/config.sh b/build-aux/config.sh index 99ac740e..75d1d42b 100644 --- a/build-aux/config.sh +++ b/build-aux/config.sh @@ -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 diff --git a/build-aux/mes-snarf.scm b/build-aux/mes-snarf.scm index d01d337c..0730108f 100755 --- a/build-aux/mes-snarf.scm +++ b/build-aux/mes-snarf.scm @@ -110,8 +110,8 @@ exec ${GUILE-guile} --no-auto-compile -L $(dirname $0) -C $(dirname $0) -e '(mes (define (symbol->names s i) (if %gcc? - (format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.name);\n" s s) - (format #f "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) diff --git a/build-aux/snarf.sh b/build-aux/snarf.sh index a77677f4..07f8f78d 100755 --- a/build-aux/snarf.sh +++ b/build-aux/snarf.sh @@ -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 diff --git a/include/linux/x86_64/syscall.h b/include/linux/x86_64/syscall.h index 0c73df78..5737ecbb 100644 --- a/include/linux/x86_64/syscall.h +++ b/include/linux/x86_64/syscall.h @@ -59,6 +59,7 @@ #define SYS_pipe 0x16 #define SYS_getgid 0x68 #define SYS_rt_sigaction 0x0d +#define SYS_rt_sigreturn 0x0f #define SYS_fcntl 0x48 #define SYS_dup2 0x21 #define SYS_getrusage 0x62 diff --git a/include/signal.h b/include/signal.h index bfb18b1c..e6ed8070 100644 --- a/include/signal.h +++ b/include/signal.h @@ -76,6 +76,7 @@ typedef long stack_t; #define SA_NOCLDSTOP 0x00000001 #define SA_NOCLDWAIT 0x00000002 #define SA_SIGINFO 0x00000004 +#define SA_RESTORER 0x04000000 #define SA_ONSTACK 0x08000000 #define SA_RESTART 0x10000000 #define SA_NODEFER 0x40000000 diff --git a/lib/linux/gettimeofday.c b/lib/linux/gettimeofday.c index 0e427856..81cf0fc0 100644 --- a/lib/linux/gettimeofday.c +++ b/lib/linux/gettimeofday.c @@ -18,7 +18,7 @@ * along with GNU Mes. If not, see . */ -#include +#include int gettimeofday (struct timeval *tv, struct timezone *tz) diff --git a/lib/linux/gnu.c b/lib/linux/gnu.c index 402f30e1..7d4f08c5 100644 --- a/lib/linux/gnu.c +++ b/lib/linux/gnu.c @@ -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)))) diff --git a/mes/module/mes/base.mes b/mes/module/mes/base.mes index 15af15d1..9591ffad 100644 --- a/mes/module/mes/base.mes +++ b/mes/module/mes/base.mes @@ -101,6 +101,24 @@ (or (null? x) (and (pair? x) (list? (cdr x))))) +(define-macro (cond . clauses) + (list 'if (pair? clauses) + (list (cons + 'lambda + (cons + '(test) + (list (list 'if 'test + (if (pair? (cdr (car clauses))) + (if (eq? (car (cdr (car clauses))) '=>) + (append2 (cdr (cdr (car clauses))) '(test)) + (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses))))))) + (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses))))))) + (if (pair? (cdr clauses)) + (cons 'cond (cdr clauses))))))) + (car (car clauses))))) + +(define else #t) + (define (procedure? p) (cond ((builtin? p) #t) ((and (pair? p) (eq? (car p) 'lambda))) diff --git a/mes/module/mes/boot-0.scm.in b/mes/module/mes/boot-0.scm.in index 9351c3b3..0d5d9c96 100644 --- a/mes/module/mes/boot-0.scm.in +++ b/mes/module/mes/boot-0.scm.in @@ -52,18 +52,12 @@ (if (null? rest) (core:write x) (core:write-port x (car rest)))) -(define (list->string lst) - (core:make-cell lst 0)) - (define (integer->char x) (core:make-cell 0 x)) (define (newline . rest) (core:display (list->string (list (integer->char 10))))) -(define (string->list s) - (core:car s)) - (define (cadr x) (car (cdr x))) (define (map1 f lst) @@ -107,7 +101,9 @@ #t) ;; end boot-02.scm -;; boot-0.scm +;; boot-03.scm +(define guile? #f) +(define mes? #t) (define (primitive-eval e) (core:eval e (current-module))) (define eval core:eval) @@ -125,24 +121,6 @@ (if (null? t) (core:apply f h (current-module)) (apply f (apply cons* (cons h t))))) -(define-macro (cond . clauses) - (list 'if (pair? clauses) - (list (cons - 'lambda - (cons - '(test) - (list (list 'if 'test - (if (pair? (cdr (car clauses))) - (if (eq? (car (cdr (car clauses))) '=>) - (append2 (cdr (cdr (car clauses))) '(test)) - (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses))))))) - (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses))))))) - (if (pair? (cdr clauses)) - (cons 'cond (cdr clauses))))))) - (car (car clauses))))) - -(define else #t) - (define-macro (load file) (list 'begin (list 'if (list 'and (list getenv "MES_DEBUG") @@ -161,9 +139,6 @@ (if (null? (cdr rest)) (car rest) (append2 (car rest) (apply append (cdr rest)))))) -(define (string->list s) - (core:car s)) - (define %prefix (getenv "MES_PREFIX")) (define %moduledir (if (not %prefix) "mes/module/" @@ -173,16 +148,9 @@ (include (list->string (append2 (string->list %moduledir) (string->list "mes/type-0.mes")))) -(define (symbol->string s) - (apply string (symbol->list s))) - (define (string-append . rest) (apply string (apply append (map1 string->list rest)))) -(define %version (if (eq? (car (string->list "@VERSION@")) #\@) "git" - "@VERSION@")) -(define (effective-version) %version) - (if (and (getenv "MES_DEBUG") (not (equal2? (getenv "MES_DEBUG") "0")) (not (equal2? (getenv "MES_DEBUG") "1"))) @@ -205,6 +173,20 @@ (mes-use-module (mes quasiquote)) (mes-use-module (mes let)) (mes-use-module (mes scm)) + +(define-macro (define-module module . rest) + `(if ,(and (pair? module) + (= 1 (length module)) + (symbol? (car module))) + (define (,(car module) . arguments) (main (command-line))))) + +(define-macro (use-modules . rest) #t) +;; end boot-03.scm + +(define %version (if (eq? (car (string->list "@VERSION@")) #\@) "git" + "@VERSION@")) +(define (effective-version) %version) + (mes-use-module (srfi srfi-1)) (mes-use-module (srfi srfi-13)) (mes-use-module (mes fluids)) diff --git a/mes/module/mes/boot-01.scm b/mes/module/mes/boot-01.scm index edad5e3c..74641c22 100644 --- a/mes/module/mes/boot-01.scm +++ b/mes/module/mes/boot-01.scm @@ -42,18 +42,12 @@ (if (null? rest) (core:write x) (core:write-port x (car rest)))) -(define (list->string lst) - (core:make-cell lst 0)) - (define (integer->char x) (core:make-cell 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-02.scm b/mes/module/mes/boot-02.scm index e400db43..4e691b40 100644 --- a/mes/module/mes/boot-02.scm +++ b/mes/module/mes/boot-02.scm @@ -52,18 +52,12 @@ (if (null? rest) (core:write x) (core:write-port x (car rest)))) -(define (list->string lst) - (core:make-cell lst 0)) - (define (integer->char x) (core:make-cell 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 index 00000000..4bfc6a3c --- /dev/null +++ b/mes/module/mes/boot-03.scm @@ -0,0 +1,186 @@ +;;; -*-scheme-*- + +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen +;;; +;;; 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 . + +;;; 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 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) "") +(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) diff --git a/mes/module/mes/display.mes b/mes/module/mes/display.mes index 5245b52f..71a1fb0e 100644 --- a/mes/module/mes/display.mes +++ b/mes/module/mes/display.mes @@ -50,31 +50,33 @@ (write? (and (pair? rest) (pair? (cdr rest)) (cadr rest)))) (define (display-char x port write?) - (cond ((and write? (or (eq? x #\") (eq? x #\\))) - (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)) @@ -94,7 +96,10 @@ (#\space . space))) cdr))) (write-char #\# port) - (write-char #\\ port) + (when (or name + (and (>= (char->integer 32)) + (<= (char->integer 127)))) + (write-char #\\ port)) (if name (display name port) (write-char x port))))) ((closure? x) @@ -163,7 +168,7 @@ (display ")" port)) ((function? x) (display "#symbol s) - (list->symbol (keyword->list s))) + (string->symbol (keyword->string s))) ;;; Characters diff --git a/mes/module/mes/type-0.mes b/mes/module/mes/type-0.mes index 0a015994..e81868fd 100644 --- a/mes/module/mes/type-0.mes +++ b/mes/module/mes/type-0.mes @@ -26,7 +26,8 @@ ;;; Code: (define cell:type-alist - (list (cons (quote )) + (list (cons (quote )) + (cons (quote )) (cons (quote )) (cons (quote )) (cons (quote )) @@ -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) )) + (define (char? x) (and (eq? (core:type x) ) (> (char->integer x) -1))) @@ -102,10 +106,8 @@ (define (vector? x) (eq? (core:type x) )) -;; Non-types -;; In core -;; (define (null? x) -;; (eq? x '())) +(define (broken-heart? x) + (eq? (core:type x) )) (define (atom? x) (not (pair? x))) @@ -116,20 +118,13 @@ ;;; core: accessors (define (string . lst) - (core:make-cell lst 0)) - -(define (string->symbol s) - (if (not (pair? (core:car s))) '() - (list->symbol (core:car s)))) - -(define (symbol->keyword s) - (core:make-cell (symbol->list s) 0)) - -(define (symbol->list s) - (core:car s)) + (list->string lst)) (define (keyword->list s) - (core:car s)) + (string->list (keyword->string s))) + +(define (symbol->list s) + (string->list (symbol->string s))) (define (integer->char x) (core:make-cell 0 x)) diff --git a/mes/module/srfi/srfi-13.mes b/mes/module/srfi/srfi-13.mes index 2735cfcc..dfd1c545 100644 --- a/mes/module/srfi/srfi-13.mes +++ b/mes/module/srfi/srfi-13.mes @@ -41,10 +41,6 @@ (define (string-copy s) (list->string (string->list s))) -(define (string=? a b) - (eq? (string->symbol a) - (string->symbol b))) - (define (string= a b . rest) (let* ((start1 (and (pair? rest) (car rest))) (end1 (and start1 (pair? (cdr rest)) (cadr rest))) diff --git a/module/mes/getopt-long.scm b/module/mes/getopt-long.scm index eaa9337a..71e04438 100644 --- a/module/mes/getopt-long.scm +++ b/module/mes/getopt-long.scm @@ -1,24 +1,19 @@ -;;; GNU Mes --- Maxwell Equations of Software ;;; Copyright (C) 1998, 2001, 2006 Free Software Foundation, Inc. ;;; Copyright (C) 2017,2018 Jan (janneke) Nieuwenhuizen -;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen ;;; -;;; 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 . - -;;; 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) diff --git a/module/mes/guile.scm b/module/mes/guile.scm index d6518c85..9c60077d 100644 --- a/module/mes/guile.scm +++ b/module/mes/guile.scm @@ -45,6 +45,7 @@ core:write-error core:write-port core:type + equal2? pmatch-car pmatch-cdr ) @@ -66,6 +67,7 @@ (define (core:apply f a . m) (apply f a)) (define (core:car f a . m) (apply f a)) (define append2 append) + (define equal2? equal?) (define guile:keyword? keyword?) (define guile:number? number?) diff --git a/module/mes/misc.scm b/module/mes/misc.scm index c3dae084..386476de 100644 --- a/module/mes/misc.scm +++ b/module/mes/misc.scm @@ -53,10 +53,11 @@ (car (last-pair stuff))) (define (pke . stuff) + (display "\n" (current-error-port)) (newline (current-error-port)) (display ";;; " (current-error-port)) (write stuff (current-error-port)) - (newline (current-error-port)) + (display "\n" (current-error-port)) (car (last-pair stuff))) (define warn pke) diff --git a/mes/module/mes/optargs.scm b/module/mes/optargs.scm similarity index 98% rename from mes/module/mes/optargs.scm rename to module/mes/optargs.scm index 943e21fa..148c986a 100644 --- a/mes/module/mes/optargs.scm +++ b/module/mes/optargs.scm @@ -6,12 +6,12 @@ ;;;; 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 @@ -57,7 +57,7 @@ ;;; Code: -(define-module (ice-9 optargs) +(define-module (mes optargs) #:use-module (system base pmatch) #:replace (lambda*) #:export-syntax (let-optional @@ -151,14 +151,13 @@ => cdr) (else ,(cadr key))))))) - `(let ((,kb-list-gensym (;;(@@ (ice-9 optargs) rest-arg->keyword-binding-list) - rest-arg->keyword-binding-list + `(let ((,kb-list-gensym ((if (not mes?) (@@ (mes optargs) rest-arg->keyword-binding-list) + rest-arg->keyword-binding-list) ,REST-ARG ',(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) '() diff --git a/module/mescc/M1.scm b/module/mescc/M1.scm index 894c6cc9..ef53ad74 100644 --- a/module/mescc/M1.scm +++ b/module/mescc/M1.scm @@ -111,6 +111,7 @@ (if (equal? o "%0") o ; FIXME: 64b (error "no such string:" o))))) (define (text->M1 o) + ;; (cond ((char? o) (text->M1 (char->integer o))) ((string? o) o) @@ -166,7 +167,8 @@ ((#:immediate4 ,immediate4) (hex2:immediate4 immediate4)) ((#:immediate8 ,immediate8) (hex2:immediate8 immediate8)) (_ (error "text->M1 no match o" o)))) - ((pair? o) (string-join (map text->M1 o))))) + ((pair? o) (string-join (map text->M1 o))) + (#t (error "no such text:" o)))) (define (write-function o) (let ((name (car o)) (text (function:text (cdr o)))) diff --git a/module/mescc/compile.scm b/module/mescc/compile.scm index 93f749e7..736c8053 100644 --- a/module/mescc/compile.scm +++ b/module/mescc/compile.scm @@ -910,8 +910,7 @@ ((p-expr (fixed ,value)) (let* ((value (cstring->int value)) (info (allocate-register info)) - (info (append-text info (append (wrap-as (as info 'value->r value))))) - (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)))))) @@ -1208,7 +1207,7 @@ ((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 index 00000000..e788e21c --- /dev/null +++ b/scaffold/boot/17-equal2.scm @@ -0,0 +1,25 @@ +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; 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 . + +(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 index 00000000..3114ec50 --- /dev/null +++ b/scaffold/boot/17-memq-keyword.scm @@ -0,0 +1,21 @@ +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; 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 . + +(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 index 00000000..d071c419 --- /dev/null +++ b/scaffold/boot/17-memq.scm @@ -0,0 +1,21 @@ +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; 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 . + +(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 index 00000000..8e2cc7ee --- /dev/null +++ b/scaffold/boot/17-open-input-string.scm @@ -0,0 +1,36 @@ +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; 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 . + +((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 index 00000000..3e30edba --- /dev/null +++ b/scaffold/boot/17-string-equal.scm @@ -0,0 +1,23 @@ +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; 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 . + +(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) diff --git a/scaffold/boot/4f-string-split.scm b/scaffold/boot/4f-string-split.scm index 98a28f61..c6396b78 100644 --- a/scaffold/boot/4f-string-split.scm +++ b/scaffold/boot/4f-string-split.scm @@ -91,12 +91,6 @@ ;; (if (= 0 n) '() ;; (foo (car x) (ss-list-head (cdr x) (- n 1))))) -(define (string->list s) - (core:car s)) - -(define (list->string lst) - (core:make-cell 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 index 00000000..b670b209 --- /dev/null +++ b/scaffold/boot/50-keyword.scm @@ -0,0 +1,23 @@ +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; 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 . + +(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 index 00000000..bedf7f1c --- /dev/null +++ b/scaffold/boot/50-make-string.scm @@ -0,0 +1,59 @@ +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; 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 . + +(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 index 00000000..48edbea0 --- /dev/null +++ b/scaffold/boot/50-string-append.scm @@ -0,0 +1,49 @@ +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; 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 . + +(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 index 00000000..4699ed7f --- /dev/null +++ b/scaffold/boot/50-string-join.scm @@ -0,0 +1,53 @@ +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; 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 . + +(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) diff --git a/scaffold/boot/51-module.scm b/scaffold/boot/51-module.scm index 2457d75f..50ff9e80 100644 --- a/scaffold/boot/51-module.scm +++ b/scaffold/boot/51-module.scm @@ -42,11 +42,8 @@ (list (quote if) (car x) (cons (quote and) (cdr x)) #f)))) - (define (string->list s) - (core:car s)) - (define (string . lst) - (core:make-cell 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 lst 0)) - (define %moduledir (if (not %prefix ) "mes/module/" (list->string @@ -80,24 +74,11 @@ (define-macro (include-from-path file) (list 'load (list string-append %moduledir file))) - (define (string->symbol s) - (list->symbol (core:car s))) - - (define (symbol->list s) - (core:car s)) - - (define (string . lst) - (core:make-cell 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 diff --git a/scaffold/boot/52-define-module.scm b/scaffold/boot/52-define-module.scm index a7150162..57e55dbf 100644 --- a/scaffold/boot/52-define-module.scm +++ b/scaffold/boot/52-define-module.scm @@ -40,11 +40,8 @@ (list (quote if) (car x) (cons (quote and) (cdr x)) #f)))) - (define (string->list s) - (core:car s)) - (define (string . lst) - (core:make-cell lst 0)) + (list->string lst)) (define (map1 f lst) (if (null? lst) (list) @@ -54,23 +51,13 @@ (define (string-append . rest) (apply string (apply append (map string->list rest)))) -;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;; - (define (symbol->list s) - (core:car s)) - - (define (symbol->string s) - (apply string (symbol->list s))) - (define (string-join lst infix) (if (null? (cdr lst)) (car lst) (string-append (car lst) infix (string-join (cdr lst) infix)))) ;;;;;;;;;;;;;;;;;; - (define (string->symbol s) - (list->symbol (core:car s))) - (define-macro (load file) (list 'primitive-load file)) @@ -83,5 +70,11 @@ )) (define %moduledir "./") +(core:display-error "reading...\n") (primitive-load "mes/module/mes/module.mes") +(core:display-error "dun\n") +(core:write-error (map symbol->string '(scaffold boot data bar))) +(core:display-error "\n") +(core:write-error (string-join (map symbol->string '(scaffold boot data bar)) "/")) +(core:display-error "\n") (mes-use-module (scaffold boot data bar)) diff --git a/scaffold/boot/60-let-syntax-expanded.scm b/scaffold/boot/60-let-syntax-expanded.scm index 9cec17fd..52049287 100644 --- a/scaffold/boot/60-let-syntax-expanded.scm +++ b/scaffold/boot/60-let-syntax-expanded.scm @@ -46,9 +46,6 @@ (if (null? rest) (core:write x) (core:write-port x (car rest)))) -(define (list->string lst) - (core:make-cell lst 0)) - (define (integer->char x) (core:make-cell 0 x)) @@ -142,10 +139,6 @@ (define (symbol? x) (eq? (core:type x) )) - (define (string->symbol s) - (if (not (pair? (core:car s))) '() - (list->symbol (core:car s)))) - (define 10) (define (string? x) (eq? (core:type x) )) @@ -232,7 +225,7 @@ (and (equal2? (car a) (car b)) (equal2? (cdr a) (cdr b))) (if (and (string? a) (string? b)) - (eq? (string->symbol a) (string->symbol b)) + (string=? a b) (if (and (vector? a) (vector? b)) (equal2? (vector->list a) (vector->list b)) (eq? a b)))))) diff --git a/scaffold/boot/60-let-syntax.scm b/scaffold/boot/60-let-syntax.scm index 4710a86a..72f57b04 100644 --- a/scaffold/boot/60-let-syntax.scm +++ b/scaffold/boot/60-let-syntax.scm @@ -55,10 +55,6 @@ (define (symbol? x) (eq? (core:type x) )) - (define (string->symbol s) - (if (not (pair? (core:car s))) '() - (list->symbol (core:car s)))) - (define (string? x) (eq? (core:type x) )) diff --git a/scaffold/mini-mes.c b/scaffold/mini-mes.c index e1366dd1..70e5ce04 100644 --- a/scaffold/mini-mes.c +++ b/scaffold/mini-mes.c @@ -218,7 +218,7 @@ struct scm scm_symbol_arch = {TSYMBOL, "%arch",0}; struct scm scm_test = {TSYMBOL, "test",0}; -#include "mes.mes.symbols.h" +#include "src/mes.mes.symbols.h" SCM tmp; SCM tmp_num; @@ -227,19 +227,19 @@ SCM tmp_num2; struct function g_functions[200]; int g_function = 0; -#include "gc.mes.h" -#include "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[]) diff --git a/scripts/mescc.in b/scripts/mescc.in index 4ea84daa..738b49d0 100755 --- a/scripts/mescc.in +++ b/scripts/mescc.in @@ -5,6 +5,10 @@ if [ "$V" = 2 ]; then fi prefix=${prefix-@prefix@} program_prefix=${program_prefix-@program_prefix@} +MES_ARENA=${MES_ARENA-100000000} +export MES_ARENA +MES_STACK=${MES_STACK-500000} +export MES_STACK MES_PREFIX=${MES_PREFIX-$prefix/share/mes} export MES_PREFIX mes_p=$(command -v mes) diff --git a/src/gc.c b/src/gc.c index 7dfb5831..498bd859 100644 --- a/src/gc.c +++ b/src/gc.c @@ -20,6 +20,8 @@ #include +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 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 (); diff --git a/src/hash.c b/src/hash.c index f2dee09c..ab963c38 100644 --- a/src/hash.c +++ b/src/hash.c @@ -23,11 +23,11 @@ SCM vector_ref_ (SCM x, long i); SCM vector_set_x_ (SCM x, long i, SCM e); int -hash_list_of_char (SCM lst, long size) +hash_cstring (char const* s, long size) { - int hash = VALUE (CAR (lst)) * 37; - 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); } diff --git a/src/lib.c b/src/lib.c index 3dd6dd35..e16dc653 100644 --- 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 ("#", 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)) diff --git a/src/mes.c b/src/mes.c index 48a91e24..e1752c94 100644 --- a/src/mes.c +++ b/src/mes.c @@ -20,6 +20,7 @@ #include #include +#include #include #include #include @@ -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; - SCM car; - SCM ref; - SCM string; - SCM variable; - long length; - }; - union { - long value; - long function; + 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 variable; + }; + union + { + long value; + 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_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, "*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_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, "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_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, "set!",0}; +struct scm scm_symbol_set_x = {TSYMBOL, 0, "set!"}; -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_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, "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_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, "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_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}; -struct scm scm_symbol_record_type = {TSYMBOL, "",0}; -struct scm scm_symbol_frame = {TSYMBOL, "",0}; -struct scm scm_symbol_module = {TSYMBOL, "",0}; -struct scm scm_symbol_stack = {TSYMBOL, "",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_hashq_table = {TSYMBOL, 0, ""}; +struct scm scm_symbol_record_type = {TSYMBOL, 0, ""}; +struct scm scm_symbol_frame = {TSYMBOL, 0, ""}; +struct scm scm_symbol_module = {TSYMBOL, 0, ""}; +struct scm scm_symbol_stack = {TSYMBOL, 0, ""}; +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, "%argv",0}; -struct scm scm_symbol_mes_prefix = {TSYMBOL, "%prefix",0}; -struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0}; +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, "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_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, "*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_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, "*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_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, "*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_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_char = {TSYMBOL, "",0}; -struct scm scm_type_closure = {TSYMBOL, "",0}; -struct scm scm_type_continuation = {TSYMBOL, "",0}; -struct scm scm_type_function = {TSYMBOL, "",0}; -struct scm scm_type_keyword = {TSYMBOL, "",0}; -struct scm scm_type_macro = {TSYMBOL, "",0}; -struct scm scm_type_number = {TSYMBOL, "",0}; -struct scm scm_type_pair = {TSYMBOL, "",0}; -struct scm scm_type_port = {TSYMBOL, "",0}; -struct scm scm_type_ref = {TSYMBOL, "",0}; -struct scm scm_type_special = {TSYMBOL, "",0}; -struct scm scm_type_string = {TSYMBOL, "",0}; -struct scm scm_type_struct = {TSYMBOL, "",0}; -struct scm scm_type_symbol = {TSYMBOL, "",0}; -struct scm scm_type_values = {TSYMBOL, "",0}; -struct scm scm_type_variable = {TSYMBOL, "",0}; -struct scm scm_type_vector = {TSYMBOL, "",0}; -struct scm scm_type_broken_heart = {TSYMBOL, "",0}; +struct scm scm_type_bytes = {TSYMBOL, 0, ""}; +struct scm scm_type_char = {TSYMBOL, 0, ""}; +struct scm scm_type_closure = {TSYMBOL, 0, ""}; +struct scm scm_type_continuation = {TSYMBOL, 0, ""}; +struct scm scm_type_function = {TSYMBOL, 0, ""}; +struct scm scm_type_keyword = {TSYMBOL, 0, ""}; +struct scm scm_type_macro = {TSYMBOL, 0, ""}; +struct scm scm_type_number = {TSYMBOL, 0, ""}; +struct scm scm_type_pair = {TSYMBOL, 0, ""}; +struct scm scm_type_port = {TSYMBOL, 0, ""}; +struct scm scm_type_ref = {TSYMBOL, 0, ""}; +struct scm scm_type_special = {TSYMBOL, 0, ""}; +struct scm scm_type_string = {TSYMBOL, 0, ""}; +struct scm scm_type_struct = {TSYMBOL, 0, ""}; +struct scm scm_type_symbol = {TSYMBOL, 0, ""}; +struct scm scm_type_values = {TSYMBOL, 0, ""}; +struct scm scm_type_variable = {TSYMBOL, 0, ""}; +struct scm scm_type_vector = {TSYMBOL, 0, ""}; +struct scm scm_type_broken_heart = {TSYMBOL, 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_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, "%%test",0}; +struct scm scm_test = {TSYMBOL, 0, "%%test"}; -#if !_POSIX_SOURCE -#include "mes.mes.symbols.h" +#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)); -} - // 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)) // 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" // 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=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 "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 "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/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 "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 "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/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; } diff --git a/src/module.c b/src/module.c index 484b121b..fcff1149 100644 --- a/src/module.c +++ b/src/module.c @@ -20,6 +20,7 @@ SCM struct_ref_ (SCM x, long i); SCM struct_set_x_ (SCM x, long i, SCM e); +SCM cstring_to_symbol (char const *s); SCM make_module_type () ///(internal)) @@ -101,7 +102,7 @@ module_variable (SCM module, SCM name) SCM module_ref (SCM module, SCM name) { - if (g_debug > 4) + if (g_debug > 3) { eputs ("module_ref: "); display_error_ (name); eputs ("\n"); } diff --git a/src/posix.c b/src/posix.c index 407d20c6..b7a3dac3 100644 --- a/src/posix.c +++ b/src/posix.c @@ -40,7 +40,12 @@ peekchar () return c; } SCM port = current_input_port (); - return VALUE (CAR (STRING (port))); + SCM string = STRING (port); + size_t length = LENGTH (string); + if (!length) + return -1; + char const *p = CSTRING (string); + return p[0]; } int @@ -50,10 +55,12 @@ readchar () return fdgetc (g_stdin); SCM port = current_input_port (); SCM string = STRING (port); - if (string == cell_nil) + size_t length = LENGTH (string); + if (!length) return -1; - int c = VALUE (CAR (string)); - 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; } diff --git a/src/reader.c b/src/reader.c index 5f4e3bec..86254ff8 100644 --- a/src/reader.c +++ b/src/reader.c @@ -21,8 +21,6 @@ #include -#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 index 00000000..fe86311a --- /dev/null +++ b/src/strings.c @@ -0,0 +1,242 @@ +/* -*-comment-start: "//";comment-end:""-*- + * GNU Mes --- Maxwell Equations of Software + * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen + * + * 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 . + */ + +#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); +} diff --git a/tests/base.test b/tests/base.test index 54cad53c..37a459ec 100755 --- a/tests/base.test +++ b/tests/base.test @@ -1,6 +1,9 @@ #! /bin/sh # -*-scheme-*- -exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests base)' -s "$0" "$@" +if [ "$MES" != guile ]; then + MES_BOOT=boot-03.scm exec ${MES-mes} < $0 +fi +exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@" !# ;;; -*-scheme-*- @@ -27,7 +30,12 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests #:use-module (mes mes-0) #:use-module (mes test)) -(mes-use-module (mes test)) +(cond-expand + (mes + (primitive-load "module/mes/test.scm")) + (guile-2) + (guile + (use-modules (ice-9 syncase)))) (pass-if "first dummy" #t) (pass-if-not "second dummy" #f) diff --git a/tests/boot.test b/tests/boot.test index da6a25cd..97a0ee18 100755 --- a/tests/boot.test +++ b/tests/boot.test @@ -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" "$@" !# diff --git a/tests/macro.test b/tests/macro.test index 0c874215..1ebaba92 100755 --- a/tests/macro.test +++ b/tests/macro.test @@ -57,19 +57,9 @@ exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests macr ;; type-0.mes (define (string . lst) - (core:make-cell 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)))) diff --git a/tests/optargs.test b/tests/optargs.test index 0207776e..06f1c53b 100755 --- a/tests/optargs.test +++ b/tests/optargs.test @@ -24,7 +24,7 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests ;;; along with GNU Mes. If not, see . (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) (cons text))) -;; (define* (make o #:key (functions '()) (globals '()) (locals '()) (text '())) -;; (format (current-error-port) "make\n") -;; ((cond ((info? o) -;; (list -;; (cons functions) -;; (cons globals) -;; (cons locals) -;; (cons text)))))) - (define (.functions o) (assq-ref (cdr o) )) @@ -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) ))) -;; FIXME: psyntax+pmatch+optarg is broken; BINDINGS-> (g1234 g1234) -;; iso (function function) -;; (define (clone o . rest) -;; (pmatch o -;; (( -;; ( . ,functions) -;; ( . ,globals) -;; ( . ,locals) -;; ( . ,text)) -;; (let-keywords rest -;; #f -;; ((functions functions) -;; (globals globals) -;; (locals locals) -;; (text text)) -;; (make #:functions functions #:globals globals #:locals locals #:text text))))) - (define (clone o . rest) (cond ((info? o) (let ((functions (.functions o)) diff --git a/tests/perform.test b/tests/perform.test index b9719532..1021b1f7 100755 --- a/tests/perform.test +++ b/tests/perform.test @@ -1,9 +1,8 @@ #! /bin/sh # -*-scheme-*- if [ "$MES" != guile ]; then - export MES_BOOT=boot-02.scm MES=${MES-$(dirname $0)/../src/mes} - $MES < $0 + MES_BOOT=boot-02.scm exec $MES < $0 exit $? fi exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests perform)' -s "$0" "$@" diff --git a/tests/posix.test b/tests/posix.test new file mode 100755 index 00000000..648306c2 --- /dev/null +++ b/tests/posix.test @@ -0,0 +1,40 @@ +#! /bin/sh +# -*-scheme-*- +exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests srfi-13)' -s "$0" "$@" +!# + +;;; -*-scheme-*- + +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; 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 . + +(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) diff --git a/tests/quasiquote.test b/tests/quasiquote.test index 85786b0b..38719cee 100755 --- a/tests/quasiquote.test +++ b/tests/quasiquote.test @@ -1,6 +1,9 @@ #! /bin/sh # -*-scheme-*- -exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests quasiquote)' -s "$0" "$@" +if [ "$MES" != guile ]; then + MES_BOOT=boot-03.scm exec ${MES-mes} < $0 +fi +exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@" !# ;;; -*-scheme-*- @@ -27,9 +30,12 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests #:use-module (mes mes-0) #:use-module (mes test)) -(mes-use-module (mes base)) -(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) diff --git a/tests/read.test b/tests/read.test index a6af905d..f307c122 100755 --- a/tests/read.test +++ b/tests/read.test @@ -22,9 +22,12 @@ # You should have received a copy of the GNU General Public License # along with GNU Mes. If not, see . +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 diff --git a/tests/scm.test b/tests/scm.test index c572eaeb..88c6b0db 100755 --- a/tests/scm.test +++ b/tests/scm.test @@ -1,6 +1,9 @@ #! /bin/sh # -*-scheme-*- -exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests scm)' -s "$0" "$@" +if [ "$MES" != guile ]; then + MES_BOOT=boot-03.scm exec ${MES-mes} < $0 +fi +exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@" !# ;;; -*-scheme-*- @@ -27,9 +30,12 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests #:use-module (mes mes-0) #:use-module (mes test)) -(mes-use-module (mes scm)) -(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)) diff --git a/tests/srfi-13.test b/tests/srfi-13.test index c1987f62..25bdc660 100755 --- a/tests/srfi-13.test +++ b/tests/srfi-13.test @@ -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)) diff --git a/tests/srfi-14.test b/tests/srfi-14.test index dd62034a..4ef1493a 100755 --- a/tests/srfi-14.test +++ b/tests/srfi-14.test @@ -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)