artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

core: String as array of bytes.

Browse source 
* src/strings.c: New file.
* src/mes.c: Use it.  Update users.
This commit is contained in:
Jan Nieuwenhuizen 2018-11-11 16:25:36 +01:00
parent 2e97dc1250
commit 149f2a3e51
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
60 changed files with 1792 additions and 913 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
build-aux/build-mes.sh
View file

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

8
build-aux/check-boot.sh
View file

@ -46,6 +46,12 @@ tests="
16-if-eq-quote.scm 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.scm
20-define-quoted.scm 20-define-quoted.scm
20-define-quote.scm 20-define-quote.scm
@ -99,6 +105,8 @@ tests="
4e-let-global.scm 4e-let-global.scm
4f-string-split.scm 4f-string-split.scm
50-string-append.scm
50-string-join.scm
50-primitive-load.scm 50-primitive-load.scm
51-module.scm 51-module.scm
52-define-module.scm 52-define-module.scm

1
build-aux/check-mes.sh
View file

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

4
build-aux/config.sh
View file

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

17
build-aux/mes-snarf.scm
View file

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

21
build-aux/snarf.sh
View file

@ -27,13 +27,14 @@ snarf=" "
if [ -n "$1" ]; then if [ -n "$1" ]; then
snarf=.mes snarf=.mes
fi fi
trace "SNARF$snarf gc.c" ${srcdest}build-aux/mes-snarf.scm $1 src/gc.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 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 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 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 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 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 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 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 strings.c" ${srcdest}build-aux/mes-snarf.scm $1 src/strings.c
trace "SNARF$snarf vector.c" ${srcdest}build-aux/mes-snarf.scm $1 src/vector.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

1
include/linux/x86_64/syscall.h
View file

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

1
include/signal.h
View file

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

2
lib/linux/gettimeofday.c
View file

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

10
lib/linux/gnu.c
View file

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

18
mes/module/mes/base.mes
View file

@ -101,6 +101,24 @@
(or (null? x) (or (null? x)
(and (pair? x) (list? (cdr 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) (define (procedure? p)
(cond ((builtin? p) #t) (cond ((builtin? p) #t)
((and (pair? p) (eq? (car p) 'lambda))) ((and (pair? p) (eq? (car p) 'lambda)))

52
mes/module/mes/boot-0.scm.in
View file

@ -52,18 +52,12 @@
(if (null? rest) (core:write x) (if (null? rest) (core:write x)
(core:write-port x (car rest)))) (core:write-port x (car rest))))
(define (list->string lst)
(core:make-cell <cell:string> lst 0))
(define (integer->char x) (define (integer->char x)
(core:make-cell <cell:char> 0 x)) (core:make-cell <cell:char> 0 x))
(define (newline . rest) (define (newline . rest)
(core:display (list->string (list (integer->char 10))))) (core:display (list->string (list (integer->char 10)))))
(define (string->list s)
(core:car s))
(define (cadr x) (car (cdr x))) (define (cadr x) (car (cdr x)))
(define (map1 f lst) (define (map1 f lst)
@ -107,7 +101,9 @@
#t) #t)
;; end boot-02.scm ;; 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 (primitive-eval e) (core:eval e (current-module)))
(define eval core:eval) (define eval core:eval)
@ -125,24 +121,6 @@
(if (null? t) (core:apply f h (current-module)) (if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t))))) (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) (define-macro (load file)
(list 'begin (list 'begin
(list 'if (list 'and (list getenv "MES_DEBUG") (list 'if (list 'and (list getenv "MES_DEBUG")
@ -161,9 +139,6 @@
(if (null? (cdr rest)) (car rest) (if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest)))))) (append2 (car rest) (apply append (cdr rest))))))
(define (string->list s)
(core:car s))
(define %prefix (getenv "MES_PREFIX")) (define %prefix (getenv "MES_PREFIX"))
(define %moduledir (define %moduledir
(if (not %prefix) "mes/module/" (if (not %prefix) "mes/module/"
@ -173,16 +148,9 @@
(include (list->string (include (list->string
(append2 (string->list %moduledir) (string->list "mes/type-0.mes")))) (append2 (string->list %moduledir) (string->list "mes/type-0.mes"))))
(define (symbol->string s)
(apply string (symbol->list s)))
(define (string-append . rest) (define (string-append . rest)
(apply string (apply append (map1 string->list 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") (if (and (getenv "MES_DEBUG")
(not (equal2? (getenv "MES_DEBUG") "0")) (not (equal2? (getenv "MES_DEBUG") "0"))
(not (equal2? (getenv "MES_DEBUG") "1"))) (not (equal2? (getenv "MES_DEBUG") "1")))
@ -205,6 +173,20 @@
(mes-use-module (mes quasiquote)) (mes-use-module (mes quasiquote))
(mes-use-module (mes let)) (mes-use-module (mes let))
(mes-use-module (mes scm)) (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-1))
(mes-use-module (srfi srfi-13)) (mes-use-module (srfi srfi-13))
(mes-use-module (mes fluids)) (mes-use-module (mes fluids))

6
mes/module/mes/boot-01.scm
View file

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

6
mes/module/mes/boot-02.scm
View file

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

186
mes/module/mes/boot-03.scm Normal file
View file

@ -0,0 +1,186 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; read-0.mes - bootstrap reader. This file is read by a minimal
;;; core reader. It only supports s-exps and line-comments; quotes,
;;; character literals, string literals cannot be used here.
;;; Code:
;; boot-00.scm
(define mes %version)
(define (defined? x)
(module-variable (current-module) x))
(define (cond-expand-expander clauses)
(if (defined? (car (car clauses)))
(cdr (car clauses))
(cond-expand-expander (cdr clauses))))
(define-macro (cond-expand . clauses)
(cons 'begin (cond-expand-expander clauses)))
;; end boot-00.scm
;; boot-01.scm
(define (not x) (if x #f #t))
(define (display x . rest)
(if (null? rest) (core:display x)
(core:display-port x (car rest))))
(define (write x . rest)
(if (null? rest) (core:write x)
(core:write-port x (car rest))))
(define (integer->char x)
(core:make-cell <cell:char> 0 x))
(define (newline . rest)
(core:display (list->string (list (integer->char 10)))))
(define (cadr x) (car (cdr x)))
(define (map1 f lst)
(if (null? lst) (list)
(cons (f (car lst)) (map1 f (cdr lst)))))
(define (map f lst)
(if (null? lst) (list)
(cons (f (car lst)) (map f (cdr lst)))))
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t)
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define (append . rest)
(if (null? rest) '()
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
;; end boot-01.scm
;; boot-02.scm
(define-macro (and . x)
(if (null? x) #t
(if (null? (cdr x)) (car x)
(list (quote if) (car x) (cons (quote and) (cdr x))
#f))))
(define-macro (or . x)
(if (null? x) #f
(if (null? (cdr x)) (car x)
(list (list (quote lambda) (list (quote r))
(list (quote if) (quote r) (quote r)
(cons (quote or) (cdr x))))
(car x)))))
(define-macro (mes-use-module module)
#t)
;; end boot-02.scm
;; boot-03.scm
(define guile? #f)
(define mes? #t)
(define (primitive-eval e) (core:eval e (current-module)))
(define eval core:eval)
(define (port-filename port) "<stdin>")
(define (port-line port) 0)
(define (port-column port) 0)
(define (ftell port) 0)
(define (false-if-exception x) x)
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t)
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define-macro (load file)
(list 'begin
(list 'if (list 'and (list getenv "MES_DEBUG")
(list not (list equal2? (list getenv "MES_DEBUG") "0"))
(list not (list equal2? (list getenv "MES_DEBUG") "1")))
(list 'begin
(list core:display-error ";;; read ")
(list core:display-error file)
(list core:display-error "\n")))
(list 'primitive-load file)))
(define-macro (include file) (list 'load file))
(define (append . rest)
(if (null? rest) '()
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
(define %prefix (getenv "MES_PREFIX"))
(define %moduledir
(if (not %prefix) "boe /share/mes/module/"
(list->string
(append (string->list %prefix) (string->list "/module/" )))))
(include (list->string
(append2 (string->list %moduledir) (string->list "mes/type-0.mes"))))
(define (string-append . rest)
(apply string (apply append (map1 string->list rest))))
(if (and (getenv "MES_DEBUG")
(not (equal2? (getenv "MES_DEBUG") "0"))
(not (equal2? (getenv "MES_DEBUG") "1")))
(begin
(core:display-error ";;; %moduledir=")
(core:display-error %moduledir)
(core:display-error "\n")))
(define-macro (include-from-path file)
(list 'load (list string-append %moduledir file)))
(define (string-join lst infix)
(if (null? lst) ""
(if (null? (cdr lst)) (car lst)
(string-append (car lst) infix (string-join (cdr lst) infix)))))
(include-from-path "mes/module.mes")
(mes-use-module (mes base))
(mes-use-module (mes quasiquote))
(mes-use-module (mes let))
(mes-use-module (mes scm))
(define-macro (define-module module . rest)
`(if ,(and (pair? module)
(= 1 (length module))
(symbol? (car module)))
(define (,(car module) . arguments) (main (command-line)))))
(define-macro (use-modules . rest) #t)
;; end boot-03.scm
(primitive-load 0)
(primitive-load 0)

59
mes/module/mes/display.mes
View file

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

2
mes/module/mes/scm.mes
View file

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

29
mes/module/mes/type-0.mes
View file

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

4
mes/module/srfi/srfi-13.mes
View file

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

31
module/mes/getopt-long.scm
View file

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

2
module/mes/guile.scm
View file

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

3
module/mes/misc.scm
View file

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

7
mes/module/mes/optargs.scm → module/mes/optargs.scm
View file

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

4
module/mescc/M1.scm
View file

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

5
module/mescc/compile.scm
View file

@ -910,8 +910,7 @@
((p-expr (fixed ,value)) ((p-expr (fixed ,value))
(let* ((value (cstring->int value)) (let* ((value (cstring->int value))
(info (allocate-register info)) (info (allocate-register info))
(info (append-text info (append (wrap-as (as info 'value->r value))))) (info (append-text info (wrap-as (as info 'value->r value)))))
(reg-size (->size "*" info)))
(if (or #t (> value 0) (= reg-size 4)) info (if (or #t (> value 0) (= reg-size 4)) info
(append-text info (wrap-as (as info 'long-signed-r)))))) (append-text info (wrap-as (as info 'long-signed-r))))))
@ -1208,7 +1207,7 @@
((rshift ,a ,b) ((binop->r info) a b 'r0>>r1)) ((rshift ,a ,b) ((binop->r info) a b 'r0>>r1))
((div ,a ,b) ((div ,a ,b)
((binop->r info) a b 'r0/r1 ((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 ((mod ,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)))))
((mul ,a ,b) ((binop->r info) a b 'r0*r1)) ((mul ,a ,b) ((binop->r info) a b 'r0*r1))

25
scaffold/boot/17-equal2.scm Normal file
View file

@ -0,0 +1,25 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(core:write (if (equal2? "" "") #t (exit 1)))
(core:write "\n")
(core:write (if (equal2? '("foo" "") '("foo" "")) #t (exit 1)))
(core:write "\n")
(core:write (if (equal2? '("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "") '("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "")) #t (exit 1)))
(core:write "\n")
(exit 0)

21
scaffold/boot/17-memq-keyword.scm Normal file
View file

@ -0,0 +1,21 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(if (memq '#:bar '(foo #:bar baz))
(exit 0))
(exit 1)

21
scaffold/boot/17-memq.scm Normal file
View file

@ -0,0 +1,21 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(if (memq 'bar '(foo bar baz))
(exit 0))
(exit 1)

36
scaffold/boot/17-open-input-string.scm Normal file
View file

@ -0,0 +1,36 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
((lambda (port)
(core:display-error "port:")
(core:write-error port)
(core:display-error "\n")
(set-current-input-port port)
(core:display-error "current:")
(core:write-error (current-input-port))
(core:display-error "\n")
(core:display-error "read:")
((lambda (string)
(core:write-error string)
(core:display-error "\n")
(core:display-error "empty:")
(core:write-error port)
(core:display-error "\n")
(exit (if (equal2? string "foo bar\n") 0 1)))
((if (pair? (current-module)) read-string (@ (ice-9 rdelim) read-string)) port)))
(open-input-string "foo bar\n"))

23
scaffold/boot/17-string-equal.scm Normal file
View file

@ -0,0 +1,23 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(core:write (if (string=? "" "") #t (exit 1)))
(core:write (if (string=? "foo" "foo") #t (exit 1)))
(core:write (if (string=? "" "foo") (exit 1)))
(core:write "\n")
(exit 0)

6
scaffold/boot/4f-string-split.scm
View file

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

23
scaffold/boot/50-keyword.scm Normal file
View file

@ -0,0 +1,23 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(core:display-error "symbol->keyword\n")
(core:write (symbol->keyword 'foo))
(core:display-error "\n")
(core:write (keyword->string #:bar))
(core:display-error "dun\n")

59
scaffold/boot/50-make-string.scm Normal file
View file

@ -0,0 +1,59 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(cond-expand
(guile)
(mes
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t)
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define (append . rest)
(if (null? rest) '()
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
(define (string . lst)
(list->string lst))
(define (map1 f lst)
(if (null? lst) (list)
(cons (f (car lst)) (map1 f (cdr lst)))))
(define map map1)
(define (string-append . rest)
(apply string (apply append (map string->list rest))))))
(define (make-list n . fill)
fill)
(define (make-string n . fill)
(list->string (apply make-list n fill)))
;;(make-string 1 (option-spec->single-char spec))
(core:write-error (make-string 1 #\a))
;;(core:write-error (list->string '(#\a #\b #\c)))
;; (if (string=? (string-append "foo" "/" "bar") "foo/bar")
;; (exit 0))
;; (exit 1)

49
scaffold/boot/50-string-append.scm Normal file
View file

@ -0,0 +1,49 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(cond-expand
(guile)
(mes
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t)
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define (append . rest)
(if (null? rest) '()
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
(define (string . lst)
(list->string lst))
(define (map1 f lst)
(if (null? lst) (list)
(cons (f (car lst)) (map1 f (cdr lst)))))
(define map map1)
(define (string-append . rest)
(apply string (apply append (map string->list rest))))))
(if (string=? (string-append "foo" "/" "bar") "foo/bar")
(exit 0))
(exit 1)

53
scaffold/boot/50-string-join.scm Normal file
View file

@ -0,0 +1,53 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(cond-expand
(guile)
(mes
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t)
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define (append . rest)
(if (null? rest) '()
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
(define (string . lst)
(list->string lst))
(define (map1 f lst)
(if (null? lst) (list)
(cons (f (car lst)) (map1 f (cdr lst)))))
(define map map1)
(define (string-append . rest)
(apply string (apply append (map string->list rest))))))
(define (string-join lst infix)
(if (null? (cdr lst)) (car lst)
(string-append (car lst) infix (string-join (cdr lst) infix))))
(if (string=? (string-join '("foo" "bar") "/") "foo/bar")
(exit 0))
(exit 1)

23
scaffold/boot/51-module.scm
View file

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

21
scaffold/boot/52-define-module.scm
View file

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

9
scaffold/boot/60-let-syntax-expanded.scm
View file

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

4
scaffold/boot/60-let-syntax.scm
View file

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

61
scaffold/mini-mes.c
View file

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

4
scripts/mescc.in
View file

@ -5,6 +5,10 @@ if [ "$V" = 2 ]; then
fi fi
prefix=${prefix-@prefix@} prefix=${prefix-@prefix@}
program_prefix=${program_prefix-@program_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} MES_PREFIX=${MES_PREFIX-$prefix/share/mes}
export MES_PREFIX export MES_PREFIX
mes_p=$(command -v mes) mes_p=$(command -v mes)

35
src/gc.c
View file

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

14
src/hash.c
View file

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

81
src/lib.c
View file

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

1044
src/mes.c
View file

File diff suppressed because it is too large Load diff

3
src/module.c
View file

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

105
src/posix.c
View file

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

66
src/reader.c
View file

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

242
src/strings.c Normal file
View file

@ -0,0 +1,242 @@
/* -*-comment-start: "//";comment-end:""-*-
* GNU Mes --- Maxwell Equations of Software
* Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
*
* This file is part of GNU Mes.
*
* GNU Mes is free software; you can redistribute it and/or modify it
* under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 3 of the License, or (at
* your option) any later version.
*
* GNU Mes is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#define MAX_STRING 4096
char const*
list_to_cstring (SCM list, size_t* size)
{
static char buf[MAX_STRING];
size_t i = 0;
char *p = buf;
while (list != cell_nil)
{
assert (i < MAX_STRING);
buf[i++] = VALUE (car (list));
list = cdr (list);
}
buf[i] = 0;
*size = i;
return buf;
}
size_t
bytes_cells (size_t length)
{
return (1 + sizeof (long) + sizeof (long) + length + sizeof (SCM)) / sizeof (SCM);
}
SCM
make_bytes (char const* s, size_t length)
{
size_t size = bytes_cells (length);
SCM x = alloc (size);
TYPE (x) = TBYTES;
LENGTH (x) = length;
char *p = &g_cells[x].cdr;
if (!length)
*(char*)p = 0;
else
memcpy (p, s, length + 1);
if (g_debug > 2)
{
eputs ("make bytes: "); eputs (s); eputs ("\n");
eputs (" bytes: "); eputs (CBYTES (x)); eputs ("\n");
eputs (" length: "); eputs (itoa (length)); eputs ("\n");
eputs (" ==> "); write_error_ (x);
eputs ("\n");
}
return x;
}
SCM
make_string (char const* s, size_t length)
{
assert (length < HALFLONG_MAX);
SCM x = make_cell__ (TSTRING, length, 0);
SCM v = make_bytes (s, length);
CDR (x) = v;
return x;
}
SCM
string_equal_p (SCM a, SCM b) ///((name . "string=?"))
{
if (! ((TYPE (a) == TSTRING && TYPE (b) == TSTRING)
|| (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD)))
{
eputs ("type a: "); eputs (itoa (TYPE (a))); eputs ("\n");
eputs ("type b: "); eputs (itoa (TYPE (b))); eputs ("\n");
eputs ("a= "); write_error_ (a); eputs ("\n");
eputs ("b= "); write_error_ (b); eputs ("\n");
assert ((TYPE (a) == TSTRING && TYPE (b) == TSTRING)
|| (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD));
}
if (g_debug == -1)
{
eputs ("string=?: "); eputs (CSTRING (a));
eputs (" =? "); eputs (CSTRING (b));
}
if (a == b
|| STRING (a) == STRING (b)
|| (!LENGTH (a) && !LENGTH (b))
|| (LENGTH (a) == LENGTH (b)
&& !memcmp (CSTRING (a), CSTRING (b), LENGTH (a))))
{
if (g_debug == -1)
eputs (" => #t\n");
return cell_t;
}
if (g_debug == -1)
eputs (" => #f\n");
return cell_f;
}
SCM
symbol_to_string (SCM symbol)
{
SCM x = make_cell__ (TSTRING, CAR (symbol), CDR (symbol));
if (g_debug > 2)
{
eputs ("symbol->string: "); eputs (CSTRING (x)); eputs ("\n");
eputs (" was: "); write_error_ (symbol);
eputs ("==> "); write_error_ (x);
eputs ("\n");
}
return x;
}
SCM
symbol_to_keyword (SCM symbol)
{
SCM x = make_cell__ (TKEYWORD, CAR (symbol), CDR (symbol));
if (g_debug > 2)
{
eputs ("symbol->keyword: "); eputs (CSTRING (x)); eputs ("\n");
eputs (" was: "); write_error_ (symbol);
eputs ("==> "); write_error_ (x);
eputs ("\n");
}
return x;
}
SCM
keyword_to_string (SCM keyword)
{
SCM x = make_cell__ (TSTRING, CAR (keyword), CDR (keyword));
if (g_debug > 2)
{
eputs ("keyword->string: "); eputs (CSTRING (x)); eputs ("\n");
eputs (" was: "); write_error_ (keyword);
eputs ("==> "); write_error_ (x);
eputs ("\n");
}
return x;
}
SCM
string_to_symbol (SCM string)
{
SCM x = hash_ref (g_symbols, string, cell_f);
if (x == cell_f)
x = make_symbol (string);
return x;
}
SCM
make_symbol (SCM string)
{
SCM x = make_cell__ (TSYMBOL, LENGTH (string), STRING (string));
hash_set_x (g_symbols, string, x);
if (g_debug > 3)
hash_table_printer (g_symbols);
if (g_debug > 2)
{
eputs ("make_symbol: "); eputs (CSTRING (string)); eputs ("\n");
eputs ("==> "); write_error_ (x);
eputs ("\n");
}
return x;
}
SCM
bytes_to_list (char const* s, size_t i)
{
SCM p = cell_nil;
while (i--)
{
int c = (0x100 + s[i]) % 0x100;
p = cons (MAKE_CHAR (c), p);
}
return p;
}
SCM
cstring_to_list (char const* s)
{
return bytes_to_list (s, strlen (s));
}
SCM
cstring_to_symbol (char const *s)
{
SCM string = MAKE_STRING0 (s);
return string_to_symbol (string);
}
SCM
string_to_list (SCM string)
{
return bytes_to_list (CSTRING (string), LENGTH (string));
}
SCM
list_to_string (SCM list)
{
size_t size;
char const *s = list_to_cstring (list, &size);
return make_string (s, size);
}
SCM
read_string (SCM port) ///((arity . n))
{
int fd = g_stdin;
if (TYPE (port) == TPAIR && TYPE (car (port)) == TNUMBER)
g_stdin = VALUE (CAR (port));
int c = readchar ();
static char buf[MAX_STRING];
size_t i = 0;
while (c != -1)
{
assert (i < MAX_STRING);
buf[i++] = c;
c = readchar ();
}
buf[i] = 0;
g_stdin = fd;
return make_string (buf, i);
}

12
tests/base.test
View file

@ -1,6 +1,9 @@
#! /bin/sh #! /bin/sh
# -*-scheme-*- # -*-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-*- ;;; -*-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 mes-0)
#:use-module (mes test)) #: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 "first dummy" #t)
(pass-if-not "second dummy" #f) (pass-if-not "second dummy" #f)

5
tests/boot.test
View file

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

12
tests/macro.test
View file

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

28
tests/optargs.test
View file

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

3
tests/perform.test
View file

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

40
tests/posix.test Executable file
View file

@ -0,0 +1,40 @@
#! /bin/sh
# -*-scheme-*-
exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests srfi-13)' -s "$0" "$@"
!#
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(define-module (tests srfi-13)
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (srfi srfi-13))
(mes-use-module (mes test))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)
(pass-if-eq "system*" 0 (system* "true"))
(pass-if-eq "system*" 256 (system* "false"))
(result 'report)

14
tests/quasiquote.test
View file

@ -1,6 +1,9 @@
#! /bin/sh #! /bin/sh
# -*-scheme-*- # -*-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-*- ;;; -*-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 mes-0)
#:use-module (mes test)) #:use-module (mes test))
(mes-use-module (mes base)) (cond-expand
(mes-use-module (mes quasiquote)) (mes
(mes-use-module (mes test)) (primitive-load "module/mes/test.scm"))
(guile-2)
(guile
(use-modules (ice-9 syncase))))
(pass-if "first dummy" #t) (pass-if "first dummy" #t)
(pass-if-not "second dummy" #f) (pass-if-not "second dummy" #f)

7
tests/read.test
View file

@ -22,9 +22,12 @@
# You should have received a copy of the GNU General Public License # You should have received a copy of the GNU General Public License
# along with GNU Mes. If not, see <http://www.gnu.org/licenses/>. # along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
if [ "$MES" != guile ]; then
MES=${MES-$(dirname $0)/../src/mes}
MES_BOOT=boot-02.scm exec $MES < $0
fi
MES=${MES-$(dirname $0)/../src/mes} exec ${MES-mes} --no-auto-compile -s $0
exec $MES -s $0
!# !#
0 0

30
tests/scm.test
View file

@ -1,6 +1,9 @@
#! /bin/sh #! /bin/sh
# -*-scheme-*- # -*-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-*- ;;; -*-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 mes-0)
#:use-module (mes test)) #:use-module (mes test))
(mes-use-module (mes scm)) (cond-expand
(mes-use-module (srfi srfi-0)) (mes
(mes-use-module (mes test)) (primitive-load "module/mes/test.scm"))
(guile-2)
(guile
(use-modules (ice-9 syncase))))
(pass-if "first dummy" #t) (pass-if "first dummy" #t)
(pass-if-not "second dummy" #f) (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" (pass-if-equal "iota -1"
'() (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 "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)) (pass-if "apply identity" (seq? (apply identity '(0)) 0))

37
tests/srfi-13.test
View file

@ -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 "first dummy" #t)
(pass-if-not "second dummy" #f) (pass-if-not "second dummy" #f)
(pass-if "string=?"
(string=? "foo" "foo"))
(pass-if "string=?"
(let ((empty ""))
(string=? "" empty)))
(pass-if-equal "string-join" (pass-if-equal "string-join"
"foo bar" "foo bar"
(string-join '("foo" "bar"))) (string-join '("foo" "bar")))
(pass-if-equal "string-join infix" (pass-if-equal "string-join infix"
"foo+bar" "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 INT-MIN" "-2147483648" (number->string -2147483648))
(pass-if-equal "number->string" "-4" (number->string -4)) (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" (pass-if-equal "string-fold"
"oof" "oof"
(list->string (string-fold cons '() "foo"))) (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" (pass-if-equal "string-replace" "fubar"
(string-replace "foobar" "u" 1 3)) (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)) (result 'report (if (and (or #t (equal? %compiler "gnuc")) (equal? %arch "x86")) 1 0))

2
tests/srfi-14.test
View file

@ -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)))) (char-set= (char-set #\a #\b #\c) (list->char-set '(#\a #\b #\c))))
(pass-if "string->char-set!" (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) (result 'report)