Compare commits
49 Commits
master
...
wip-symbol
Author | SHA1 | Date |
---|---|---|
Jan Nieuwenhuizen | 759888cec6 | |
Jan Nieuwenhuizen | d71a0b6052 | |
Jan Nieuwenhuizen | b9d90be4f5 | |
Jan Nieuwenhuizen | 742264c6c1 | |
Jan Nieuwenhuizen | 60a9357e4c | |
Jan Nieuwenhuizen | f8b8b8a5d1 | |
Jan Nieuwenhuizen | 99ec582c74 | |
Jan Nieuwenhuizen | 79adcfc61e | |
Jan Nieuwenhuizen | f602f3d845 | |
Jan Nieuwenhuizen | 40c1166013 | |
Jan Nieuwenhuizen | 297fdb7026 | |
Jan Nieuwenhuizen | 0720990023 | |
Jan Nieuwenhuizen | 615b1e97a2 | |
Jan Nieuwenhuizen | b7819a3c7d | |
Jan Nieuwenhuizen | 46ce2c71cd | |
Jan Nieuwenhuizen | 6e00070b28 | |
Jan Nieuwenhuizen | 65d0d866bb | |
Jan Nieuwenhuizen | b0e552ac0c | |
Jan Nieuwenhuizen | 5a8024ca82 | |
Jan Nieuwenhuizen | f660d149a5 | |
Jan Nieuwenhuizen | 509ebb038a | |
Jan Nieuwenhuizen | 7838df8d6c | |
Jan Nieuwenhuizen | 613ce2b12a | |
Jan Nieuwenhuizen | 75b2590017 | |
Jan Nieuwenhuizen | 5427af9754 | |
Jan Nieuwenhuizen | c8c03c19dd | |
Jan Nieuwenhuizen | cfae3ed7fe | |
Jan Nieuwenhuizen | faeab8353e | |
Jan Nieuwenhuizen | c4b74ae9e3 | |
Jan Nieuwenhuizen | 79383565aa | |
Jan Nieuwenhuizen | 6a720e2323 | |
Jan Nieuwenhuizen | 5144032050 | |
Jan Nieuwenhuizen | 2e5d757aba | |
Jan Nieuwenhuizen | 64b9eee1bc | |
Jan Nieuwenhuizen | 5d2a6c7347 | |
Jan Nieuwenhuizen | f14d63b621 | |
Jan Nieuwenhuizen | 83b0d35f5c | |
Jan Nieuwenhuizen | ba6c091549 | |
Jan Nieuwenhuizen | 24cf9eb4e7 | |
Jan Nieuwenhuizen | 0b4a22c4f7 | |
Jan Nieuwenhuizen | 8a48e22231 | |
Jan Nieuwenhuizen | fc1e39a505 | |
Peter De Wachter | bb5ad2e6f7 | |
Peter De Wachter | b88d0121c6 | |
Peter De Wachter | 29e88ebece | |
Peter De Wachter | 014712a995 | |
Peter De Wachter | 93a2d13e7a | |
Peter De Wachter | 5ea7d8b6bb | |
Jan Nieuwenhuizen | 2036a9de0c |
7
AUTHORS
7
AUTHORS
|
@ -18,6 +18,13 @@ scaffold/tests/98-fopen.c
|
||||||
Han-Wen Nienhuys <hanwen@xs4all.nl>
|
Han-Wen Nienhuys <hanwen@xs4all.nl>
|
||||||
lib/string/memmem.c (_memmem, memmem)
|
lib/string/memmem.c (_memmem, memmem)
|
||||||
|
|
||||||
|
Peter de Wachter
|
||||||
|
Small fixes and additions to
|
||||||
|
lib/x86-mes/x86.M1
|
||||||
|
lib/x86_64-mes/x86_64.M1
|
||||||
|
include/stdint.h
|
||||||
|
module/mescc/compile.mes
|
||||||
|
|
||||||
rain1
|
rain1
|
||||||
scaffold/tests/90-goto-var.c
|
scaffold/tests/90-goto-var.c
|
||||||
scaffold/tests/91-goto-array.c
|
scaffold/tests/91-goto-array.c
|
||||||
|
|
48
NEWS
48
NEWS
|
@ -10,6 +10,54 @@ Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||||
|
|
||||||
Please send Mes bug reports to bug-mes@gnu.org.
|
Please send Mes bug reports to bug-mes@gnu.org.
|
||||||
|
|
||||||
|
* Changes in 0.19 since 0.18
|
||||||
|
** Core
|
||||||
|
*** Mes now prints a backtrace upon error.
|
||||||
|
*** Performance has been improved 2-8 times, making Mes 2-10 times slower than Guile.
|
||||||
|
*** Mes now supports a module type and uses a `boot-module'.
|
||||||
|
*** Mes now supports a hash_table type.
|
||||||
|
*** Mes now supports a struct type.
|
||||||
|
*** Mes now supports building a %bootstrap-mes seed from Guix.
|
||||||
|
** Language
|
||||||
|
*** Records are now implemented using struct (WAS: vector).
|
||||||
|
*** 30 new functions
|
||||||
|
ceil,
|
||||||
|
current-time,
|
||||||
|
floor,
|
||||||
|
frame-printer,
|
||||||
|
get-internal-run-time,
|
||||||
|
gettimeofday,
|
||||||
|
hash,
|
||||||
|
hash-ref,
|
||||||
|
hash-set!,
|
||||||
|
hash-table-printer,
|
||||||
|
hashq,
|
||||||
|
hashq-get-handle,
|
||||||
|
hashq-ref,
|
||||||
|
hashq-set,
|
||||||
|
inexact->exact,
|
||||||
|
make-hash-table,
|
||||||
|
make-stack,
|
||||||
|
make-struct,
|
||||||
|
module-define!
|
||||||
|
module-printer,
|
||||||
|
module-ref,
|
||||||
|
module-variable,
|
||||||
|
round,
|
||||||
|
stack-length,
|
||||||
|
stack-ref,
|
||||||
|
struct-ref,
|
||||||
|
struct-set!
|
||||||
|
struct-vtable,
|
||||||
|
struct-vtable,
|
||||||
|
struct_length.
|
||||||
|
** MesCC
|
||||||
|
*** Assembly defines have been cleaned-up: duplicates deleted, missing added, wrong fixed.
|
||||||
|
** Noteworthy bug fixes
|
||||||
|
*** MesCC now supports the unary plus operator.
|
||||||
|
*** MesCC now supports the `U' integer suffix.
|
||||||
|
*** MesCC now comes with INTnn_MIN/MAX, UINTnn defines in stdint.h.
|
||||||
|
*** MesCC now always exits non-zero when assembler or linker fail.
|
||||||
* Changes in 0.18 since 0.17.1
|
* Changes in 0.18 since 0.17.1
|
||||||
** Core
|
** Core
|
||||||
*** Mes/MesCC now supports x86_64.
|
*** Mes/MesCC now supports x86_64.
|
||||||
|
|
|
@ -24,13 +24,7 @@ set -e
|
||||||
. ${srcdest}build-aux/trace.sh
|
. ${srcdest}build-aux/trace.sh
|
||||||
|
|
||||||
# native
|
# native
|
||||||
trace "SNARF gc.c" ${srcdest}build-aux/mes-snarf.scm src/gc.c
|
sh ${srcdest}build-aux/snarf.sh
|
||||||
trace "SNARF lib.c" ${srcdest}build-aux/mes-snarf.scm src/lib.c
|
|
||||||
trace "SNARF math.c" ${srcdest}build-aux/mes-snarf.scm src/math.c
|
|
||||||
trace "SNARF mes.c" ${srcdest}build-aux/mes-snarf.scm src/mes.c
|
|
||||||
trace "SNARF posix.c" ${srcdest}build-aux/mes-snarf.scm src/posix.c
|
|
||||||
trace "SNARF reader.c" ${srcdest}build-aux/mes-snarf.scm src/reader.c
|
|
||||||
trace "SNARF vector.c" ${srcdest}build-aux/mes-snarf.scm src/vector.c
|
|
||||||
|
|
||||||
ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc.sh lib/libmes
|
ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc.sh lib/libmes
|
||||||
sh ${srcdest}build-aux/cc.sh src/mes
|
sh ${srcdest}build-aux/cc.sh src/mes
|
||||||
|
|
|
@ -27,23 +27,7 @@ LIBC=${LIBC-c}
|
||||||
|
|
||||||
##moduledir=${moduledir-${datadir}${datadir:+/}module}
|
##moduledir=${moduledir-${datadir}${datadir:+/}module}
|
||||||
|
|
||||||
# native
|
sh ${srcdest}build-aux/snarf.sh --mes
|
||||||
# trace "SNARF gc.c" ${srcdest}build-aux/mes-snarf.scm src/gc.c
|
|
||||||
# trace "SNARF lib.c" ${srcdest}build-aux/mes-snarf.scm src/lib.c
|
|
||||||
# trace "SNARF math.c" ${srcdest}build-aux/mes-snarf.scm src/math.c
|
|
||||||
# trace "SNARF mes.c" ${srcdest}build-aux/mes-snarf.scm src/mes.c
|
|
||||||
# trace "SNARF posix.c" ${srcdest}build-aux/mes-snarf.scm src/posix.c
|
|
||||||
# trace "SNARF reader.c" ${srcdest}build-aux/mes-snarf.scm src/reader.c
|
|
||||||
# trace "SNARF vector.c" ${srcdest}build-aux/mes-snarf.scm src/vector.c
|
|
||||||
|
|
||||||
# cc32-mes
|
|
||||||
trace "SNARF.mes gc.c" ${srcdest}build-aux/mes-snarf.scm --mes src/gc.c
|
|
||||||
trace "SNARF.mes lib.c" ${srcdest}build-aux/mes-snarf.scm --mes src/lib.c
|
|
||||||
trace "SNARF.mes math.c" ${srcdest}build-aux/mes-snarf.scm --mes src/math.c
|
|
||||||
trace "SNARF.mes mes.c" ${srcdest}build-aux/mes-snarf.scm --mes src/mes.c
|
|
||||||
trace "SNARF.mes posix.c" ${srcdest}build-aux/mes-snarf.scm --mes src/posix.c
|
|
||||||
trace "SNARF.mes reader.c" ${srcdest}build-aux/mes-snarf.scm --mes src/reader.c
|
|
||||||
trace "SNARF.mes vector.c" ${srcdest}build-aux/mes-snarf.scm --mes src/vector.c
|
|
||||||
|
|
||||||
ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc32-mes.sh lib/linux/x86-mes-gcc/crt0
|
ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc32-mes.sh lib/linux/x86-mes-gcc/crt0
|
||||||
ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc32-mes.sh lib/linux/x86-mes-gcc/crt1
|
ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc32-mes.sh lib/linux/x86-mes-gcc/crt1
|
||||||
|
|
|
@ -26,13 +26,7 @@ set -e
|
||||||
LIBC=${LIBC-c}
|
LIBC=${LIBC-c}
|
||||||
|
|
||||||
# cc64-mes
|
# cc64-mes
|
||||||
trace "SNARF.mes gc.c" ${srcdest}build-aux/mes-snarf.scm --mes src/gc.c
|
sh ${srcdest}build-aux/snarf.sh --mes
|
||||||
trace "SNARF.mes lib.c" ${srcdest}build-aux/mes-snarf.scm --mes src/lib.c
|
|
||||||
trace "SNARF.mes math.c" ${srcdest}build-aux/mes-snarf.scm --mes src/math.c
|
|
||||||
trace "SNARF.mes mes.c" ${srcdest}build-aux/mes-snarf.scm --mes src/mes.c
|
|
||||||
trace "SNARF.mes posix.c" ${srcdest}build-aux/mes-snarf.scm --mes src/posix.c
|
|
||||||
trace "SNARF.mes reader.c" ${srcdest}build-aux/mes-snarf.scm --mes src/reader.c
|
|
||||||
trace "SNARF.mes vector.c" ${srcdest}build-aux/mes-snarf.scm --mes src/vector.c
|
|
||||||
|
|
||||||
ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc64-mes.sh lib/linux/x86_64-mes-gcc/crt0
|
ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc64-mes.sh lib/linux/x86_64-mes-gcc/crt0
|
||||||
ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc64-mes.sh lib/linux/x86_64-mes-gcc/crt1
|
ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc64-mes.sh lib/linux/x86_64-mes-gcc/crt1
|
||||||
|
|
|
@ -128,13 +128,7 @@ ARCHDIR=1 NOLINK=1 bash ${srcdest}build-aux/cc-mes.sh lib/libc+gnu
|
||||||
ARCHDIR=1 NOLINK=1 bash ${srcdest}build-aux/cc-mes.sh lib/libgetopt
|
ARCHDIR=1 NOLINK=1 bash ${srcdest}build-aux/cc-mes.sh lib/libgetopt
|
||||||
|
|
||||||
MES_ARENA=${MES_ARENA-100000000}
|
MES_ARENA=${MES_ARENA-100000000}
|
||||||
trace "SNARF.mes gc.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/gc.c
|
sh ${srcdest}build-aux/snarf.sh --mes
|
||||||
trace "SNARF.mes lib.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/lib.c
|
|
||||||
trace "SNARF.mes math.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/math.c
|
|
||||||
trace "SNARF.mes mes.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/mes.c
|
|
||||||
trace "SNARF.mes posix.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/posix.c
|
|
||||||
trace "SNARF.mes reader.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/reader.c
|
|
||||||
trace "SNARF.mes vector.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/vector.c
|
|
||||||
|
|
||||||
if [ -n "$SEED" ]; then
|
if [ -n "$SEED" ]; then
|
||||||
bash ${srcdest}build-aux/cc-mes.sh src/mes
|
bash ${srcdest}build-aux/cc-mes.sh src/mes
|
||||||
|
|
|
@ -123,13 +123,7 @@ ARCHDIR=1 NOLINK=1 bash ${srcdest}build-aux/cc-x86_64-mes.sh lib/libc+gnu
|
||||||
ARCHDIR=1 NOLINK=1 bash ${srcdest}build-aux/cc-x86_64-mes.sh lib/libgetopt
|
ARCHDIR=1 NOLINK=1 bash ${srcdest}build-aux/cc-x86_64-mes.sh lib/libgetopt
|
||||||
|
|
||||||
MES_ARENA=${MES_ARENA-100000000}
|
MES_ARENA=${MES_ARENA-100000000}
|
||||||
trace "SNARF.mes gc.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/gc.c
|
sh ${srcdest}build-aux/snarf.sh --mes
|
||||||
trace "SNARF.mes lib.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/lib.c
|
|
||||||
trace "SNARF.mes math.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/math.c
|
|
||||||
trace "SNARF.mes mes.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/mes.c
|
|
||||||
trace "SNARF.mes posix.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/posix.c
|
|
||||||
trace "SNARF.mes reader.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/reader.c
|
|
||||||
trace "SNARF.mes vector.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/vector.c
|
|
||||||
|
|
||||||
if [ -n "$SEED" ]; then
|
if [ -n "$SEED" ]; then
|
||||||
bash ${srcdest}build-aux/cc-mes.sh src/mes
|
bash ${srcdest}build-aux/cc-mes.sh src/mes
|
||||||
|
|
|
@ -34,6 +34,9 @@ MES_ARENA=${MES_ARENA-100000000}
|
||||||
tests="
|
tests="
|
||||||
tests/boot.test
|
tests/boot.test
|
||||||
tests/read.test
|
tests/read.test
|
||||||
|
tests/srfi-0.test
|
||||||
|
tests/macro.test
|
||||||
|
tests/perform.test
|
||||||
tests/base.test
|
tests/base.test
|
||||||
tests/quasiquote.test
|
tests/quasiquote.test
|
||||||
tests/let.test
|
tests/let.test
|
||||||
|
|
|
@ -219,6 +219,7 @@ t
|
||||||
97-fopen
|
97-fopen
|
||||||
98-fopen
|
98-fopen
|
||||||
99-readdir
|
99-readdir
|
||||||
|
9a-snprintf
|
||||||
a0-call-trunc-char
|
a0-call-trunc-char
|
||||||
a0-call-trunc-short
|
a0-call-trunc-short
|
||||||
a0-call-trunc-int
|
a0-call-trunc-int
|
||||||
|
|
|
@ -146,8 +146,8 @@ exec ${GUILE-guile} --no-auto-compile -L $(dirname $0) -C $(dirname $0) -e '(mes
|
||||||
(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].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)))
|
(format #f "g_cells[cell_~a].car = MAKE_STRING (scm_~a.car);\n" (function.name f) (function.name f)))
|
||||||
(if %gcc?
|
(if %gcc?
|
||||||
(format #f "a = acons (lookup_symbol_ (scm_~a.string), ~a, a);\n\n" (function.name f) (function-cell-name f))
|
(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 (lookup_symbol_ (scm_~a.car), ~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)
|
||||||
|
|
|
@ -0,0 +1,39 @@
|
||||||
|
#! /bin/sh
|
||||||
|
|
||||||
|
# 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/>.
|
||||||
|
|
||||||
|
set -e
|
||||||
|
|
||||||
|
. ${srcdest}build-aux/config.sh
|
||||||
|
. ${srcdest}build-aux/trace.sh
|
||||||
|
|
||||||
|
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
|
|
@ -33,7 +33,7 @@ Documentation License''.
|
||||||
@end direntry
|
@end direntry
|
||||||
|
|
||||||
@titlepage
|
@titlepage
|
||||||
@title Mes Reference Manual
|
@title GNU Mes Reference Manual
|
||||||
@subtitle Full Source Bootstrapping of the GNU GuixSD Operating System
|
@subtitle Full Source Bootstrapping of the GNU GuixSD Operating System
|
||||||
@author Jan (janneke) Nieuwenhuizen
|
@author Jan (janneke) Nieuwenhuizen
|
||||||
|
|
||||||
|
@ -49,7 +49,7 @@ Edition @value{EDITION} @*
|
||||||
|
|
||||||
@c *********************************************************************
|
@c *********************************************************************
|
||||||
@node Top
|
@node Top
|
||||||
@top Mes
|
@top GNU Mes
|
||||||
|
|
||||||
This document describes GNU Mes version @value{VERSION}, a bootstrappable
|
This document describes GNU Mes version @value{VERSION}, a bootstrappable
|
||||||
Scheme interpreter and C compiler written for bootstrapping the GNU system.
|
Scheme interpreter and C compiler written for bootstrapping the GNU system.
|
||||||
|
@ -1039,7 +1039,7 @@ Please send bug reports with full details to @email{bug-mes@@gnu.org}.
|
||||||
@chapter Acknowledgments
|
@chapter Acknowledgments
|
||||||
|
|
||||||
We would like to thank the following people for their help: Jeremiah
|
We would like to thank the following people for their help: Jeremiah
|
||||||
Orians, pdewacht, rain1, Ricardo Wurmus, Rutger van Beusekom.
|
Orians, Peter de Wachter, rain1, Ricardo Wurmus, Rutger van Beusekom.
|
||||||
|
|
||||||
We also thank Ludovic Courtès for creating GuixSD and making the
|
We also thank Ludovic Courtès for creating GuixSD and making the
|
||||||
bootstrap problem so painfully visible, John McCarthy for creating
|
bootstrap problem so painfully visible, John McCarthy for creating
|
||||||
|
|
|
@ -43,6 +43,7 @@ int isspace (int c);
|
||||||
int isxdigit (int c);
|
int isxdigit (int c);
|
||||||
int _open3 (char const *file_name, int flags, int mask);
|
int _open3 (char const *file_name, int flags, int mask);
|
||||||
int _open2 (char const *file_name, int flags);
|
int _open2 (char const *file_name, int flags);
|
||||||
|
int oputc (int c);
|
||||||
int oputs (char const* s);
|
int oputs (char const* s);
|
||||||
ssize_t write (int filedes, void const *buffer, size_t size);
|
ssize_t write (int filedes, void const *buffer, size_t size);
|
||||||
char *search_path (char const *file_name);
|
char *search_path (char const *file_name);
|
||||||
|
|
|
@ -29,19 +29,12 @@
|
||||||
|
|
||||||
#else // ! WITH_GLIBC
|
#else // ! WITH_GLIBC
|
||||||
|
|
||||||
#define CHAR_BIT 8
|
#include <stdint.h>
|
||||||
#define UCHAR_MAX 255
|
|
||||||
#define CHAR_MAX 255
|
|
||||||
#define UINT_MAX 4294967295U
|
|
||||||
#define ULONG_MAX 4294967295U
|
|
||||||
#define INT_MIN -2147483648
|
|
||||||
#define INT_MAX 2147483647
|
|
||||||
#define MB_CUR_MAX 1
|
#define MB_CUR_MAX 1
|
||||||
#define LONG_MIN -2147483648
|
|
||||||
#define LONG_MAX 2147483647
|
|
||||||
#define _POSIX_OPEN_MAX 16
|
|
||||||
#define PATH_MAX 512
|
|
||||||
#define NAME_MAX 255
|
#define NAME_MAX 255
|
||||||
|
#define PATH_MAX 512
|
||||||
|
#define _POSIX_OPEN_MAX 16
|
||||||
|
|
||||||
#endif // ! WITH_GLIBC
|
#endif // ! WITH_GLIBC
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
/* -*-comment-start: "//";comment-end:""-*-
|
/* -*-comment-start: "//";comment-end:""-*-
|
||||||
* GNU Mes --- Maxwell Equations of Software
|
* GNU Mes --- Maxwell Equations of Software
|
||||||
* Copyright © 2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
* Copyright © 2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||||
|
* Copyright © 2018 Peter De Wachter <pdewacht@gmail.com>
|
||||||
*
|
*
|
||||||
* This file is part of GNU Mes.
|
* This file is part of GNU Mes.
|
||||||
*
|
*
|
||||||
|
@ -80,6 +81,40 @@ typedef unsigned* uintptr_t;
|
||||||
typedef long ptrdiff_t;
|
typedef long ptrdiff_t;
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
#define CHAR_BIT 8
|
||||||
|
#define CHAR_MAX 255
|
||||||
|
#define UCHAR_MAX 255
|
||||||
|
|
||||||
|
#define INT8_MAX 127
|
||||||
|
#define INT8_MIN (-INT8_MAX-1)
|
||||||
|
#define UINT8_MAX 255
|
||||||
|
|
||||||
|
#define INT16_MAX 32767
|
||||||
|
#define INT16_MIN (-INT16_MAX-1)
|
||||||
|
#define UINT16_MAX 65535
|
||||||
|
|
||||||
|
#define INT32_MAX 2147483647
|
||||||
|
#define INT32_MIN (-INT32_MAX-1)
|
||||||
|
#define UINT32_MAX 4294967295U
|
||||||
|
|
||||||
|
#define INT64_MAX 9223372036854775807LL
|
||||||
|
#define INT64_MIN (-INT64_MAX-1)
|
||||||
|
#define UINT64_MAX 18446744073709551615ULL
|
||||||
|
|
||||||
|
#define INT_MIN -2147483648
|
||||||
|
#define INT_MAX 2147483647
|
||||||
|
#if __i386__
|
||||||
|
#define LONG_MIN INT_MIN
|
||||||
|
#define LONG_MAX INT_MAX
|
||||||
|
#define UINT_MAX UINT32_MAX
|
||||||
|
#define ULONG_MAX UINT32_MAX
|
||||||
|
#elif __x86_64__
|
||||||
|
#define LONG_MIN INT64_MIN
|
||||||
|
#define LONG_MAX INT64_MAX
|
||||||
|
#define UINT_MAX UINT32_MAX
|
||||||
|
#define ULONG_MAX UINT64_MAX
|
||||||
|
#endif
|
||||||
|
|
||||||
#endif // ! WITH_GLIBC
|
#endif // ! WITH_GLIBC
|
||||||
|
|
||||||
#endif // __MES_STDINT_H
|
#endif // __MES_STDINT_H
|
||||||
|
|
|
@ -54,6 +54,7 @@ struct timespec
|
||||||
|
|
||||||
#endif // __MES_STRUCT_TIMESPEC
|
#endif // __MES_STRUCT_TIMESPEC
|
||||||
|
|
||||||
|
#define CLOCK_PROCESS_CPUTIME_ID 2
|
||||||
int clock_gettime (clockid_t clk_id, struct timespec *tp);
|
int clock_gettime (clockid_t clk_id, struct timespec *tp);
|
||||||
struct tm *localtime (time_t const *timep);
|
struct tm *localtime (time_t const *timep);
|
||||||
struct tm *gmtime (time_t const *time);
|
struct tm *gmtime (time_t const *time);
|
||||||
|
|
|
@ -47,3 +47,4 @@
|
||||||
#endif // POSIX
|
#endif // POSIX
|
||||||
|
|
||||||
#include <mes/eputc.c>
|
#include <mes/eputc.c>
|
||||||
|
#include <mes/oputc.c>
|
||||||
|
|
|
@ -0,0 +1,27 @@
|
||||||
|
/* -*-comment-start: "//";comment-end:""-*-
|
||||||
|
* 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/>.
|
||||||
|
*/
|
||||||
|
|
||||||
|
#include <time.h>
|
||||||
|
|
||||||
|
int
|
||||||
|
clock_gettime (clockid_t clk_id, struct timespec *tp)
|
||||||
|
{
|
||||||
|
return _sys_call2 (SYS_clock_gettime, (long)clk_id, (long)tp);
|
||||||
|
}
|
|
@ -0,0 +1,27 @@
|
||||||
|
/* -*-comment-start: "//";comment-end:""-*-
|
||||||
|
* 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/>.
|
||||||
|
*/
|
||||||
|
|
||||||
|
#include <time.h>
|
||||||
|
|
||||||
|
int
|
||||||
|
gettimeofday (struct timeval *tv, struct timezone *tz)
|
||||||
|
{
|
||||||
|
return _sys_call2 (SYS_gettimeofday, (long)tv, (long)tz);
|
||||||
|
}
|
|
@ -173,9 +173,3 @@ chdir (char const *file_name)
|
||||||
{
|
{
|
||||||
return _sys_call1 (SYS_chdir, (long)file_name);
|
return _sys_call1 (SYS_chdir, (long)file_name);
|
||||||
}
|
}
|
||||||
|
|
||||||
int
|
|
||||||
clock_gettime (clockid_t clk_id, struct timespec *tp)
|
|
||||||
{
|
|
||||||
return _sys_call2 (SYS_clock_gettime, (long)clk_id, (long)tp);
|
|
||||||
}
|
|
||||||
|
|
|
@ -149,3 +149,7 @@ fsync (int filedes)
|
||||||
{
|
{
|
||||||
return _sys_call1 (SYS_fsync, (int)filedes);
|
return _sys_call1 (SYS_fsync, (int)filedes);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
#include "linux/clock_gettime.c"
|
||||||
|
#include "linux/gettimeofday.c"
|
||||||
|
#include "linux/time.c"
|
||||||
|
|
|
@ -60,15 +60,3 @@ getcwd (char *buffer, size_t size)
|
||||||
{
|
{
|
||||||
return _sys_call2 (SYS_getcwd, (long)buffer, (long)size);
|
return _sys_call2 (SYS_getcwd, (long)buffer, (long)size);
|
||||||
}
|
}
|
||||||
|
|
||||||
time_t
|
|
||||||
time (time_t *result)
|
|
||||||
{
|
|
||||||
return _sys_call1 (SYS_time, (long)result);
|
|
||||||
}
|
|
||||||
|
|
||||||
int
|
|
||||||
gettimeofday (struct timeval *tv, struct timezone *tz)
|
|
||||||
{
|
|
||||||
return _sys_call2 (SYS_gettimeofday, (long)tv, (long)tz);
|
|
||||||
}
|
|
||||||
|
|
|
@ -0,0 +1,27 @@
|
||||||
|
/* -*-comment-start: "//";comment-end:""-*-
|
||||||
|
* 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/>.
|
||||||
|
*/
|
||||||
|
|
||||||
|
#include <time.h>
|
||||||
|
|
||||||
|
time_t
|
||||||
|
time (time_t *result)
|
||||||
|
{
|
||||||
|
return _sys_call1 (SYS_time, (long)result);
|
||||||
|
}
|
|
@ -0,0 +1,27 @@
|
||||||
|
/* -*-comment-start: "//";comment-end:""-*-
|
||||||
|
* 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/>.
|
||||||
|
*/
|
||||||
|
|
||||||
|
#include <libmes.h>
|
||||||
|
|
||||||
|
int
|
||||||
|
oputc (int c)
|
||||||
|
{
|
||||||
|
return fdputc (c, STDOUT);
|
||||||
|
}
|
|
@ -25,8 +25,14 @@ int
|
||||||
snprintf (char *str, size_t size, char const *format, ...)
|
snprintf (char *str, size_t size, char const *format, ...)
|
||||||
{
|
{
|
||||||
va_list ap;
|
va_list ap;
|
||||||
|
int r;
|
||||||
|
#if __GNUC__ && __x86_64__
|
||||||
|
#define __FUNCTION_ARGS 3
|
||||||
|
ap += (__FOO_VARARGS + (__FUNCTION_ARGS << 1)) << 3;
|
||||||
|
#undef __FUNCTION_ARGS
|
||||||
|
#endif
|
||||||
va_start (ap, format);
|
va_start (ap, format);
|
||||||
int r = vsprintf (str, format, ap);
|
r = vsnprintf (str, size, format, ap);
|
||||||
va_end (ap);
|
va_end (ap);
|
||||||
return r;
|
return r;
|
||||||
}
|
}
|
||||||
|
|
|
@ -22,7 +22,200 @@
|
||||||
#include <stdlib.h>
|
#include <stdlib.h>
|
||||||
|
|
||||||
int
|
int
|
||||||
vsnprintf (char *str, size_t size, char const *format, va_list ap)
|
vsnprintf (char *str, size_t size, char const* format, va_list ap)
|
||||||
{
|
{
|
||||||
return vsprintf (str, format, ap);
|
char const *p = format;
|
||||||
|
int count = 0;
|
||||||
|
char c;
|
||||||
|
while (*p)
|
||||||
|
if (*p != '%')
|
||||||
|
{
|
||||||
|
c = *p++;
|
||||||
|
if (count < size)
|
||||||
|
*str++ = c;
|
||||||
|
count++;
|
||||||
|
}
|
||||||
|
else
|
||||||
|
{
|
||||||
|
p++;
|
||||||
|
c = *p;
|
||||||
|
int left_p = 0;
|
||||||
|
int precision = -1;
|
||||||
|
int width = -1;
|
||||||
|
if (c == '-')
|
||||||
|
{
|
||||||
|
left_p = 1;
|
||||||
|
c = *++p;
|
||||||
|
}
|
||||||
|
char pad = ' ';
|
||||||
|
if (c == '0')
|
||||||
|
{
|
||||||
|
pad = c;
|
||||||
|
c = *p++;
|
||||||
|
}
|
||||||
|
if (c >= '0' && c <= '9')
|
||||||
|
{
|
||||||
|
width = abtol (&p, 10);
|
||||||
|
c = *p;
|
||||||
|
}
|
||||||
|
else if (c == '*')
|
||||||
|
{
|
||||||
|
width = va_arg (ap, long);
|
||||||
|
c = *++p;
|
||||||
|
}
|
||||||
|
if (c == '.')
|
||||||
|
{
|
||||||
|
c = *++p;
|
||||||
|
if (c >= '0' && c <= '9')
|
||||||
|
{
|
||||||
|
precision = abtol (&p, 10);
|
||||||
|
c = *p;
|
||||||
|
}
|
||||||
|
else if (c == '*')
|
||||||
|
{
|
||||||
|
precision = va_arg (ap, long);
|
||||||
|
c = *++p;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
if (c == 'l')
|
||||||
|
c = *++p;
|
||||||
|
if (c == 'l')
|
||||||
|
c = *++p;
|
||||||
|
if (c == 'l')
|
||||||
|
{
|
||||||
|
eputs ("vsnprintf: skipping second: l\n");
|
||||||
|
c = *++p;
|
||||||
|
}
|
||||||
|
switch (c)
|
||||||
|
{
|
||||||
|
case '%':
|
||||||
|
{
|
||||||
|
if (count < size)
|
||||||
|
*str++ = *p;
|
||||||
|
count++;
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
case 'c':
|
||||||
|
{
|
||||||
|
c = va_arg (ap, long);
|
||||||
|
if (count < size)
|
||||||
|
*str++ = c;
|
||||||
|
count++;
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
case 'd':
|
||||||
|
case 'i':
|
||||||
|
case 'o':
|
||||||
|
case 'u':
|
||||||
|
case 'x':
|
||||||
|
case 'X':
|
||||||
|
{
|
||||||
|
long d = va_arg (ap, long);
|
||||||
|
int base = c == 'o' ? 8
|
||||||
|
: c == 'x' || c == 'X' ? 16
|
||||||
|
: 10;
|
||||||
|
char const *s = ntoab (d, base, c != 'u' && c != 'x' && c != 'X');
|
||||||
|
if (c == 'X')
|
||||||
|
strupr (s);
|
||||||
|
int length = strlen (s);
|
||||||
|
if (precision == -1)
|
||||||
|
precision = length;
|
||||||
|
if (!left_p)
|
||||||
|
{
|
||||||
|
while (width-- > precision)
|
||||||
|
{
|
||||||
|
if (count < size)
|
||||||
|
*str++ = pad;
|
||||||
|
count++;
|
||||||
|
}
|
||||||
|
while (precision > length)
|
||||||
|
{
|
||||||
|
if (count < size)
|
||||||
|
*str++ = '0';
|
||||||
|
precision--;
|
||||||
|
width--;
|
||||||
|
count++;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
while (*s)
|
||||||
|
{
|
||||||
|
if (precision-- <= 0)
|
||||||
|
break;
|
||||||
|
width--;
|
||||||
|
c = *s++;
|
||||||
|
if (count < size)
|
||||||
|
*str++ = c;
|
||||||
|
count++;
|
||||||
|
}
|
||||||
|
while (width > 0)
|
||||||
|
{
|
||||||
|
width--;
|
||||||
|
if (count < size)
|
||||||
|
*str++ = pad;
|
||||||
|
count++;
|
||||||
|
}
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
case 's':
|
||||||
|
{
|
||||||
|
char *s = va_arg (ap, char *);
|
||||||
|
int length = s ? strlen (s) : 0;
|
||||||
|
if (precision == -1)
|
||||||
|
precision = length;
|
||||||
|
if (!left_p)
|
||||||
|
{
|
||||||
|
while (width-- > precision)
|
||||||
|
{
|
||||||
|
if (count < size)
|
||||||
|
*str++ = pad;
|
||||||
|
count++;
|
||||||
|
}
|
||||||
|
while (width > length)
|
||||||
|
{
|
||||||
|
if (count < size)
|
||||||
|
*str++ = ' ';
|
||||||
|
precision--;
|
||||||
|
width--;
|
||||||
|
count++;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
while (s && *s)
|
||||||
|
{
|
||||||
|
if (precision-- <= 0)
|
||||||
|
break;
|
||||||
|
width--;
|
||||||
|
c = *s++;
|
||||||
|
if (count < size)
|
||||||
|
*str++ = c;
|
||||||
|
count++;
|
||||||
|
}
|
||||||
|
while (width > 0)
|
||||||
|
{
|
||||||
|
width--;
|
||||||
|
if (count < size)
|
||||||
|
*str++ = pad;
|
||||||
|
count++;
|
||||||
|
}
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
case 'n':
|
||||||
|
{
|
||||||
|
int *n = va_arg (ap, int *);
|
||||||
|
*n = count;
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
default:
|
||||||
|
{
|
||||||
|
eputs ("vsnprintf: not supported: %:");
|
||||||
|
eputc (c);
|
||||||
|
eputs ("\n");
|
||||||
|
p++;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
p++;
|
||||||
|
}
|
||||||
|
va_end (ap);
|
||||||
|
if (count < size)
|
||||||
|
*str = 0;
|
||||||
|
return count;
|
||||||
}
|
}
|
||||||
|
|
|
@ -24,182 +24,5 @@
|
||||||
int
|
int
|
||||||
vsprintf (char *str, char const* format, va_list ap)
|
vsprintf (char *str, char const* format, va_list ap)
|
||||||
{
|
{
|
||||||
char const *p = format;
|
return vsnprintf (str, LONG_MAX, format, ap);
|
||||||
int count = 0;
|
|
||||||
while (*p)
|
|
||||||
if (*p != '%')
|
|
||||||
{
|
|
||||||
*str++ = *p++;
|
|
||||||
count++;
|
|
||||||
}
|
|
||||||
else
|
|
||||||
{
|
|
||||||
p++;
|
|
||||||
char c = *p;
|
|
||||||
int left_p = 0;
|
|
||||||
int precision = -1;
|
|
||||||
int width = -1;
|
|
||||||
if (c == '-')
|
|
||||||
{
|
|
||||||
left_p = 1;
|
|
||||||
c = *++p;
|
|
||||||
}
|
|
||||||
char pad = ' ';
|
|
||||||
if (c == '0')
|
|
||||||
{
|
|
||||||
pad = c;
|
|
||||||
c = *p++;
|
|
||||||
}
|
|
||||||
if (c >= '0' && c <= '9')
|
|
||||||
{
|
|
||||||
width = abtol (&p, 10);
|
|
||||||
c = *p;
|
|
||||||
}
|
|
||||||
else if (c == '*')
|
|
||||||
{
|
|
||||||
width = va_arg (ap, long);
|
|
||||||
c = *++p;
|
|
||||||
}
|
|
||||||
if (c == '.')
|
|
||||||
{
|
|
||||||
c = *++p;
|
|
||||||
if (c >= '0' && c <= '9')
|
|
||||||
{
|
|
||||||
precision = abtol (&p, 10);
|
|
||||||
c = *p;
|
|
||||||
}
|
|
||||||
else if (c == '*')
|
|
||||||
{
|
|
||||||
precision = va_arg (ap, long);
|
|
||||||
c = *++p;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
if (c == 'l')
|
|
||||||
c = *++p;
|
|
||||||
if (c == 'l')
|
|
||||||
c = *++p;
|
|
||||||
if (c == 'l')
|
|
||||||
{
|
|
||||||
eputs ("vfprintf: skipping second: l\n");
|
|
||||||
c = *++p;
|
|
||||||
}
|
|
||||||
switch (c)
|
|
||||||
{
|
|
||||||
case '%':
|
|
||||||
{
|
|
||||||
*str++ = *p;
|
|
||||||
count++;
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
case 'c':
|
|
||||||
{
|
|
||||||
c = va_arg (ap, long);
|
|
||||||
*str++ = c;
|
|
||||||
count++;
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
case 'd':
|
|
||||||
case 'i':
|
|
||||||
case 'o':
|
|
||||||
case 'u':
|
|
||||||
case 'x':
|
|
||||||
case 'X':
|
|
||||||
{
|
|
||||||
long d = va_arg (ap, long);
|
|
||||||
int base = c == 'o' ? 8
|
|
||||||
: c == 'x' || c == 'X' ? 16
|
|
||||||
: 10;
|
|
||||||
char const *s = ntoab (d, base, c != 'u' && c != 'x' && c != 'X');
|
|
||||||
if (c == 'X')
|
|
||||||
strupr (s);
|
|
||||||
int length = strlen (s);
|
|
||||||
if (precision == -1)
|
|
||||||
precision = length;
|
|
||||||
if (!left_p)
|
|
||||||
{
|
|
||||||
while (width-- > precision)
|
|
||||||
{
|
|
||||||
*str++ = pad;
|
|
||||||
count++;
|
|
||||||
}
|
|
||||||
while (precision > length)
|
|
||||||
{
|
|
||||||
*str++ = '0';
|
|
||||||
precision--;
|
|
||||||
width--;
|
|
||||||
count++;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
while (*s)
|
|
||||||
{
|
|
||||||
if (precision-- <= 0)
|
|
||||||
break;
|
|
||||||
width--;
|
|
||||||
*str++ = *s++;
|
|
||||||
count++;
|
|
||||||
}
|
|
||||||
while (width > 0)
|
|
||||||
{
|
|
||||||
width--;
|
|
||||||
*str++ = pad;
|
|
||||||
count++;
|
|
||||||
}
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
case 's':
|
|
||||||
{
|
|
||||||
char *s = va_arg (ap, char *);
|
|
||||||
int length = strlen (s);
|
|
||||||
if (precision == -1)
|
|
||||||
precision = length;
|
|
||||||
if (!left_p)
|
|
||||||
{
|
|
||||||
while (width-- > precision)
|
|
||||||
{
|
|
||||||
*str++ = pad;
|
|
||||||
count++;
|
|
||||||
}
|
|
||||||
while (width > length)
|
|
||||||
{
|
|
||||||
*str++ = ' ';
|
|
||||||
precision--;
|
|
||||||
width--;
|
|
||||||
count++;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
while (*s)
|
|
||||||
{
|
|
||||||
if (precision-- <= 0)
|
|
||||||
break;
|
|
||||||
width--;
|
|
||||||
*str++ = *s++;
|
|
||||||
count++;
|
|
||||||
}
|
|
||||||
while (width > 0)
|
|
||||||
{
|
|
||||||
width--;
|
|
||||||
*str++ = pad;
|
|
||||||
count++;
|
|
||||||
}
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
case 'n':
|
|
||||||
{
|
|
||||||
int *n = va_arg (ap, int *);
|
|
||||||
*n = count;
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
default:
|
|
||||||
{
|
|
||||||
eputs ("vsprintf: not supported: %:");
|
|
||||||
eputc (c);
|
|
||||||
eputs ("\n");
|
|
||||||
p++;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
p++;
|
|
||||||
}
|
|
||||||
va_end (ap);
|
|
||||||
*str = 0;
|
|
||||||
return strlen (str);
|
|
||||||
}
|
}
|
||||||
|
|
|
@ -129,14 +129,15 @@ DEFINE mov____0x8(%ebp),%edx 8b55
|
||||||
DEFINE mov____0x8(%ebp),%esi 8b75
|
DEFINE mov____0x8(%ebp),%esi 8b75
|
||||||
DEFINE mov____0x8(%ebp),%esp 8b65
|
DEFINE mov____0x8(%ebp),%esp 8b65
|
||||||
DEFINE movb___%al,0x32 a2
|
DEFINE movb___%al,0x32 a2
|
||||||
|
DEFINE movb___%bl,0x32 881d
|
||||||
DEFINE movsbl_%al,%eax 0fbec0
|
DEFINE movsbl_%al,%eax 0fbec0
|
||||||
DEFINE movsbl_%bl,%ebx 0fbedb
|
DEFINE movsbl_%bl,%ebx 0fbedb
|
||||||
DEFINE movswl_%ax,%eax 0fbfc0
|
DEFINE movswl_%ax,%eax 0fbfc0
|
||||||
DEFINE movswl_%bx,%ebx 0fbfdb
|
DEFINE movswl_%bx,%ebx 0fbfdb
|
||||||
DEFINE movw___%ax,0x32 66a3
|
DEFINE movw___%ax,0x32 66a3
|
||||||
|
DEFINE movw___%bx,0x32 66891d
|
||||||
DEFINE movzbl_%al,%eax 0fb6c0
|
DEFINE movzbl_%al,%eax 0fb6c0
|
||||||
DEFINE movzbl_%bl,%ebx 0fb6db
|
DEFINE movzbl_%bl,%ebx 0fb6db
|
||||||
DEFINE movzbl_%bl,%ebx 0fb6db
|
|
||||||
DEFINE movzbl_(%eax),%eax 0fb600
|
DEFINE movzbl_(%eax),%eax 0fb600
|
||||||
DEFINE movzbl_(%ebx),%ebx 0fb61b
|
DEFINE movzbl_(%ebx),%ebx 0fb61b
|
||||||
DEFINE movzbl_0x32(%eax),%eax 0fb680
|
DEFINE movzbl_0x32(%eax),%eax 0fb680
|
||||||
|
@ -203,7 +204,6 @@ DEFINE test___%eax,%eax 85c0
|
||||||
DEFINE test___%ebx,%ebx 85db
|
DEFINE test___%ebx,%ebx 85db
|
||||||
DEFINE xchg___%eax,%ebx 93
|
DEFINE xchg___%eax,%ebx 93
|
||||||
DEFINE xchg___%eax,(%esp) 870424
|
DEFINE xchg___%eax,(%esp) 870424
|
||||||
DEFINE xchg___%eax,(%esp) 870424
|
|
||||||
DEFINE xchg___%ebx,(%esp) 871c24
|
DEFINE xchg___%ebx,(%esp) 871c24
|
||||||
DEFINE xor____$i32,%eax 35
|
DEFINE xor____$i32,%eax 35
|
||||||
DEFINE xor____$i8,%ah 80f4
|
DEFINE xor____$i8,%ah 80f4
|
||||||
|
|
|
@ -1,5 +1,6 @@
|
||||||
### GNU Mes --- Maxwell Equations of Software
|
### GNU Mes --- Maxwell Equations of Software
|
||||||
### Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
### Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||||
|
### Copyright © 2018 Peter De Wachter <pdewacht@gmail.com>
|
||||||
###
|
###
|
||||||
### This file is part of GNU Mes.
|
### This file is part of GNU Mes.
|
||||||
###
|
###
|
||||||
|
@ -54,6 +55,7 @@ DEFINE call___*%rax ffd0
|
||||||
DEFINE call___*%rdi ffd7
|
DEFINE call___*%rdi ffd7
|
||||||
DEFINE cmp____$i32,%rax 483d
|
DEFINE cmp____$i32,%rax 483d
|
||||||
DEFINE cmp____$i8,%rax 4883f8
|
DEFINE cmp____$i8,%rax 4883f8
|
||||||
|
DEFINE cmp____$i8,%rdi 4883ff
|
||||||
DEFINE cmp____%r15,%rax 4c39f8
|
DEFINE cmp____%r15,%rax 4c39f8
|
||||||
DEFINE cmp____%r15,%rdi 4c39ff
|
DEFINE cmp____%r15,%rdi 4c39ff
|
||||||
DEFINE cqto 4899
|
DEFINE cqto 4899
|
||||||
|
@ -78,8 +80,6 @@ DEFINE mov____$i32,%rax 48c7c0
|
||||||
DEFINE mov____$i32,%rdi 48c7c7
|
DEFINE mov____$i32,%rdi 48c7c7
|
||||||
DEFINE mov____$i32,0x8(%rbp) c745
|
DEFINE mov____$i32,0x8(%rbp) c745
|
||||||
DEFINE mov____$i64,%r15 49bf
|
DEFINE mov____$i64,%r15 49bf
|
||||||
DEFINE mov____$i64,%rax 48a1
|
|
||||||
DEFINE mov____$i64,%rax 48b8
|
|
||||||
DEFINE mov____$i64,%rax 48b8
|
DEFINE mov____$i64,%rax 48b8
|
||||||
DEFINE mov____$i64,%rdi 48bf
|
DEFINE mov____$i64,%rdi 48bf
|
||||||
DEFINE mov____%al,(%rdi) 8807
|
DEFINE mov____%al,(%rdi) 8807
|
||||||
|
@ -92,7 +92,6 @@ DEFINE mov____%eax,%rax 89c0
|
||||||
DEFINE mov____%eax,(%rdi) 8907
|
DEFINE mov____%eax,(%rdi) 8907
|
||||||
DEFINE mov____%eax,0x32(%rbp) 8985
|
DEFINE mov____%eax,0x32(%rbp) 8985
|
||||||
DEFINE mov____%eax,0x8(%rbp) 8945
|
DEFINE mov____%eax,0x8(%rbp) 8945
|
||||||
DEFINE mov____%eax,0x8(%rbp) 8945
|
|
||||||
DEFINE mov____%edi,%edi 89ff
|
DEFINE mov____%edi,%edi 89ff
|
||||||
DEFINE mov____%edi,%rdi 89ff
|
DEFINE mov____%edi,%rdi 89ff
|
||||||
DEFINE mov____%edi,0x32(%rbp) 89bd
|
DEFINE mov____%edi,0x32(%rbp) 89bd
|
||||||
|
|
|
@ -30,7 +30,7 @@
|
||||||
(define mes %version)
|
(define mes %version)
|
||||||
|
|
||||||
(define (defined? x)
|
(define (defined? x)
|
||||||
(assq x (current-module)))
|
(module-variable (current-module) x))
|
||||||
|
|
||||||
(define (cond-expand-expander clauses)
|
(define (cond-expand-expander clauses)
|
||||||
(if (defined? (car (car clauses)))
|
(if (defined? (car (car clauses)))
|
||||||
|
@ -42,7 +42,6 @@
|
||||||
;; end boot-00.scm
|
;; end boot-00.scm
|
||||||
|
|
||||||
;; boot-01.scm
|
;; boot-01.scm
|
||||||
(define (pair? x) (eq? (core:type x) <cell:pair>))
|
|
||||||
(define (not x) (if x #f #t))
|
(define (not x) (if x #f #t))
|
||||||
|
|
||||||
(define (display x . rest)
|
(define (display x . rest)
|
||||||
|
@ -104,10 +103,6 @@
|
||||||
(cons (quote or) (cdr x))))
|
(cons (quote or) (cdr x))))
|
||||||
(car x)))))
|
(car x)))))
|
||||||
|
|
||||||
(define-macro (module-define! module name value)
|
|
||||||
;;(list 'define name value)
|
|
||||||
#t)
|
|
||||||
|
|
||||||
(define-macro (mes-use-module module)
|
(define-macro (mes-use-module module)
|
||||||
#t)
|
#t)
|
||||||
;; end boot-02.scm
|
;; end boot-02.scm
|
||||||
|
|
|
@ -20,7 +20,7 @@
|
||||||
(define mes %version)
|
(define mes %version)
|
||||||
|
|
||||||
(define (defined? x)
|
(define (defined? x)
|
||||||
(assq x (current-module)))
|
(module-variable (current-module) x))
|
||||||
|
|
||||||
(define (cond-expand-expander clauses)
|
(define (cond-expand-expander clauses)
|
||||||
(if (defined? (car (car clauses)))
|
(if (defined? (car (car clauses)))
|
||||||
|
|
|
@ -20,7 +20,7 @@
|
||||||
(define mes %version)
|
(define mes %version)
|
||||||
|
|
||||||
(define (defined? x)
|
(define (defined? x)
|
||||||
(assq x (current-module)))
|
(module-variable (current-module) x))
|
||||||
|
|
||||||
(define (cond-expand-expander clauses)
|
(define (cond-expand-expander clauses)
|
||||||
(if (defined? (car (car clauses)))
|
(if (defined? (car (car clauses)))
|
||||||
|
@ -32,7 +32,6 @@
|
||||||
;; end boot-00.scm
|
;; end boot-00.scm
|
||||||
|
|
||||||
;; boot-01.scm
|
;; boot-01.scm
|
||||||
(define (pair? x) (eq? (core:type x) <cell:pair>))
|
|
||||||
(define (not x) (if x #f #t))
|
(define (not x) (if x #f #t))
|
||||||
|
|
||||||
(define (display x . rest)
|
(define (display x . rest)
|
||||||
|
|
|
@ -30,7 +30,7 @@
|
||||||
(define mes %version)
|
(define mes %version)
|
||||||
|
|
||||||
(define (defined? x)
|
(define (defined? x)
|
||||||
(assq x (current-module)))
|
(module-variable (current-module) x))
|
||||||
|
|
||||||
(define (cond-expand-expander clauses)
|
(define (cond-expand-expander clauses)
|
||||||
(if (defined? (car (car clauses)))
|
(if (defined? (car (car clauses)))
|
||||||
|
@ -42,7 +42,6 @@
|
||||||
;; end boot-00.scm
|
;; end boot-00.scm
|
||||||
|
|
||||||
;; boot-01.scm
|
;; boot-01.scm
|
||||||
(define (pair? x) (eq? (core:type x) <cell:pair>))
|
|
||||||
(define (not x) (if x #f #t))
|
(define (not x) (if x #f #t))
|
||||||
|
|
||||||
(define (display x . rest)
|
(define (display x . rest)
|
||||||
|
@ -104,10 +103,6 @@
|
||||||
(cons (quote or) (cdr x))))
|
(cons (quote or) (cdr x))))
|
||||||
(car x)))))
|
(car x)))))
|
||||||
|
|
||||||
(define-macro (module-define! module name value)
|
|
||||||
;;(list 'define name value)
|
|
||||||
#t)
|
|
||||||
|
|
||||||
(define-macro (mes-use-module module)
|
(define-macro (mes-use-module module)
|
||||||
#t)
|
#t)
|
||||||
|
|
||||||
|
|
|
@ -31,6 +31,8 @@
|
||||||
(core:display-error ":")
|
(core:display-error ":")
|
||||||
(core:write-error args)
|
(core:write-error args)
|
||||||
(core:display-error "\n")))
|
(core:display-error "\n")))
|
||||||
|
(core:display-error "Backtrace:\n")
|
||||||
|
(display-backtrace (make-stack) (current-error-port))
|
||||||
(exit 1))))
|
(exit 1))))
|
||||||
|
|
||||||
(define (catch key thunk handler)
|
(define (catch key thunk handler)
|
||||||
|
@ -54,3 +56,16 @@
|
||||||
(apply handler (cons key args))))
|
(apply handler (cons key args))))
|
||||||
|
|
||||||
(define with-throw-handler catch) ; FIXME: hack for Nyacc 0.75
|
(define with-throw-handler catch) ; FIXME: hack for Nyacc 0.75
|
||||||
|
|
||||||
|
(define (frame-procedure frame)
|
||||||
|
(struct-ref frame 3))
|
||||||
|
|
||||||
|
(define (display-backtrace stack port . rest)
|
||||||
|
(let* ((frames (map (lambda (i) (stack-ref stack i)) (iota (stack-length stack))))
|
||||||
|
(call-frames (filter frame-procedure frames))
|
||||||
|
(display-frames (drop-right call-frames 2)))
|
||||||
|
(for-each (lambda (f)
|
||||||
|
(core:display-error " ")
|
||||||
|
(core:display-error f)
|
||||||
|
(core:display-error "\n"))
|
||||||
|
display-frames)))
|
||||||
|
|
|
@ -115,6 +115,7 @@
|
||||||
((port? x)
|
((port? x)
|
||||||
(display "#<port " port)
|
(display "#<port " port)
|
||||||
(display (core:cdr x) port)
|
(display (core:cdr x) port)
|
||||||
|
(display " ")
|
||||||
(display (core:car x) port)
|
(display (core:car x) port)
|
||||||
(display ">" port))
|
(display ">" port))
|
||||||
((variable? x)
|
((variable? x)
|
||||||
|
@ -142,6 +143,13 @@
|
||||||
(if (keyword? x) (display "#:" port))
|
(if (keyword? x) (display "#:" port))
|
||||||
(for-each (display-cut2 display-char <> port write?) (string->list x))
|
(for-each (display-cut2 display-char <> port write?) (string->list x))
|
||||||
(if (and (string? x) write?) (write-char #\" port)))
|
(if (and (string? x) write?) (write-char #\" port)))
|
||||||
|
((struct? x)
|
||||||
|
(display "#<" port)
|
||||||
|
(for-each (lambda (i)
|
||||||
|
(let ((x (strut-ref x i)))
|
||||||
|
(d x #f (if (= i 0) "" " "))))
|
||||||
|
(iota (struct-length x)))
|
||||||
|
(display ")" port))
|
||||||
((vector? x)
|
((vector? x)
|
||||||
(display "#(" port)
|
(display "#(" port)
|
||||||
(for-each (lambda (i)
|
(for-each (lambda (i)
|
||||||
|
@ -214,7 +222,7 @@
|
||||||
((#\s) (write (car args) port))
|
((#\s) (write (car args) port))
|
||||||
(else (display (car args) port)))
|
(else (display (car args) port)))
|
||||||
(simple-format (cddr lst) (cdr args)))))))
|
(simple-format (cddr lst) (cdr args)))))))
|
||||||
|
|
||||||
(if destination (simple-format lst rest)
|
(if destination (simple-format lst rest)
|
||||||
(with-output-to-string
|
(with-output-to-string
|
||||||
(lambda () (simple-format lst rest))))))
|
(lambda () (simple-format lst rest))))))
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
;;; -*-scheme-*-
|
;;; -*-scheme-*-
|
||||||
|
|
||||||
;;; GNU Mes --- Maxwell Equations of Software
|
;;; GNU Mes --- Maxwell Equations of Software
|
||||||
;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Mes.
|
;;; This file is part of GNU Mes.
|
||||||
;;;
|
;;;
|
||||||
|
@ -24,39 +24,19 @@
|
||||||
|
|
||||||
(mes-use-module (mes scm))
|
(mes-use-module (mes scm))
|
||||||
|
|
||||||
|
|
||||||
(define (sexp:define e a)
|
|
||||||
(if (atom? (car (cdr e))) (cons (car (cdr e))
|
|
||||||
(core:eval (car (cdr (cdr e))) a))
|
|
||||||
(cons (car (car (cdr e)))
|
|
||||||
(core:eval (cons (quote lambda)
|
|
||||||
(cons (cdr (car (cdr e))) (cdr (cdr e)))) a))))
|
|
||||||
|
|
||||||
(define (f:env:define a+ a)
|
|
||||||
(set-cdr! a+ (cdr a))
|
|
||||||
(set-cdr! a a+)
|
|
||||||
;;(set-cdr! (assq '*closure* a) a+)
|
|
||||||
)
|
|
||||||
|
|
||||||
(define (env:escape-closure a n)
|
|
||||||
(if (eq? (caar a) '*closure*) (if (= 0 n) a
|
|
||||||
(env:escape-closure (cdr a) (- n 1)))
|
|
||||||
(env:escape-closure (cdr a) n)))
|
|
||||||
|
|
||||||
(define-macro (module-define! name value a)
|
|
||||||
`(f:env:define (cons (sexp:define (cons 'define (cons ',name (cons ,value '()))) ,a) '()) (env:escape-closure ,a 1)))
|
|
||||||
|
|
||||||
(define-macro (make-fluid . default)
|
(define-macro (make-fluid . default)
|
||||||
`(begin
|
((lambda (fluid)
|
||||||
,(let ((fluid (symbol-append 'fluid: (gensym)))
|
`(begin
|
||||||
(module (current-module)))
|
(module-define!
|
||||||
`(begin
|
(boot-module)
|
||||||
(module-define! ,fluid
|
',fluid
|
||||||
(let ((v ,(and (pair? default) (car default))))
|
((lambda (v)
|
||||||
(lambda ( . rest)
|
(lambda ( . rest)
|
||||||
(if (null? rest) v
|
(if (null? rest) v
|
||||||
(set! v (car rest))))) ',module)
|
(set! v (car rest)))))
|
||||||
',fluid))))
|
,(and (pair? default) (car default))))
|
||||||
|
',fluid))
|
||||||
|
(symbol-append 'fluid: (gensym))))
|
||||||
|
|
||||||
(define (fluid-ref fluid)
|
(define (fluid-ref fluid)
|
||||||
(fluid))
|
(fluid))
|
||||||
|
@ -92,7 +72,7 @@
|
||||||
`(let ,(map (lambda (b s) `(,s (,b))) (map car bindings) syms)
|
`(let ,(map (lambda (b s) `(,s (,b))) (map car bindings) syms)
|
||||||
,@(map (lambda (o) `(fluid-set! ,(car o) ,(cadr o))) bindings)
|
,@(map (lambda (o) `(fluid-set! ,(car o) ,(cadr o))) bindings)
|
||||||
(let ((r (begin ,@bodies)))
|
(let ((r (begin ,@bodies)))
|
||||||
`,@(map (lambda (b s) `(fluid-set! ,b ,s)) (map car bindings) syms)
|
,@(map (lambda (b s) `(fluid-set! ,b ,s)) (map car bindings) syms)
|
||||||
r))))
|
r))))
|
||||||
|
|
||||||
(define (dynamic-wind in-guard thunk out-guard)
|
(define (dynamic-wind in-guard thunk out-guard)
|
||||||
|
|
|
@ -31,16 +31,6 @@
|
||||||
(mes-use-module (srfi srfi-16))
|
(mes-use-module (srfi srfi-16))
|
||||||
(mes-use-module (mes display))
|
(mes-use-module (mes display))
|
||||||
|
|
||||||
(if #t ;;(not (defined? 'read-string))
|
|
||||||
(define (read-string)
|
|
||||||
(define (read-string c)
|
|
||||||
(if (eq? c #\*eof*) '()
|
|
||||||
(cons c (read-string (read-char)))))
|
|
||||||
(let ((string (list->string (read-string (read-char)))))
|
|
||||||
(if (and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 3)) string->number))
|
|
||||||
(core:display-error (string-append "drained: `" string "'\n")))
|
|
||||||
string)))
|
|
||||||
|
|
||||||
(define (drain-input port) (read-string))
|
(define (drain-input port) (read-string))
|
||||||
|
|
||||||
(define (make-string n . fill)
|
(define (make-string n . fill)
|
||||||
|
|
|
@ -57,3 +57,6 @@
|
||||||
(define (waitpid pid . options)
|
(define (waitpid pid . options)
|
||||||
(let ((options (if (null? options) 0 (car options))))
|
(let ((options (if (null? options) 0 (car options))))
|
||||||
(core:waitpid pid options)))
|
(core:waitpid pid options)))
|
||||||
|
|
||||||
|
(define (status:exit-val status)
|
||||||
|
(ash status -8))
|
||||||
|
|
|
@ -108,11 +108,6 @@
|
||||||
(define assv assq)
|
(define assv assq)
|
||||||
(define assv-ref assq-ref)
|
(define assv-ref assq-ref)
|
||||||
|
|
||||||
(define (assoc key alist)
|
|
||||||
(if (not (pair? alist)) #f
|
|
||||||
(if (equal? key (caar alist)) (car alist)
|
|
||||||
(assoc key (cdr alist)))))
|
|
||||||
|
|
||||||
(define (assoc-ref alist key)
|
(define (assoc-ref alist key)
|
||||||
(let ((entry (assoc key alist)))
|
(let ((entry (assoc key alist)))
|
||||||
(if entry (cdr entry)
|
(if entry (cdr entry)
|
||||||
|
@ -373,6 +368,12 @@
|
||||||
(lambda args
|
(lambda args
|
||||||
(not (apply proc args))))
|
(not (apply proc args))))
|
||||||
|
|
||||||
|
(define ceil identity)
|
||||||
|
(define floor identity)
|
||||||
|
(define round identity)
|
||||||
|
(define inexact->exact identity)
|
||||||
|
(define exact->inexact identity)
|
||||||
|
|
||||||
(define (const . rest)
|
(define (const . rest)
|
||||||
(lambda (. _)
|
(lambda (. _)
|
||||||
(car rest)))
|
(car rest)))
|
||||||
|
|
|
@ -37,6 +37,7 @@
|
||||||
(cons <cell:ref> (quote <cell:ref>))
|
(cons <cell:ref> (quote <cell:ref>))
|
||||||
(cons <cell:special> (quote <cell:special>))
|
(cons <cell:special> (quote <cell:special>))
|
||||||
(cons <cell:string> (quote <cell:string>))
|
(cons <cell:string> (quote <cell:string>))
|
||||||
|
(cons <cell:struct> (quote <cell:struct>))
|
||||||
(cons <cell:symbol> (quote <cell:symbol>))
|
(cons <cell:symbol> (quote <cell:symbol>))
|
||||||
(cons <cell:values> (quote <cell:values>))
|
(cons <cell:values> (quote <cell:values>))
|
||||||
(cons <cell:variable> (quote <cell:variable>))
|
(cons <cell:variable> (quote <cell:variable>))
|
||||||
|
@ -74,9 +75,6 @@
|
||||||
(define (number? x)
|
(define (number? x)
|
||||||
(eq? (core:type x) <cell:number>))
|
(eq? (core:type x) <cell:number>))
|
||||||
|
|
||||||
(define (pair? x)
|
|
||||||
(eq? (core:type x) <cell:pair>))
|
|
||||||
|
|
||||||
(define (port? x)
|
(define (port? x)
|
||||||
(eq? (core:type x) <cell:port>))
|
(eq? (core:type x) <cell:port>))
|
||||||
|
|
||||||
|
@ -86,6 +84,9 @@
|
||||||
(define (string? x)
|
(define (string? x)
|
||||||
(eq? (core:type x) <cell:string>))
|
(eq? (core:type x) <cell:string>))
|
||||||
|
|
||||||
|
(define (struct? x)
|
||||||
|
(eq? (core:type x) <cell:struct>))
|
||||||
|
|
||||||
(define (symbol? x)
|
(define (symbol? x)
|
||||||
(eq? (core:type x) <cell:symbol>))
|
(eq? (core:type x) <cell:symbol>))
|
||||||
|
|
||||||
|
@ -119,14 +120,11 @@
|
||||||
|
|
||||||
(define (string->symbol s)
|
(define (string->symbol s)
|
||||||
(if (not (pair? (core:car s))) '()
|
(if (not (pair? (core:car s))) '()
|
||||||
(core:lookup-symbol (core:car s))))
|
(list->symbol (core:car s))))
|
||||||
|
|
||||||
(define (symbol->keyword s)
|
(define (symbol->keyword s)
|
||||||
(core:make-cell <cell:keyword> (symbol->list s) 0))
|
(core:make-cell <cell:keyword> (symbol->list s) 0))
|
||||||
|
|
||||||
(define (list->symbol lst)
|
|
||||||
(core:lookup-symbol lst))
|
|
||||||
|
|
||||||
(define (symbol->list s)
|
(define (symbol->list s)
|
||||||
(core:car s))
|
(core:car s))
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,145 @@
|
||||||
|
;;; -*-scheme-*-
|
||||||
|
|
||||||
|
;;; GNU Mes --- Maxwell Equations of Software
|
||||||
|
;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||||
|
;;;
|
||||||
|
;;; This file is part of GNU Mes.
|
||||||
|
;;;
|
||||||
|
;;; GNU Mes is free software; you can redistribute it and/or modify it
|
||||||
|
;;; under the terms of the GNU General Public License as published by
|
||||||
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||||
|
;;; your option) any later version.
|
||||||
|
;;;
|
||||||
|
;;; GNU Mes is distributed in the hope that it will be useful, but
|
||||||
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
;;; GNU General Public License for more details.
|
||||||
|
;;;
|
||||||
|
;;; You should have received a copy of the GNU General Public License
|
||||||
|
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;;; srfi-9.mes - records, based on struct.
|
||||||
|
|
||||||
|
(define-macro (define-record-type name constructor+params predicate . fields)
|
||||||
|
(let ((type (make-record-type name (map car fields))))
|
||||||
|
`(begin
|
||||||
|
(define ,name ,type)
|
||||||
|
(define ,(car constructor+params) ,(record-constructor type name (cdr constructor+params)))
|
||||||
|
(define ,predicate ,(record-predicate type))
|
||||||
|
(define-record-accessors ,type ,@fields))))
|
||||||
|
|
||||||
|
(define (make-record-type type fields . printer)
|
||||||
|
(let ((printer (if (pair? printer) (car printer))))
|
||||||
|
(make-struct '<record-type> (cons type (list fields)) printer)))
|
||||||
|
|
||||||
|
(define (record-type? o)
|
||||||
|
(eq? (struct-vtable o) '<record-type>))
|
||||||
|
|
||||||
|
(define (struct-vtable o)
|
||||||
|
(struct-ref o 0))
|
||||||
|
|
||||||
|
(define (record-type o)
|
||||||
|
(struct-ref o 2))
|
||||||
|
|
||||||
|
(define (record-predicate type)
|
||||||
|
(lambda (o)
|
||||||
|
(and (record? o)
|
||||||
|
(eq? (record-type o) (record-type type)))))
|
||||||
|
|
||||||
|
(define (record? o)
|
||||||
|
(and (struct? o)
|
||||||
|
(record-type? (struct-vtable o))))
|
||||||
|
|
||||||
|
(define (record-constructor type name params)
|
||||||
|
(let ((fields (record-fields type))
|
||||||
|
(record-type (record-type type)))
|
||||||
|
(lambda (. o)
|
||||||
|
(if (not (= (length o) (length params))) (error "wrong number of arguments for record-constructor")
|
||||||
|
(let ((rest (make-list (- (length fields) (length params)))))
|
||||||
|
(make-struct type (cons name (append o rest)) record-printer))))))
|
||||||
|
|
||||||
|
(define record-printer *unspecified*) ; TODO
|
||||||
|
(define (record-printer o)
|
||||||
|
(display "#<")
|
||||||
|
(display (record-type o))
|
||||||
|
(let* ((vtable (struct-vtable o))
|
||||||
|
(fields (record-fields vtable)))
|
||||||
|
(for-each (lambda (field)
|
||||||
|
(display " ")
|
||||||
|
(display field)
|
||||||
|
(display ": ")
|
||||||
|
(display ((record-getter vtable field) o)))
|
||||||
|
fields))
|
||||||
|
(display ">"))
|
||||||
|
|
||||||
|
(define (record-fields o)
|
||||||
|
(struct-ref o 3))
|
||||||
|
|
||||||
|
(define-macro (define-record-accessors type . fields)
|
||||||
|
`(begin
|
||||||
|
,@(map (lambda (field)
|
||||||
|
`(define-record-accessor ,type ,field))
|
||||||
|
fields)))
|
||||||
|
|
||||||
|
(define-macro (define-record-accessor type field)
|
||||||
|
`(begin
|
||||||
|
(define ,(cadr field) ,(record-getter type (car field)))
|
||||||
|
(if ,(pair? (cddr field))
|
||||||
|
(define ,(if (pair? (cddr field)) (caddr field)) ,(record-setter type (car field))))))
|
||||||
|
|
||||||
|
(define (record-getter type field)
|
||||||
|
(let ((i (record-field-index type field)))
|
||||||
|
(lambda (o . field?)
|
||||||
|
(if (not (eq? (record-type o) (record-type type))) (error "record getter: record expected" type o)
|
||||||
|
(if (pair? field?) field
|
||||||
|
(struct-ref o i))))))
|
||||||
|
|
||||||
|
(define (record-setter type field)
|
||||||
|
(let ((i (record-field-index type field)))
|
||||||
|
(lambda (o v)
|
||||||
|
(if (not (eq? (record-type o) (record-type type))) (error "record setter: record expected" type o)
|
||||||
|
(struct-set! o i v)))))
|
||||||
|
|
||||||
|
(define (record-field-index type field)
|
||||||
|
(+ 3 (or (lst-index (record-fields type) field)
|
||||||
|
(error "no such field" type field))))
|
||||||
|
|
||||||
|
(define (lst-index lst o)
|
||||||
|
(let loop ((lst lst) (i 0))
|
||||||
|
(and (pair? lst)
|
||||||
|
(if (eq? o (car lst)) i
|
||||||
|
(loop (cdr lst) (1+ i))))))
|
||||||
|
|
||||||
|
;; (define-record-type <employee>
|
||||||
|
;; (make-employee name age salary)
|
||||||
|
;; employee?
|
||||||
|
;; (name employe-name)
|
||||||
|
;; (age employee-age set-employee-age!)
|
||||||
|
;; (salary employee-salary))
|
||||||
|
|
||||||
|
;; (display <employee>)
|
||||||
|
;; (newline)
|
||||||
|
|
||||||
|
;; (display make-employee)
|
||||||
|
;; (newline)
|
||||||
|
;; (display "employee-age ")
|
||||||
|
;; (display employee-age)
|
||||||
|
;; (newline)
|
||||||
|
|
||||||
|
;; (display "set-employee-age! ")
|
||||||
|
;; (display set-employee-age!)
|
||||||
|
;; (newline)
|
||||||
|
|
||||||
|
;; (define janneke (make-employee "janneke" 49 42))
|
||||||
|
;; (display janneke)
|
||||||
|
;; (newline)
|
||||||
|
|
||||||
|
;; (display (employee-age janneke))
|
||||||
|
;; (newline)
|
||||||
|
|
||||||
|
;; (display (set-employee-age! janneke 33))
|
||||||
|
;; (newline)
|
||||||
|
;; (display (employee-age janneke))
|
||||||
|
;; (newline)
|
|
@ -0,0 +1,116 @@
|
||||||
|
;;; -*-scheme-*-
|
||||||
|
|
||||||
|
;;; GNU Mes --- Maxwell Equations of Software
|
||||||
|
;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||||
|
;;;
|
||||||
|
;;; This file is part of GNU Mes.
|
||||||
|
;;;
|
||||||
|
;;; GNU Mes is free software; you can redistribute it and/or modify it
|
||||||
|
;;; under the terms of the GNU General Public License as published by
|
||||||
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||||
|
;;; your option) any later version.
|
||||||
|
;;;
|
||||||
|
;;; GNU Mes is distributed in the hope that it will be useful, but
|
||||||
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
;;; GNU General Public License for more details.
|
||||||
|
;;;
|
||||||
|
;;; You should have received a copy of the GNU General Public License
|
||||||
|
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;;; srfi-9-vector.mes - records, based on vector
|
||||||
|
|
||||||
|
(define-macro (define-record-type type constructor+params predicate . fields)
|
||||||
|
(let ((record (make-record-type type (map car fields))))
|
||||||
|
`(begin
|
||||||
|
(define ,type ,record)
|
||||||
|
(define ,(car constructor+params) ,(record-constructor record (cdr constructor+params)))
|
||||||
|
(define ,predicate ,(record-predicate record))
|
||||||
|
(define-record-accessors ,record ,@fields))))
|
||||||
|
|
||||||
|
(define (make-record-type type fields)
|
||||||
|
(list->vector (list '*record-type* type fields (length fields))))
|
||||||
|
|
||||||
|
(define (record-type? o)
|
||||||
|
(eq? (record-type o) '*record-type*))
|
||||||
|
|
||||||
|
(define (record-type o)
|
||||||
|
(vector-ref o 0))
|
||||||
|
|
||||||
|
(define (record-predicate type)
|
||||||
|
(lambda (o)
|
||||||
|
(and (vector? o)
|
||||||
|
(eq? (record-type o) type))))
|
||||||
|
|
||||||
|
(define (record-constructor type params)
|
||||||
|
(let ((fields (record-fields type)))
|
||||||
|
(lambda (. o)
|
||||||
|
(if (not (= (length o) (length params))) (error "wrong number of arguments for record-constructor")
|
||||||
|
(let ((rest (make-list (- (length fields) (length params)))))
|
||||||
|
(list->vector (cons type (append o rest))))))))
|
||||||
|
|
||||||
|
(define (record-fields o)
|
||||||
|
(vector-ref o 2))
|
||||||
|
|
||||||
|
(define-macro (define-record-accessors type . fields)
|
||||||
|
`(begin
|
||||||
|
,@(map (lambda (field)
|
||||||
|
`(define-record-accessor ,type ,field))
|
||||||
|
fields)))
|
||||||
|
|
||||||
|
(define-macro (define-record-accessor type field)
|
||||||
|
`(begin
|
||||||
|
(define ,(cadr field) ,(record-getter type (car field)))
|
||||||
|
(if ,(pair? (cddr field))
|
||||||
|
(define ,(if (pair? (cddr field)) (caddr field)) ,(record-setter type (car field))))))
|
||||||
|
|
||||||
|
(define (record-getter type field)
|
||||||
|
(let ((i (record-field-index type field)))
|
||||||
|
(lambda (o . field?)
|
||||||
|
(if (not (eq? (record-type o) type)) (error "record getter: record expected" type o)
|
||||||
|
(if (pair? field?) field
|
||||||
|
(vector-ref o i))))))
|
||||||
|
|
||||||
|
(define (record-setter type field)
|
||||||
|
(let ((i (record-field-index type field)))
|
||||||
|
(lambda (o v)
|
||||||
|
(if (not (eq? (record-type o) type)) (error "record setter: record expected" type o)
|
||||||
|
(vector-set! o i v)))))
|
||||||
|
|
||||||
|
(define (record-field-index type field)
|
||||||
|
(1+ (or (lst-index (record-fields type) field)
|
||||||
|
(error "no such field" type field))))
|
||||||
|
|
||||||
|
(define (lst-index lst o)
|
||||||
|
(let loop ((lst lst) (i 0))
|
||||||
|
(and (pair? lst)
|
||||||
|
(if (eq? o (car lst)) i
|
||||||
|
(loop (cdr lst) (1+ i))))))
|
||||||
|
|
||||||
|
;; (define-record-type <employee> (make-employee name age salary) employee? (name employe-name) (age employee-age set-employee-age!) (salary employee-salary))
|
||||||
|
|
||||||
|
;; (display <employee>)
|
||||||
|
;; (newline)
|
||||||
|
;; (display make-employee)
|
||||||
|
;; (newline)
|
||||||
|
;; (display "employee-age ")
|
||||||
|
;; (display employee-age)
|
||||||
|
;; (newline)
|
||||||
|
|
||||||
|
;; (display "set-employee-age! ")
|
||||||
|
;; (display set-employee-age!)
|
||||||
|
;; (newline)
|
||||||
|
|
||||||
|
;; (define janneke (make-employee "janneke" 49 42))
|
||||||
|
;; (display janneke)
|
||||||
|
;; (newline)
|
||||||
|
|
||||||
|
;; (display (employee-age janneke))
|
||||||
|
;; (newline)
|
||||||
|
|
||||||
|
;; (display (set-employee-age! janneke 33))
|
||||||
|
;; (newline)
|
||||||
|
;; (display (employee-age janneke))
|
||||||
|
;; (newline)
|
|
@ -1,138 +0,0 @@
|
||||||
;;; -*-scheme-*-
|
|
||||||
|
|
||||||
;;; GNU Mes --- Maxwell Equations of Software
|
|
||||||
;;; Copyright © 2017 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:
|
|
||||||
|
|
||||||
;;; srfi-9.mes - records.
|
|
||||||
|
|
||||||
(define (lst-index lst o)
|
|
||||||
(let loop ((lst lst) (i 0))
|
|
||||||
(and (pair? lst)
|
|
||||||
(if (equal? o (car lst)) i
|
|
||||||
(loop (cdr lst) (1+ i))))))
|
|
||||||
|
|
||||||
(define (make-record-type type fields)
|
|
||||||
(list->vector (list '*record-type* type fields (length fields))))
|
|
||||||
|
|
||||||
(define (record-type o)
|
|
||||||
(vector-ref o 0))
|
|
||||||
|
|
||||||
(define (record-type? o)
|
|
||||||
(eq? (record-type o) '*record-type*))
|
|
||||||
|
|
||||||
(define (record-constructor type params)
|
|
||||||
(let ((fields (record-fields type)))
|
|
||||||
(lambda (. o)
|
|
||||||
(if (not (= (length o) (length params))) (error "wrong number of arguments for record-constructor")
|
|
||||||
(let ((rest (make-list (- (length fields) (length params)))))
|
|
||||||
(list->vector (cons type (append o rest))))))))
|
|
||||||
|
|
||||||
(define (record-fields o)
|
|
||||||
(vector-ref o 2))
|
|
||||||
|
|
||||||
(define (record-field-index type field)
|
|
||||||
(1+ (or (lst-index (record-fields type) field)
|
|
||||||
(error "no such field" type field))))
|
|
||||||
|
|
||||||
(define (record-getter type field)
|
|
||||||
(let ((i (record-field-index type field)))
|
|
||||||
(lambda (o . field?)
|
|
||||||
(if (not (eq? (record-type o) type)) (error "record getter: record expected" type o)
|
|
||||||
(if (pair? field?) field
|
|
||||||
(vector-ref o i))))))
|
|
||||||
|
|
||||||
(define (record-setter type field)
|
|
||||||
(let ((i (record-field-index type field)))
|
|
||||||
(lambda (o v)
|
|
||||||
(if (not (eq? (record-type o) type)) (error "record setter: record expected" type o)
|
|
||||||
(vector-set! o i v)))))
|
|
||||||
|
|
||||||
(define (record-predicate type)
|
|
||||||
(lambda (o)
|
|
||||||
(and (vector? o)
|
|
||||||
(eq? (record-type o) type))))
|
|
||||||
|
|
||||||
(define-macro (define-record-accessors type . fields)
|
|
||||||
`(begin
|
|
||||||
,@(map (lambda (field)
|
|
||||||
`(define-record-accessor ,type ,field))
|
|
||||||
fields)))
|
|
||||||
|
|
||||||
(define-macro (define-record-accessor type field)
|
|
||||||
`(begin
|
|
||||||
(define ,(cadr field) ,(record-getter type (car field)))
|
|
||||||
(if ,(pair? (cddr field))
|
|
||||||
(define ,(if (pair? (cddr field)) (caddr field)) ,(record-setter type (car field))))))
|
|
||||||
|
|
||||||
(define-macro (define-record-type type constructor+params predicate . fields)
|
|
||||||
(let ((record (make-record-type type (map car fields))))
|
|
||||||
`(begin
|
|
||||||
(define ,type ,record)
|
|
||||||
(define ,(car constructor+params) ,(record-constructor record (cdr constructor+params)))
|
|
||||||
(define ,predicate ,(record-predicate record))
|
|
||||||
(define-record-accessors ,record ,@fields))))
|
|
||||||
|
|
||||||
;; (define-record-type cpi
|
|
||||||
;; (make-cpi-1)
|
|
||||||
;; cpi?
|
|
||||||
;; (debug cpi-debug set-cpi-debug!) ; debug #t #f
|
|
||||||
;; (defines cpi-defs set-cpi-defs!) ; #defines
|
|
||||||
;; (incdirs cpi-incs set-cpi-incs!) ; #includes
|
|
||||||
;; (inc-tynd cpi-itynd set-cpi-itynd!) ; a-l of incfile => typenames
|
|
||||||
;; (inc-defd cpi-idefd set-cpi-idefd!) ; a-l of incfile => defines
|
|
||||||
;; (ptl cpi-ptl set-cpi-ptl!) ; parent typename list
|
|
||||||
;; (ctl cpi-ctl set-cpi-ctl!) ; current typename list
|
|
||||||
;; (blev cpi-blev set-cpi-blev!) ; curr brace/block level
|
|
||||||
;; )
|
|
||||||
|
|
||||||
;; (display cpi)
|
|
||||||
;; (newline)
|
|
||||||
;; (display make-cpi-1)
|
|
||||||
;; (newline)
|
|
||||||
;; (define cpi (make-cpi-1))
|
|
||||||
;; (set-cpi-debug! cpi #t)
|
|
||||||
;; (set-cpi-blev! cpi #t)
|
|
||||||
|
|
||||||
|
|
||||||
;; (define-record-type <employee> (make-employee name age salary) employee? (name employe-name) (age employee-age set-employee-age!) (salary employee-salary))
|
|
||||||
|
|
||||||
;; (display <employee>)
|
|
||||||
;; (newline)
|
|
||||||
;; (display make-employee)
|
|
||||||
;; (newline)
|
|
||||||
;; (display "employee-age ")
|
|
||||||
;; (display employee-age)
|
|
||||||
;; (newline)
|
|
||||||
|
|
||||||
;; (display "set-employee-age! ")
|
|
||||||
;; (display set-employee-age!)
|
|
||||||
;; (newline)
|
|
||||||
|
|
||||||
;; (define janneke (make-employee "janneke" 49 42))
|
|
||||||
;; (display janneke)
|
|
||||||
;; (newline)
|
|
||||||
|
|
||||||
;; (display (employee-age janneke))
|
|
||||||
;; (newline)
|
|
||||||
|
|
||||||
;; (display (set-employee-age! janneke 33))
|
|
||||||
;; (newline)
|
|
||||||
;; (display (employee-age janneke))
|
|
||||||
;; (newline)
|
|
|
@ -0,0 +1 @@
|
||||||
|
srfi-9-struct.mes
|
|
@ -0,0 +1,38 @@
|
||||||
|
;;; -*-scheme-*-
|
||||||
|
|
||||||
|
;;; GNU Mes --- Maxwell Equations of Software
|
||||||
|
;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||||
|
;;;
|
||||||
|
;;; This file is part of GNU Mes.
|
||||||
|
;;;
|
||||||
|
;;; GNU Mes is free software; you can redistribute it and/or modify it
|
||||||
|
;;; under the terms of the GNU General Public License as published by
|
||||||
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||||
|
;;; your option) any later version.
|
||||||
|
;;;
|
||||||
|
;;; GNU Mes is distributed in the hope that it will be useful, but
|
||||||
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
;;; GNU General Public License for more details.
|
||||||
|
;;;
|
||||||
|
;;; You should have received a copy of the GNU General Public License
|
||||||
|
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;;; srfi-9.mes - GNU immutable records.
|
||||||
|
|
||||||
|
(define-macro (define-immutable-record-type type constructor+params predicate . fields)
|
||||||
|
`(define-record-type ,type ,constructor+params ,predicate ,@(map (lambda (f) (list-head f 2)) fields)))
|
||||||
|
|
||||||
|
(define-macro (set-field o getters value)
|
||||||
|
`(let ((getter ,(car getters)))
|
||||||
|
(let* ((type (struct-vtable ,o))
|
||||||
|
(name (record-type ,o))
|
||||||
|
(set (getter ,o #t)))
|
||||||
|
(define (field->value field)
|
||||||
|
(if (eq? set field) ,value
|
||||||
|
((record-getter type field) ,o)))
|
||||||
|
(let* ((fields (record-fields type))
|
||||||
|
(values (map field->value fields)))
|
||||||
|
(apply (record-constructor type name fields) values)))))
|
|
@ -0,0 +1,37 @@
|
||||||
|
;;; -*-scheme-*-
|
||||||
|
|
||||||
|
;;; GNU Mes --- Maxwell Equations of Software
|
||||||
|
;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||||
|
;;;
|
||||||
|
;;; This file is part of GNU Mes.
|
||||||
|
;;;
|
||||||
|
;;; GNU Mes is free software; you can redistribute it and/or modify it
|
||||||
|
;;; under the terms of the GNU General Public License as published by
|
||||||
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||||
|
;;; your option) any later version.
|
||||||
|
;;;
|
||||||
|
;;; GNU Mes is distributed in the hope that it will be useful, but
|
||||||
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
;;; GNU General Public License for more details.
|
||||||
|
;;;
|
||||||
|
;;; You should have received a copy of the GNU General Public License
|
||||||
|
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;;; srfi-9.mes - GNU immutable records.
|
||||||
|
|
||||||
|
(define-macro (define-immutable-record-type type constructor+params predicate . fields)
|
||||||
|
`(define-record-type ,type ,constructor+params ,predicate ,@(map (lambda (f) (list-head f 2)) fields)))
|
||||||
|
|
||||||
|
(define-macro (set-field o getters value)
|
||||||
|
`(let ((getter ,(car getters)))
|
||||||
|
(let ((type (record-type ,o))
|
||||||
|
(set (getter ,o #t)))
|
||||||
|
(define (field->value field)
|
||||||
|
(if (eq? set field) ,value
|
||||||
|
((record-getter type field) ,o)))
|
||||||
|
(let* ((fields (record-fields type))
|
||||||
|
(values (map field->value fields)))
|
||||||
|
(apply (record-constructor type fields) values)))))
|
|
@ -1,37 +0,0 @@
|
||||||
;;; -*-scheme-*-
|
|
||||||
|
|
||||||
;;; GNU Mes --- Maxwell Equations of Software
|
|
||||||
;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
||||||
;;;
|
|
||||||
;;; This file is part of GNU Mes.
|
|
||||||
;;;
|
|
||||||
;;; GNU Mes is free software; you can redistribute it and/or modify it
|
|
||||||
;;; under the terms of the GNU General Public License as published by
|
|
||||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
||||||
;;; your option) any later version.
|
|
||||||
;;;
|
|
||||||
;;; GNU Mes is distributed in the hope that it will be useful, but
|
|
||||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;;; GNU General Public License for more details.
|
|
||||||
;;;
|
|
||||||
;;; You should have received a copy of the GNU General Public License
|
|
||||||
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;; srfi-9.mes - GNU immutable records.
|
|
||||||
|
|
||||||
(define-macro (define-immutable-record-type type constructor+params predicate . fields)
|
|
||||||
`(define-record-type ,type ,constructor+params ,predicate ,@(map (lambda (f) (list-head f 2)) fields)))
|
|
||||||
|
|
||||||
(define-macro (set-field o getters value)
|
|
||||||
`(let ((getter ,(car getters)))
|
|
||||||
(let ((type (record-type ,o))
|
|
||||||
(set (getter ,o #t)))
|
|
||||||
(define (field->value field)
|
|
||||||
(if (eq? set field) ,value
|
|
||||||
((record-getter type field) ,o)))
|
|
||||||
(let* ((fields (record-fields type))
|
|
||||||
(values (map field->value fields)))
|
|
||||||
(apply (record-constructor type fields) values)))))
|
|
|
@ -0,0 +1 @@
|
||||||
|
gnu-struct.mes
|
|
@ -38,6 +38,11 @@
|
||||||
%arch
|
%arch
|
||||||
%compiler
|
%compiler
|
||||||
))
|
))
|
||||||
|
(cond-expand
|
||||||
|
(guile-2)
|
||||||
|
(guile
|
||||||
|
(define %host-type (string-append (utsname:machine (uname)) "linux-gnu")))
|
||||||
|
(else))
|
||||||
|
|
||||||
(define-macro (mes-use-module . rest) #t)
|
(define-macro (mes-use-module . rest) #t)
|
||||||
(define builtin? procedure?) ; not strictly true, but ok for tests/*.test
|
(define builtin? procedure?) ; not strictly true, but ok for tests/*.test
|
||||||
|
|
|
@ -22,7 +22,9 @@
|
||||||
disjoin
|
disjoin
|
||||||
guile?
|
guile?
|
||||||
mes?
|
mes?
|
||||||
|
pk
|
||||||
pke
|
pke
|
||||||
|
warn
|
||||||
stderr
|
stderr
|
||||||
string-substitute))
|
string-substitute))
|
||||||
|
|
||||||
|
@ -43,6 +45,13 @@
|
||||||
(define (stderr string . rest)
|
(define (stderr string . rest)
|
||||||
(apply logf (cons* (current-error-port) string rest)))
|
(apply logf (cons* (current-error-port) string rest)))
|
||||||
|
|
||||||
|
(define (pk . stuff)
|
||||||
|
(newline)
|
||||||
|
(display ";;; ")
|
||||||
|
(write stuff)
|
||||||
|
(newline)
|
||||||
|
(car (last-pair stuff)))
|
||||||
|
|
||||||
(define (pke . stuff)
|
(define (pke . stuff)
|
||||||
(newline (current-error-port))
|
(newline (current-error-port))
|
||||||
(display ";;; " (current-error-port))
|
(display ";;; " (current-error-port))
|
||||||
|
@ -50,6 +59,8 @@
|
||||||
(newline (current-error-port))
|
(newline (current-error-port))
|
||||||
(car (last-pair stuff)))
|
(car (last-pair stuff)))
|
||||||
|
|
||||||
|
(define warn pke)
|
||||||
|
|
||||||
(define (disjoin . predicates)
|
(define (disjoin . predicates)
|
||||||
(lambda (. arguments)
|
(lambda (. arguments)
|
||||||
(any (lambda (o) (apply o arguments)) predicates)))
|
(any (lambda (o) (apply o arguments)) predicates)))
|
||||||
|
|
|
@ -26,11 +26,13 @@
|
||||||
;;; Code:
|
;;; Code:
|
||||||
|
|
||||||
(define-module (mes test)
|
(define-module (mes test)
|
||||||
|
#:use-module (ice-9 rdelim)
|
||||||
#:export (
|
#:export (
|
||||||
pass-if
|
pass-if
|
||||||
pass-if-equal
|
pass-if-equal
|
||||||
pass-if-not
|
pass-if-not
|
||||||
pass-if-eq
|
pass-if-eq
|
||||||
|
pass-if-timeout
|
||||||
result
|
result
|
||||||
seq? ; deprecated
|
seq? ; deprecated
|
||||||
sequal? ; deprecated
|
sequal? ; deprecated
|
||||||
|
@ -38,6 +40,7 @@
|
||||||
|
|
||||||
(cond-expand
|
(cond-expand
|
||||||
(mes
|
(mes
|
||||||
|
(define (inexact->exact x) x)
|
||||||
(define mes? #t)
|
(define mes? #t)
|
||||||
(define guile? #f)
|
(define guile? #f)
|
||||||
(define guile-2? #f)
|
(define guile-2? #f)
|
||||||
|
@ -104,6 +107,14 @@
|
||||||
(display "actual: ") (display a) (newline)
|
(display "actual: ") (display a) (newline)
|
||||||
#f)))
|
#f)))
|
||||||
|
|
||||||
|
(define (sless? a expect)
|
||||||
|
(or (< a expect)
|
||||||
|
(begin
|
||||||
|
(display ": fail") (newline)
|
||||||
|
(display "expected: ") (display expect) (newline)
|
||||||
|
(display "actual: ") (display a) (newline)
|
||||||
|
#f)))
|
||||||
|
|
||||||
(define (sequal2? actual expect)
|
(define (sequal2? actual expect)
|
||||||
(or (equal? actual expect)
|
(or (equal? actual expect)
|
||||||
(begin
|
(begin
|
||||||
|
@ -132,3 +143,16 @@
|
||||||
'begin
|
'begin
|
||||||
(list display "test: ") (list display name)
|
(list display "test: ") (list display name)
|
||||||
(list 'result (list not f)))) ;; FIXME
|
(list 'result (list not f)))) ;; FIXME
|
||||||
|
|
||||||
|
(define internal-time-units-per-milli-second
|
||||||
|
(/ internal-time-units-per-second 1000))
|
||||||
|
(define (test-time thunk)
|
||||||
|
((lambda (start)
|
||||||
|
(begin
|
||||||
|
(thunk)
|
||||||
|
(inexact->exact (/ (- (get-internal-run-time) start)
|
||||||
|
internal-time-units-per-milli-second))))
|
||||||
|
(get-internal-run-time)))
|
||||||
|
|
||||||
|
(define-macro (pass-if-timeout name limit . body)
|
||||||
|
(list 'pass-if name (list sless? (list test-time (cons* 'lambda '_ body)) limit)))
|
||||||
|
|
|
@ -87,7 +87,7 @@
|
||||||
(dec->hex (quotient o #x100000000))))
|
(dec->hex (quotient o #x100000000))))
|
||||||
(string-append "%" (number->string (dec->hex (modulo o #x100000000)))
|
(string-append "%" (number->string (dec->hex (modulo o #x100000000)))
|
||||||
" %" (if (< o 0) "-1"
|
" %" (if (< o 0) "-1"
|
||||||
(number->string (dec->hex (quoteint o #x100000000)))))))
|
(number->string (dec->hex (quotient o #x100000000)))))))
|
||||||
|
|
||||||
(define* (display-join o #:optional (sep ""))
|
(define* (display-join o #:optional (sep ""))
|
||||||
(let loop ((o o))
|
(let loop ((o o))
|
||||||
|
|
|
@ -209,6 +209,7 @@
|
||||||
((mod ,a ,b) (ast->type a info))
|
((mod ,a ,b) (ast->type a info))
|
||||||
((mul ,a ,b) (ast->type a info))
|
((mul ,a ,b) (ast->type a info))
|
||||||
((not ,a) (ast->type a info))
|
((not ,a) (ast->type a info))
|
||||||
|
((pos ,a) (ast->type a info))
|
||||||
((neg ,a) (ast->type a info))
|
((neg ,a) (ast->type a info))
|
||||||
((eq ,a ,b) (ast->type a info))
|
((eq ,a ,b) (ast->type a info))
|
||||||
((ge ,a ,b) (ast->type a info))
|
((ge ,a ,b) (ast->type a info))
|
||||||
|
@ -1218,6 +1219,9 @@
|
||||||
(info (append-text info (wrap-as (as info 'r-negate)))))
|
(info (append-text info (wrap-as (as info 'r-negate)))))
|
||||||
(append-text info (wrap-as (as info 'test-r))))) ;; hmm, use ast->info?
|
(append-text info (wrap-as (as info 'test-r))))) ;; hmm, use ast->info?
|
||||||
|
|
||||||
|
((pos ,expr)
|
||||||
|
(expr->register expr info))
|
||||||
|
|
||||||
((neg ,expr)
|
((neg ,expr)
|
||||||
(let* ((info (expr->register expr info))
|
(let* ((info (expr->register expr info))
|
||||||
(info (allocate-register info))
|
(info (allocate-register info))
|
||||||
|
@ -1542,6 +1546,7 @@
|
||||||
(define (cstring->int o)
|
(define (cstring->int o)
|
||||||
(let ((o (cond ((string-suffix? "ULL" o) (string-drop-right o 3))
|
(let ((o (cond ((string-suffix? "ULL" o) (string-drop-right o 3))
|
||||||
((string-suffix? "UL" o) (string-drop-right o 2))
|
((string-suffix? "UL" o) (string-drop-right o 2))
|
||||||
|
((string-suffix? "U" o) (string-drop-right o 1))
|
||||||
((string-suffix? "LL" o) (string-drop-right o 2))
|
((string-suffix? "LL" o) (string-drop-right o 2))
|
||||||
((string-suffix? "L" o) (string-drop-right o 1))
|
((string-suffix? "L" o) (string-drop-right o 1))
|
||||||
(else o))))
|
(else o))))
|
||||||
|
@ -1559,6 +1564,8 @@
|
||||||
(pmatch o
|
(pmatch o
|
||||||
((fixed ,a) (cstring->int a))
|
((fixed ,a) (cstring->int a))
|
||||||
((p-expr ,expr) (expr->number info expr))
|
((p-expr ,expr) (expr->number info expr))
|
||||||
|
((pos ,a)
|
||||||
|
(expr->number info a))
|
||||||
((neg ,a)
|
((neg ,a)
|
||||||
(- (expr->number info a)))
|
(- (expr->number info a)))
|
||||||
((add ,a ,b)
|
((add ,a ,b)
|
||||||
|
@ -2536,6 +2543,7 @@
|
||||||
(define (fctn-defn:get-name o)
|
(define (fctn-defn:get-name o)
|
||||||
(pmatch o
|
(pmatch o
|
||||||
((_ (ftn-declr (ident ,name) _) _) name)
|
((_ (ftn-declr (ident ,name) _) _) name)
|
||||||
|
((_ (ftn-declr (scope (ident ,name)) _) _) name)
|
||||||
((_ (ptr-declr (pointer . _) (ftn-declr (ident ,name) _)) _) name)
|
((_ (ptr-declr (pointer . _) (ftn-declr (ident ,name) _)) _) name)
|
||||||
(_ (error "fctn-defn:get-name not supported:" o))))
|
(_ (error "fctn-defn:get-name not supported:" o))))
|
||||||
|
|
||||||
|
@ -2609,6 +2617,7 @@
|
||||||
(define (fctn-defn:get-statement o)
|
(define (fctn-defn:get-statement o)
|
||||||
(pmatch o
|
(pmatch o
|
||||||
((_ (ftn-declr (ident _) _) ,statement) statement)
|
((_ (ftn-declr (ident _) _) ,statement) statement)
|
||||||
|
((_ (ftn-declr (scope (ident _)) _) ,statement) statement)
|
||||||
((_ (ptr-declr (pointer . _) (ftn-declr (ident _) . _)) ,statement) statement)
|
((_ (ptr-declr (pointer . _) (ftn-declr (ident _) . _)) ,statement) statement)
|
||||||
(_ (error "fctn-defn:get-statement: not supported: " o))))
|
(_ (error "fctn-defn:get-statement: not supported: " o))))
|
||||||
|
|
||||||
|
|
|
@ -281,7 +281,7 @@
|
||||||
(let ((status (apply system* args)))
|
(let ((status (apply system* args)))
|
||||||
(when (not (zero? status))
|
(when (not (zero? status))
|
||||||
(stderr "mescc: failed: ~a\n" (string-join args))
|
(stderr "mescc: failed: ~a\n" (string-join args))
|
||||||
(exit status))
|
(exit (status:exit-val status)))
|
||||||
status))
|
status))
|
||||||
|
|
||||||
(define (multi-opt option-name) (lambda (o) (and (eq? (car o) option-name) (cdr o))))
|
(define (multi-opt option-name) (lambda (o) (and (eq? (car o) option-name) (cdr o))))
|
||||||
|
|
|
@ -16,9 +16,6 @@
|
||||||
;;; 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/>.
|
||||||
|
|
||||||
(define (pair? x)
|
|
||||||
(eq? (core:type x) <cell:pair>))
|
|
||||||
|
|
||||||
(define (atom? x)
|
(define (atom? x)
|
||||||
(if (pair? x) #f
|
(if (pair? x) #f
|
||||||
(if (null? x) #f
|
(if (null? x) #f
|
||||||
|
|
|
@ -16,8 +16,6 @@
|
||||||
;;; 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/>.
|
||||||
|
|
||||||
(define (pair? x) (eq? (core:type x) <cell:pair>))
|
|
||||||
|
|
||||||
(define (not x) (if x #f #t))
|
(define (not x) (if x #f #t))
|
||||||
|
|
||||||
(define-macro (or . x)
|
(define-macro (or . x)
|
||||||
|
|
|
@ -16,7 +16,6 @@
|
||||||
;;; 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/>.
|
||||||
|
|
||||||
(define (pair? x) (eq? (core:type x) <cell:pair>))
|
|
||||||
(define (vector? x)
|
(define (vector? x)
|
||||||
(eq? (core:type x) <cell:vector>))
|
(eq? (core:type x) <cell:vector>))
|
||||||
|
|
||||||
|
@ -85,7 +84,7 @@
|
||||||
;; ((lambda (a d)
|
;; ((lambda (a d)
|
||||||
;; (core:display " a=") (core:display a) (core:display "\n")
|
;; (core:display " a=") (core:display a) (core:display "\n")
|
||||||
;; (core:display " d=") (core:display d)
|
;; (core:display " d=") (core:display d)
|
||||||
|
|
||||||
;; (if (pair? d)
|
;; (if (pair? d)
|
||||||
;; (if (eq? (car d) 'quote)
|
;; (if (eq? (car d) 'quote)
|
||||||
;; (if (and (pair? a) (eq? (car a) 'quote))
|
;; (if (and (pair? a) (eq? (car a) 'quote))
|
||||||
|
@ -133,7 +132,7 @@
|
||||||
(core:display "\n")
|
(core:display "\n")
|
||||||
(core:display "CDR d=") (core:display d)
|
(core:display "CDR d=") (core:display d)
|
||||||
(core:display "\n")
|
(core:display "\n")
|
||||||
|
|
||||||
(if (pair? d)
|
(if (pair? d)
|
||||||
(if (eq? (car d) 'quote)
|
(if (eq? (car d) 'quote)
|
||||||
(if (and (pair? a) (eq? (car a) 'quote))
|
(if (and (pair? a) (eq? (car a) 'quote))
|
||||||
|
|
|
@ -81,7 +81,7 @@
|
||||||
(list 'load (list string-append %moduledir file)))
|
(list 'load (list string-append %moduledir file)))
|
||||||
|
|
||||||
(define (string->symbol s)
|
(define (string->symbol s)
|
||||||
(core:lookup-symbol (core:car s)))
|
(list->symbol (core:car s)))
|
||||||
|
|
||||||
(define (symbol->list s)
|
(define (symbol->list s)
|
||||||
(core:car s))
|
(core:car s))
|
||||||
|
|
|
@ -69,7 +69,7 @@
|
||||||
;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define (string->symbol s)
|
(define (string->symbol s)
|
||||||
(core:lookup-symbol (core:car s)))
|
(list->symbol (core:car s)))
|
||||||
|
|
||||||
(define-macro (load file)
|
(define-macro (load file)
|
||||||
(list 'primitive-load file))
|
(list 'primitive-load file))
|
||||||
|
|
|
@ -28,7 +28,7 @@
|
||||||
(if (null? lst) (list)
|
(if (null? lst) (list)
|
||||||
(cons (f (car lst)) (map f (cdr lst)))))
|
(cons (f (car lst)) (map f (cdr lst)))))
|
||||||
(define (closure x)
|
(define (closure x)
|
||||||
(map car (cdr (core:cdr (core:car (core:cdr (cdr (assq 'x (current-module)))))))))))
|
(map car (cdr (core:cdr (core:car (core:cdr (cdr (module-variable (current-module) 'x))))))))))
|
||||||
|
|
||||||
(define (x t) #t)
|
(define (x t) #t)
|
||||||
(define (xx x1 x2)
|
(define (xx x1 x2)
|
||||||
|
|
|
@ -20,7 +20,7 @@
|
||||||
(define mes %version)
|
(define mes %version)
|
||||||
|
|
||||||
(define (defined? x)
|
(define (defined? x)
|
||||||
(assq x (current-module)))
|
(module-variable (current-module) x))
|
||||||
|
|
||||||
(define (cond-expand-expander clauses)
|
(define (cond-expand-expander clauses)
|
||||||
(if (defined? (car (car clauses)))
|
(if (defined? (car (car clauses)))
|
||||||
|
@ -36,7 +36,6 @@
|
||||||
(define <cell:pair> 7)
|
(define <cell:pair> 7)
|
||||||
(define <cell:string> 10)
|
(define <cell:string> 10)
|
||||||
|
|
||||||
(define (pair? x) (eq? (core:type x) <cell:pair>))
|
|
||||||
(define (not x) (if x #f #t))
|
(define (not x) (if x #f #t))
|
||||||
|
|
||||||
(define (display x . rest)
|
(define (display x . rest)
|
||||||
|
@ -139,35 +138,21 @@
|
||||||
(if (eq? x (car lst)) lst
|
(if (eq? x (car lst)) lst
|
||||||
(memq x (cdr lst)))))
|
(memq x (cdr lst)))))
|
||||||
|
|
||||||
;; (cond-expand
|
|
||||||
;; (guile
|
|
||||||
;; (define closure identity)
|
|
||||||
;; (define body identity)
|
|
||||||
;; (define append2 append)
|
|
||||||
;; (define (core:apply f a m) (f a))
|
|
||||||
;; )
|
|
||||||
;; (mes
|
|
||||||
(define <cell:symbol> 11)
|
(define <cell:symbol> 11)
|
||||||
(define (symbol? x)
|
(define (symbol? x)
|
||||||
(eq? (core:type x) <cell:symbol>))
|
(eq? (core:type x) <cell:symbol>))
|
||||||
|
|
||||||
(define (string->symbol s)
|
(define (string->symbol s)
|
||||||
(if (not (pair? (core:car s))) '()
|
(if (not (pair? (core:car s))) '()
|
||||||
(core:lookup-symbol (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>))
|
||||||
|
|
||||||
(define <cell:vector> 14)
|
(define <cell:vector> 14)
|
||||||
(define (vector? x)
|
(define (vector? x)
|
||||||
(eq? (core:type x) <cell:vector>))
|
(eq? (core:type x) <cell:vector>))
|
||||||
|
|
||||||
;; (define (body x)
|
|
||||||
;; (core:cdr (core:cdr (core:cdr (cdr (assq 'x (current-module)))))))
|
|
||||||
;; (define (closure x)
|
|
||||||
;; (map car (cdr (core:cdr (core:car (core:cdr (cdr (assq 'x (current-module)))))))))
|
|
||||||
;; ))
|
|
||||||
|
|
||||||
(define (cons* . rest)
|
(define (cons* . rest)
|
||||||
(if (null? (cdr rest)) (car rest)
|
(if (null? (cdr rest)) (car rest)
|
||||||
|
@ -183,9 +168,7 @@
|
||||||
(append2 (car rest) (apply append (cdr rest))))))
|
(append2 (car rest) (apply append (cdr rest))))))
|
||||||
|
|
||||||
(define-macro (quasiquote x)
|
(define-macro (quasiquote x)
|
||||||
;;(core:display-error "quasiquote:") (core:write-error x) (core:display-error "\n")
|
|
||||||
(define (loop x)
|
(define (loop x)
|
||||||
;;(core:display-error "loop:") (core:write-error x) (core:display-error "\n")
|
|
||||||
(if (vector? x) (list 'list->vector (loop (vector->list x)))
|
(if (vector? x) (list 'list->vector (loop (vector->list x)))
|
||||||
(if (not (pair? x)) (cons 'quote (cons x '()))
|
(if (not (pair? x)) (cons 'quote (cons x '()))
|
||||||
(if (eq? (car x) 'quasiquote) (loop (loop (cadr x)))
|
(if (eq? (car x) 'quasiquote) (loop (loop (cadr x)))
|
||||||
|
@ -362,14 +345,14 @@
|
||||||
(and (segment-template? pattern)
|
(and (segment-template? pattern)
|
||||||
(or (null? (cddr pattern))
|
(or (null? (cddr pattern))
|
||||||
(syntax-error0 "segment matching not implemented" pattern))))
|
(syntax-error0 "segment matching not implemented" pattern))))
|
||||||
|
|
||||||
(define (segment-template? pattern)
|
(define (segment-template? pattern)
|
||||||
(and (pair? pattern)
|
(and (pair? pattern)
|
||||||
(pair? (cdr pattern))
|
(pair? (cdr pattern))
|
||||||
(memq (cadr pattern) indicators-for-zero-or-more)))
|
(memq (cadr pattern) indicators-for-zero-or-more)))
|
||||||
|
|
||||||
(define indicators-for-zero-or-more (list (string->symbol "...") '---))
|
(define indicators-for-zero-or-more (list (string->symbol "...") '---))
|
||||||
|
|
||||||
(lambda (exp r c)
|
(lambda (exp r c)
|
||||||
|
|
||||||
(define %input (r '%input)) ;Gensym these, if you like.
|
(define %input (r '%input)) ;Gensym these, if you like.
|
||||||
|
@ -406,7 +389,7 @@
|
||||||
0
|
0
|
||||||
(meta-variables pattern 0 '())))))
|
(meta-variables pattern 0 '())))))
|
||||||
(syntax-error2 "ill-formed syntax rule" rule)))
|
(syntax-error2 "ill-formed syntax rule" rule)))
|
||||||
|
|
||||||
;; Generate code to test whether input expression matches pattern
|
;; Generate code to test whether input expression matches pattern
|
||||||
|
|
||||||
(define (process-match input pattern)
|
(define (process-match input pattern)
|
||||||
|
@ -427,7 +410,7 @@
|
||||||
`((eq? ,input ',pattern)))
|
`((eq? ,input ',pattern)))
|
||||||
(else
|
(else
|
||||||
`((equal? ,input ',pattern)))))
|
`((equal? ,input ',pattern)))))
|
||||||
|
|
||||||
(define (process-segment-match input pattern)
|
(define (process-segment-match input pattern)
|
||||||
;;(core:display-error "process-segment-match:") (core:write-error input) (core:display-error "\n")
|
;;(core:display-error "process-segment-match:") (core:write-error input) (core:display-error "\n")
|
||||||
;;(core:display-error " pattern:") (core:write-error pattern) (core:display-error "\n")
|
;;(core:display-error " pattern:") (core:write-error pattern) (core:display-error "\n")
|
||||||
|
@ -439,7 +422,7 @@
|
||||||
(and (pair? l)
|
(and (pair? l)
|
||||||
,@conjuncts
|
,@conjuncts
|
||||||
(loop (cdr l)))))))))
|
(loop (cdr l)))))))))
|
||||||
|
|
||||||
;; Generate code to take apart the input expression
|
;; Generate code to take apart the input expression
|
||||||
;; This is pretty bad, but it seems to work (can't say why).
|
;; This is pretty bad, but it seems to work (can't say why).
|
||||||
|
|
||||||
|
@ -560,5 +543,3 @@
|
||||||
(if (not condition)
|
(if (not condition)
|
||||||
(begin exp ...))))))
|
(begin exp ...))))))
|
||||||
(xwhen #f 42)))
|
(xwhen #f 42)))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -52,32 +52,18 @@
|
||||||
(if (eq? x (car lst)) lst
|
(if (eq? x (car lst)) lst
|
||||||
(memq x (cdr lst)))))
|
(memq x (cdr lst)))))
|
||||||
|
|
||||||
;; (cond-expand
|
|
||||||
;; (guile
|
|
||||||
;; (define closure identity)
|
|
||||||
;; (define body identity)
|
|
||||||
;; (define append2 append)
|
|
||||||
;; (define (core:apply f a m) (f a))
|
|
||||||
;; )
|
|
||||||
;; (mes
|
|
||||||
(define (symbol? x)
|
(define (symbol? x)
|
||||||
(eq? (core:type x) <cell:symbol>))
|
(eq? (core:type x) <cell:symbol>))
|
||||||
|
|
||||||
(define (string->symbol s)
|
(define (string->symbol s)
|
||||||
(if (not (pair? (core:car s))) '()
|
(if (not (pair? (core:car s))) '()
|
||||||
(core:lookup-symbol (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>))
|
||||||
|
|
||||||
(define (vector? x)
|
(define (vector? x)
|
||||||
(eq? (core:type x) <cell:vector>))
|
(eq? (core:type x) <cell:vector>))
|
||||||
|
|
||||||
;; (define (body x)
|
|
||||||
;; (core:cdr (core:cdr (core:cdr (cdr (assq 'x (current-module)))))))
|
|
||||||
;; (define (closure x)
|
|
||||||
;; (map car (cdr (core:cdr (core:car (core:cdr (cdr (assq 'x (current-module)))))))))
|
|
||||||
;; ))
|
|
||||||
|
|
||||||
(define (cons* . rest)
|
(define (cons* . rest)
|
||||||
(if (null? (cdr rest)) (car rest)
|
(if (null? (cdr rest)) (car rest)
|
||||||
|
@ -93,9 +79,7 @@
|
||||||
(append2 (car rest) (apply append (cdr rest))))))
|
(append2 (car rest) (apply append (cdr rest))))))
|
||||||
|
|
||||||
(define-macro (quasiquote x)
|
(define-macro (quasiquote x)
|
||||||
;;(core:display-error "quasiquote:") (core:write-error x) (core:display-error "\n")
|
|
||||||
(define (loop x)
|
(define (loop x)
|
||||||
;;(core:display-error "loop:") (core:write-error x) (core:display-error "\n")
|
|
||||||
(if (vector? x) (list 'list->vector (loop (vector->list x)))
|
(if (vector? x) (list 'list->vector (loop (vector->list x)))
|
||||||
(if (not (pair? x)) (cons 'quote (cons x '()))
|
(if (not (pair? x)) (cons 'quote (cons x '()))
|
||||||
(if (eq? (car x) 'quasiquote) (loop (loop (cadr x)))
|
(if (eq? (car x) 'quasiquote) (loop (loop (cadr x)))
|
||||||
|
@ -272,14 +256,14 @@
|
||||||
(and (segment-template? pattern)
|
(and (segment-template? pattern)
|
||||||
(or (null? (cddr pattern))
|
(or (null? (cddr pattern))
|
||||||
(syntax-error "segment matching not implemented" pattern))))
|
(syntax-error "segment matching not implemented" pattern))))
|
||||||
|
|
||||||
(define (segment-template? pattern)
|
(define (segment-template? pattern)
|
||||||
(and (pair? pattern)
|
(and (pair? pattern)
|
||||||
(pair? (cdr pattern))
|
(pair? (cdr pattern))
|
||||||
(memq (cadr pattern) indicators-for-zero-or-more)))
|
(memq (cadr pattern) indicators-for-zero-or-more)))
|
||||||
|
|
||||||
(define indicators-for-zero-or-more (list (string->symbol "...") '---))
|
(define indicators-for-zero-or-more (list (string->symbol "...") '---))
|
||||||
|
|
||||||
(lambda (exp r c)
|
(lambda (exp r c)
|
||||||
|
|
||||||
(define %input (r '%input)) ;Gensym these, if you like.
|
(define %input (r '%input)) ;Gensym these, if you like.
|
||||||
|
@ -316,7 +300,7 @@
|
||||||
0
|
0
|
||||||
(meta-variables pattern 0 '())))))
|
(meta-variables pattern 0 '())))))
|
||||||
(syntax-error "ill-formed syntax rule" rule)))
|
(syntax-error "ill-formed syntax rule" rule)))
|
||||||
|
|
||||||
;; Generate code to test whether input expression matches pattern
|
;; Generate code to test whether input expression matches pattern
|
||||||
|
|
||||||
(define (process-match input pattern)
|
(define (process-match input pattern)
|
||||||
|
@ -337,7 +321,7 @@
|
||||||
`((eq? ,input ',pattern)))
|
`((eq? ,input ',pattern)))
|
||||||
(else
|
(else
|
||||||
`((equal? ,input ',pattern)))))
|
`((equal? ,input ',pattern)))))
|
||||||
|
|
||||||
(define (process-segment-match input pattern)
|
(define (process-segment-match input pattern)
|
||||||
;;(core:display-error "process-segment-match:") (core:write-error input) (core:display-error "\n")
|
;;(core:display-error "process-segment-match:") (core:write-error input) (core:display-error "\n")
|
||||||
;;(core:display-error " pattern:") (core:write-error pattern) (core:display-error "\n")
|
;;(core:display-error " pattern:") (core:write-error pattern) (core:display-error "\n")
|
||||||
|
@ -349,7 +333,7 @@
|
||||||
(and (pair? l)
|
(and (pair? l)
|
||||||
,@conjuncts
|
,@conjuncts
|
||||||
(loop (cdr l)))))))))
|
(loop (cdr l)))))))))
|
||||||
|
|
||||||
;; Generate code to take apart the input expression
|
;; Generate code to take apart the input expression
|
||||||
;; This is pretty bad, but it seems to work (can't say why).
|
;; This is pretty bad, but it seems to work (can't say why).
|
||||||
|
|
||||||
|
@ -470,4 +454,3 @@
|
||||||
(if (not condition)
|
(if (not condition)
|
||||||
(begin exp ...))))))
|
(begin exp ...))))))
|
||||||
(xwhen #f 42)))
|
(xwhen #f 42)))
|
||||||
|
|
||||||
|
|
|
@ -34,6 +34,7 @@
|
||||||
|
|
||||||
int ARENA_SIZE = 200000; // 32b: 2MiB, 64b: 4 MiB
|
int ARENA_SIZE = 200000; // 32b: 2MiB, 64b: 4 MiB
|
||||||
int MAX_ARENA_SIZE = 300000000;
|
int MAX_ARENA_SIZE = 300000000;
|
||||||
|
long STACK_SIZE = 20000;
|
||||||
int JAM_SIZE = 20000;
|
int JAM_SIZE = 20000;
|
||||||
int GC_SAFETY = 2000;
|
int GC_SAFETY = 2000;
|
||||||
|
|
||||||
|
@ -48,6 +49,9 @@ SCM g_symbols = 0;
|
||||||
SCM g_macros = 0;
|
SCM g_macros = 0;
|
||||||
SCM g_ports = 0;
|
SCM g_ports = 0;
|
||||||
SCM g_stack = 0;
|
SCM g_stack = 0;
|
||||||
|
SCM *g_stack_array = 0;
|
||||||
|
#define FRAME_SIZE 5
|
||||||
|
#define FRAME_PROCEDURE 4
|
||||||
// a/env
|
// a/env
|
||||||
SCM r0 = 0;
|
SCM r0 = 0;
|
||||||
// param 1
|
// param 1
|
||||||
|
@ -56,8 +60,10 @@ SCM r1 = 0;
|
||||||
SCM r2 = 0;
|
SCM r2 = 0;
|
||||||
// continuation
|
// continuation
|
||||||
SCM r3 = 0;
|
SCM r3 = 0;
|
||||||
|
// current-module
|
||||||
|
SCM m0 = 0;
|
||||||
|
|
||||||
enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
|
enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSTRUCT, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
|
||||||
|
|
||||||
struct scm {
|
struct scm {
|
||||||
enum type_t type;
|
enum type_t type;
|
||||||
|
@ -117,6 +123,7 @@ struct scm scm_symbol_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0};
|
||||||
struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0};
|
struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0};
|
||||||
struct scm scm_call_with_current_continuation = {TSPECIAL, "*call/cc*",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_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_current_module = {TSYMBOL, "current-module",0};
|
||||||
struct scm scm_symbol_primitive_load = {TSYMBOL, "primitive-load",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_read_input_file = {TSYMBOL, "read-input-file",0};
|
||||||
|
@ -131,6 +138,15 @@ 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_wrong_type_arg = {TSYMBOL, "wrong-type-arg",0};
|
||||||
struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0};
|
struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0};
|
||||||
|
|
||||||
|
struct scm scm_symbol_hashq_table = {TSYMBOL, "<hashq-table>",0};
|
||||||
|
struct scm scm_symbol_record_type = {TSYMBOL, "<record-type>",0};
|
||||||
|
struct scm scm_symbol_frame = {TSYMBOL, "<frame>",0};
|
||||||
|
struct scm scm_symbol_module = {TSYMBOL, "<module>",0};
|
||||||
|
struct scm scm_symbol_stack = {TSYMBOL, "<stack>",0};
|
||||||
|
struct scm scm_symbol_buckets = {TSYMBOL, "buckets",0};
|
||||||
|
struct scm scm_symbol_procedure = {TSYMBOL, "procedure",0};
|
||||||
|
struct scm scm_symbol_size = {TSYMBOL, "size",0};
|
||||||
|
|
||||||
struct scm scm_symbol_argv = {TSYMBOL, "%argv",0};
|
struct scm scm_symbol_argv = {TSYMBOL, "%argv",0};
|
||||||
struct scm scm_symbol_mes_prefix = {TSYMBOL, "%prefix",0};
|
struct scm scm_symbol_mes_prefix = {TSYMBOL, "%prefix",0};
|
||||||
struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0};
|
struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0};
|
||||||
|
@ -189,12 +205,14 @@ struct scm scm_type_port = {TSYMBOL, "<cell:port>",0};
|
||||||
struct scm scm_type_ref = {TSYMBOL, "<cell:ref>",0};
|
struct scm scm_type_ref = {TSYMBOL, "<cell:ref>",0};
|
||||||
struct scm scm_type_special = {TSYMBOL, "<cell:special>",0};
|
struct scm scm_type_special = {TSYMBOL, "<cell:special>",0};
|
||||||
struct scm scm_type_string = {TSYMBOL, "<cell:string>",0};
|
struct scm scm_type_string = {TSYMBOL, "<cell:string>",0};
|
||||||
|
struct scm scm_type_struct = {TSYMBOL, "<cell:struct>",0};
|
||||||
struct scm scm_type_symbol = {TSYMBOL, "<cell:symbol>",0};
|
struct scm scm_type_symbol = {TSYMBOL, "<cell:symbol>",0};
|
||||||
struct scm scm_type_values = {TSYMBOL, "<cell:values>",0};
|
struct scm scm_type_values = {TSYMBOL, "<cell:values>",0};
|
||||||
struct scm scm_type_variable = {TSYMBOL, "<cell:variable>",0};
|
struct scm scm_type_variable = {TSYMBOL, "<cell:variable>",0};
|
||||||
struct scm scm_type_vector = {TSYMBOL, "<cell:vector>",0};
|
struct scm scm_type_vector = {TSYMBOL, "<cell:vector>",0};
|
||||||
struct scm scm_type_broken_heart = {TSYMBOL, "<cell:broken-heart>",0};
|
struct scm scm_type_broken_heart = {TSYMBOL, "<cell:broken-heart>",0};
|
||||||
|
|
||||||
|
struct scm scm_symbol_internal_time_units_per_second = {TSYMBOL, "internal-time-units-per-second",0};
|
||||||
struct scm scm_symbol_compiler = {TSYMBOL, "%compiler",0};
|
struct scm scm_symbol_compiler = {TSYMBOL, "%compiler",0};
|
||||||
struct scm scm_symbol_arch = {TSYMBOL, "%arch",0};
|
struct scm scm_symbol_arch = {TSYMBOL, "%arch",0};
|
||||||
|
|
||||||
|
@ -234,6 +252,7 @@ SCM gc_init_news ();
|
||||||
#define LENGTH(x) g_cells[x].car
|
#define LENGTH(x) g_cells[x].car
|
||||||
#define REF(x) g_cells[x].car
|
#define REF(x) g_cells[x].car
|
||||||
#define STRING(x) g_cells[x].car
|
#define STRING(x) g_cells[x].car
|
||||||
|
#define STRUCT(x) g_cells[x].cdr
|
||||||
#define VARIABLE(x) g_cells[x].car
|
#define VARIABLE(x) g_cells[x].car
|
||||||
|
|
||||||
#define CLOSURE(x) g_cells[x].cdr
|
#define CLOSURE(x) g_cells[x].cdr
|
||||||
|
@ -330,15 +349,15 @@ list_of_char_equal_p (SCM a, SCM b) ///((internal))
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM
|
SCM
|
||||||
lookup_symbol_ (SCM s)
|
list_to_symbol (SCM lst)
|
||||||
{
|
{
|
||||||
SCM x = g_symbols;
|
SCM x = g_symbols;
|
||||||
while (x) {
|
while (x) {
|
||||||
if (list_of_char_equal_p (STRING (CAR (x)), s) == cell_t) break;
|
if (list_of_char_equal_p (STRING (CAR (x)), lst) == cell_t) break;
|
||||||
x = CDR (x);
|
x = CDR (x);
|
||||||
}
|
}
|
||||||
if (x) x = CAR (x);
|
if (x) x = CAR (x);
|
||||||
if (!x) x = make_symbol_ (s);
|
if (!x) x = make_symbol_ (lst);
|
||||||
return x;
|
return x;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -451,6 +470,14 @@ length (SCM x)
|
||||||
|
|
||||||
SCM apply (SCM, SCM, SCM);
|
SCM apply (SCM, SCM, SCM);
|
||||||
|
|
||||||
|
SCM
|
||||||
|
assq_ref_env (SCM x, SCM a)
|
||||||
|
{
|
||||||
|
x = assq (x, a);
|
||||||
|
if (x == cell_f) return cell_undefined;
|
||||||
|
return CDR (x);
|
||||||
|
}
|
||||||
|
|
||||||
SCM
|
SCM
|
||||||
error (SCM key, SCM x)
|
error (SCM key, SCM x)
|
||||||
{
|
{
|
||||||
|
@ -627,18 +654,27 @@ call (SCM fn, SCM x)
|
||||||
SCM
|
SCM
|
||||||
assq (SCM x, SCM a)
|
assq (SCM x, SCM a)
|
||||||
{
|
{
|
||||||
//FIXME: move into fast-non eq_p-ing assq core:assq?
|
while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f)
|
||||||
//while (a != cell_nil && x != CAAR (a)) a = CDR (a);
|
a = CDR (a);
|
||||||
while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a);
|
|
||||||
return a != cell_nil ? CAR (a) : cell_f;
|
return a != cell_nil ? CAR (a) : cell_f;
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM
|
SCM
|
||||||
assq_ref_env (SCM x, SCM a)
|
assoc_string (SCM x, SCM a) ///(internal))
|
||||||
{
|
{
|
||||||
x = assq (x, a);
|
while (a != cell_nil && list_of_char_equal_p (STRING (x), STRING (CAAR (a))) == cell_f)
|
||||||
if (x == cell_f) return cell_undefined;
|
a = CDR (a);
|
||||||
return CDR (x);
|
return a != cell_nil ? CAR (a) : cell_f;
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
assoc (SCM x, SCM a)
|
||||||
|
{
|
||||||
|
if (TYPE (x) == TSTRING)
|
||||||
|
return assoc_string (x, a);
|
||||||
|
while (a != cell_nil && equal2_p (x, CAAR (a)) == cell_f)
|
||||||
|
a = CDR (a);
|
||||||
|
return a != cell_nil ? CAR (a) : cell_f;
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM
|
SCM
|
||||||
|
@ -681,11 +717,8 @@ make_closure_ (SCM args, SCM body, SCM a) ///((internal))
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM
|
SCM
|
||||||
lookup_macro_ (SCM x, SCM a) ///((internal))
|
macro_get_handle (SCM name)
|
||||||
{
|
{
|
||||||
if (TYPE (x) != TSYMBOL) return cell_f;
|
|
||||||
SCM m = assq_ref_env (x, a);
|
|
||||||
if (TYPE (m) == TMACRO) return MACRO (m);
|
|
||||||
return cell_f;
|
return cell_f;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -781,6 +814,19 @@ make_tmps (struct scm* cells)
|
||||||
#endif
|
#endif
|
||||||
#include "lib.c"
|
#include "lib.c"
|
||||||
|
|
||||||
|
SCM frame_printer (SCM frame)
|
||||||
|
{
|
||||||
|
}
|
||||||
|
SCM make_stack (SCM stack)
|
||||||
|
{
|
||||||
|
}
|
||||||
|
SCM stack_length (SCM stack)
|
||||||
|
{
|
||||||
|
}
|
||||||
|
SCM stack_ref (SCM stack, SCM index)
|
||||||
|
{
|
||||||
|
}
|
||||||
|
|
||||||
// Jam Collector
|
// Jam Collector
|
||||||
SCM g_symbol_max;
|
SCM g_symbol_max;
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,37 @@
|
||||||
|
/* -*-comment-start: "//";comment-end:""-*-
|
||||||
|
* 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/>.
|
||||||
|
*/
|
||||||
|
|
||||||
|
#include <libmes.h>
|
||||||
|
|
||||||
|
#include <stdlib.h>
|
||||||
|
#include <stdio.h>
|
||||||
|
#include <stdarg.h>
|
||||||
|
|
||||||
|
int
|
||||||
|
main ()
|
||||||
|
{
|
||||||
|
int n = snprintf (0, 0, "%s", "0123456");
|
||||||
|
eputs ("***n="); eputs (itoa (n)); eputs ("\n");
|
||||||
|
exit(n != 7);
|
||||||
|
|
||||||
|
/* if (n) */
|
||||||
|
/* return 1; */
|
||||||
|
return 0;
|
||||||
|
}
|
26
src/gc.c
26
src/gc.c
|
@ -23,6 +23,7 @@
|
||||||
SCM
|
SCM
|
||||||
gc_up_arena () ///((internal))
|
gc_up_arena () ///((internal))
|
||||||
{
|
{
|
||||||
|
long old_arena_bytes = (ARENA_SIZE+JAM_SIZE)*sizeof (struct scm);
|
||||||
if (ARENA_SIZE >> 1 < MAX_ARENA_SIZE >> 2)
|
if (ARENA_SIZE >> 1 < MAX_ARENA_SIZE >> 2)
|
||||||
{
|
{
|
||||||
ARENA_SIZE <<= 1;
|
ARENA_SIZE <<= 1;
|
||||||
|
@ -31,7 +32,8 @@ gc_up_arena () ///((internal))
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
ARENA_SIZE = MAX_ARENA_SIZE -JAM_SIZE;
|
ARENA_SIZE = MAX_ARENA_SIZE -JAM_SIZE;
|
||||||
void *p = realloc (g_cells-1, (ARENA_SIZE+JAM_SIZE)*sizeof (struct scm));
|
long arena_bytes = (ARENA_SIZE+JAM_SIZE)*sizeof (struct scm);
|
||||||
|
void *p = realloc (g_cells-1, arena_bytes+STACK_SIZE*sizeof (SCM));
|
||||||
if (!p)
|
if (!p)
|
||||||
{
|
{
|
||||||
eputs ("realloc failed, g_free=");
|
eputs ("realloc failed, g_free=");
|
||||||
|
@ -43,12 +45,13 @@ gc_up_arena () ///((internal))
|
||||||
exit (1);
|
exit (1);
|
||||||
}
|
}
|
||||||
g_cells = (struct scm*)p;
|
g_cells = (struct scm*)p;
|
||||||
|
memcpy (p + arena_bytes, p + old_arena_bytes, STACK_SIZE*sizeof (SCM));
|
||||||
g_cells++;
|
g_cells++;
|
||||||
|
|
||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM
|
void
|
||||||
gc_flip () ///((internal))
|
gc_flip () ///((internal))
|
||||||
{
|
{
|
||||||
if (g_debug > 2)
|
if (g_debug > 2)
|
||||||
|
@ -60,7 +63,6 @@ gc_flip () ///((internal))
|
||||||
if (g_free > JAM_SIZE)
|
if (g_free > JAM_SIZE)
|
||||||
JAM_SIZE = g_free + g_free / 2;
|
JAM_SIZE = g_free + g_free / 2;
|
||||||
memcpy (g_cells-1, g_news-1, (g_free+2)*sizeof (struct scm));
|
memcpy (g_cells-1, g_news-1, (g_free+2)*sizeof (struct scm));
|
||||||
return g_stack;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM
|
SCM
|
||||||
|
@ -70,7 +72,8 @@ gc_copy (SCM old) ///((internal))
|
||||||
return g_cells[old].car;
|
return g_cells[old].car;
|
||||||
SCM new = g_free++;
|
SCM new = g_free++;
|
||||||
g_news[new] = g_cells[old];
|
g_news[new] = g_cells[old];
|
||||||
if (NTYPE (new) == TVECTOR)
|
if (NTYPE (new) == TSTRUCT
|
||||||
|
|| NTYPE (new) == TVECTOR)
|
||||||
{
|
{
|
||||||
NVECTOR (new) = g_free;
|
NVECTOR (new) = g_free;
|
||||||
for (long i=0; i<LENGTH (old); i++)
|
for (long i=0; i<LENGTH (old); i++)
|
||||||
|
@ -95,7 +98,7 @@ gc_relocate_cdr (SCM new, SCM cdr) ///((internal))
|
||||||
return cell_unspecified;
|
return cell_unspecified;
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM
|
void
|
||||||
gc_loop (SCM scan) ///((internal))
|
gc_loop (SCM scan) ///((internal))
|
||||||
{
|
{
|
||||||
SCM car;
|
SCM car;
|
||||||
|
@ -131,7 +134,7 @@ gc_loop (SCM scan) ///((internal))
|
||||||
}
|
}
|
||||||
scan++;
|
scan++;
|
||||||
}
|
}
|
||||||
return gc_flip ();
|
gc_flip ();
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM
|
SCM
|
||||||
|
@ -199,14 +202,9 @@ gc_ () ///((internal))
|
||||||
g_symbols = gc_copy (g_symbols);
|
g_symbols = gc_copy (g_symbols);
|
||||||
g_macros = gc_copy (g_macros);
|
g_macros = gc_copy (g_macros);
|
||||||
g_ports = gc_copy (g_ports);
|
g_ports = gc_copy (g_ports);
|
||||||
SCM new = gc_copy (g_stack);
|
m0 = gc_copy (m0);
|
||||||
if (g_debug > 3)
|
for (long i=g_stack; i<STACK_SIZE; i++)
|
||||||
{
|
g_stack_array[i]= gc_copy (g_stack_array[i]);
|
||||||
eputs ("new=");
|
|
||||||
eputs (itoa (new));
|
|
||||||
eputs ("\n");
|
|
||||||
}
|
|
||||||
g_stack = new;
|
|
||||||
gc_loop (1);
|
gc_loop (1);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,237 @@
|
||||||
|
/* -*-comment-start: "//";comment-end:""-*-
|
||||||
|
* 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/>.
|
||||||
|
*/
|
||||||
|
|
||||||
|
SCM make_vector__ (long k);
|
||||||
|
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)
|
||||||
|
{
|
||||||
|
int hash = VALUE (CAR (lst)) * 37;
|
||||||
|
if (TYPE (CDR (lst)) == TPAIR && TYPE (CADR (lst)) == TCHAR)
|
||||||
|
hash = hash + VALUE (CADR (lst)) * 43;
|
||||||
|
assert (size);
|
||||||
|
hash = hash % size;
|
||||||
|
return hash;
|
||||||
|
}
|
||||||
|
|
||||||
|
int
|
||||||
|
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));
|
||||||
|
}
|
||||||
|
|
||||||
|
int
|
||||||
|
hash_ (SCM x, long size)
|
||||||
|
{
|
||||||
|
if (TYPE (x) == TSTRING)
|
||||||
|
return hash_list_of_char (STRING (x), size);
|
||||||
|
assert (0);
|
||||||
|
return hashq_ (x, size);
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
hashq (SCM x, SCM size)
|
||||||
|
{
|
||||||
|
assert (0);
|
||||||
|
return MAKE_NUMBER (hashq_ (x, VALUE (size)));
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
hash (SCM x, SCM size)
|
||||||
|
{
|
||||||
|
assert (0);
|
||||||
|
return MAKE_NUMBER (hash_ (x, VALUE (size)));
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
hashq_get_handle (SCM table, SCM key, SCM dflt)
|
||||||
|
{
|
||||||
|
long size = VALUE (struct_ref_ (table, 3));
|
||||||
|
unsigned hash = hashq_ (key, size);
|
||||||
|
SCM buckets = struct_ref_ (table, 4);
|
||||||
|
SCM bucket = vector_ref_ (buckets, hash);
|
||||||
|
SCM x = cell_f;
|
||||||
|
if (TYPE (dflt) == TPAIR)
|
||||||
|
x = CAR (dflt);
|
||||||
|
if (TYPE (bucket) == TPAIR)
|
||||||
|
x = assq (key, bucket);
|
||||||
|
return x;
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
hashq_ref (SCM table, SCM key, SCM dflt)
|
||||||
|
{
|
||||||
|
#if defined (INLINE)
|
||||||
|
SCM x = hashq_get_handle (table, key, dflt);
|
||||||
|
#else
|
||||||
|
long size = VALUE (struct_ref_ (table, 3));
|
||||||
|
unsigned hash = hashq_ (key, size);
|
||||||
|
SCM buckets = struct_ref_ (table, 4);
|
||||||
|
SCM bucket = vector_ref_ (buckets, hash);
|
||||||
|
SCM x = cell_f;
|
||||||
|
if (TYPE (dflt) == TPAIR)
|
||||||
|
x = CAR (dflt);
|
||||||
|
if (TYPE (bucket) == TPAIR)
|
||||||
|
x = assq (key, bucket);
|
||||||
|
#endif
|
||||||
|
if (x != cell_f)
|
||||||
|
x = CDR (x);
|
||||||
|
return x;
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
hash_ref (SCM table, SCM key, SCM dflt)
|
||||||
|
{
|
||||||
|
long size = VALUE (struct_ref_ (table, 3));
|
||||||
|
unsigned hash = hash_ (key, size);
|
||||||
|
SCM buckets = struct_ref_ (table, 4);
|
||||||
|
SCM bucket = vector_ref_ (buckets, hash);
|
||||||
|
SCM x = cell_f;
|
||||||
|
if (TYPE (dflt) == TPAIR)
|
||||||
|
x = CAR (dflt);
|
||||||
|
if (TYPE (bucket) == TPAIR)
|
||||||
|
{
|
||||||
|
x = assoc (key, bucket);
|
||||||
|
if (x != cell_f)
|
||||||
|
x = CDR (x);
|
||||||
|
}
|
||||||
|
return x;
|
||||||
|
}
|
||||||
|
|
||||||
|
#if defined (INLINE)
|
||||||
|
#error INLINE
|
||||||
|
SCM
|
||||||
|
hash_set_x_ (SCM table, unsigned hash, SCM key, SCM value)
|
||||||
|
{
|
||||||
|
SCM buckets = struct_ref_ (table, 4);
|
||||||
|
SCM bucket = vector_ref_ (buckets, hash);
|
||||||
|
if (TYPE (bucket) != TPAIR)
|
||||||
|
bucket = cell_nil;
|
||||||
|
bucket = acons (key, value, bucket);
|
||||||
|
vector_set_x_ (buckets, hash, bucket);
|
||||||
|
return value;
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
|
||||||
|
SCM
|
||||||
|
hashq_set_x (SCM table, SCM key, SCM value)
|
||||||
|
{
|
||||||
|
long size = VALUE (struct_ref_ (table, 3));
|
||||||
|
unsigned hash = hashq_ (key, size);
|
||||||
|
#if defined (INLINE)
|
||||||
|
return hash_set_x_ (table, hash, key, value);
|
||||||
|
#else
|
||||||
|
SCM buckets = struct_ref_ (table, 4);
|
||||||
|
SCM bucket = vector_ref_ (buckets, hash);
|
||||||
|
if (TYPE (bucket) != TPAIR)
|
||||||
|
bucket = cell_nil;
|
||||||
|
bucket = acons (key, value, bucket);
|
||||||
|
vector_set_x_ (buckets, hash, bucket);
|
||||||
|
return value;
|
||||||
|
#endif
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
hash_set_x (SCM table, SCM key, SCM value)
|
||||||
|
{
|
||||||
|
long size = VALUE (struct_ref_ (table, 3));
|
||||||
|
unsigned hash = hash_ (key, size);
|
||||||
|
#if defined (INLINE)
|
||||||
|
return hash_set_x_ (table, hash, key, value);
|
||||||
|
#else
|
||||||
|
SCM buckets = struct_ref_ (table, 4);
|
||||||
|
SCM bucket = vector_ref_ (buckets, hash);
|
||||||
|
if (TYPE (bucket) != TPAIR)
|
||||||
|
bucket = cell_nil;
|
||||||
|
bucket = acons (key, value, bucket);
|
||||||
|
vector_set_x_ (buckets, hash, bucket);
|
||||||
|
return value;
|
||||||
|
#endif
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
hash_table_printer (SCM table)
|
||||||
|
{
|
||||||
|
fdputs ("#<", g_stdout); display_ (struct_ref_ (table, 2)); fdputc (' ', g_stdout);
|
||||||
|
fdputs ("size: ", g_stdout); display_ (struct_ref_ (table, 3)); fdputc (' ', g_stdout);
|
||||||
|
SCM buckets = struct_ref_ (table, 4);
|
||||||
|
fdputs ("buckets: ", g_stdout);
|
||||||
|
for (int i=0; i<LENGTH (buckets); i++)
|
||||||
|
{
|
||||||
|
SCM e = vector_ref_ (buckets, i);
|
||||||
|
if (e != cell_unspecified)
|
||||||
|
{
|
||||||
|
fdputc ('[', g_stdout);
|
||||||
|
while (TYPE (e) == TPAIR)
|
||||||
|
{
|
||||||
|
write_ (CAAR (e));
|
||||||
|
e = CDR (e);
|
||||||
|
if (TYPE (e) == TPAIR)
|
||||||
|
fdputc (' ', g_stdout);
|
||||||
|
}
|
||||||
|
fdputs ("]\n ", g_stdout);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
fdputc ('>', g_stdout);
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
make_hashq_type () ///((internal))
|
||||||
|
{
|
||||||
|
SCM record_type = cell_symbol_record_type; // FIXME
|
||||||
|
SCM fields = cell_nil;
|
||||||
|
fields = cons (cell_symbol_buckets, fields);
|
||||||
|
fields = cons (cell_symbol_size, fields);
|
||||||
|
fields = cons (fields, cell_nil);
|
||||||
|
fields = cons (cell_symbol_hashq_table, fields);
|
||||||
|
return make_struct (record_type, fields, cell_unspecified);
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
make_hash_table_ (long size)
|
||||||
|
{
|
||||||
|
if (!size)
|
||||||
|
size = 100;
|
||||||
|
SCM hashq_type = make_hashq_type ();
|
||||||
|
|
||||||
|
SCM buckets = make_vector__ (size);
|
||||||
|
SCM values = cell_nil;
|
||||||
|
values = cons (buckets, values);
|
||||||
|
values = cons (MAKE_NUMBER (size), values);
|
||||||
|
values = cons (cell_symbol_hashq_table, values);
|
||||||
|
return make_struct (hashq_type, values, cell_hash_table_printer);
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
make_hash_table (SCM x)
|
||||||
|
{
|
||||||
|
long size = 0;
|
||||||
|
if (TYPE (x) == TPAIR)
|
||||||
|
{
|
||||||
|
assert (TYPE (x) == TNUMBER);
|
||||||
|
size = VALUE (x);
|
||||||
|
}
|
||||||
|
return make_hash_table_ (size);
|
||||||
|
}
|
116
src/lib.c
116
src/lib.c
|
@ -55,7 +55,12 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
|
||||||
else if (t == TCLOSURE)
|
else if (t == TCLOSURE)
|
||||||
{
|
{
|
||||||
fdputs ("#<closure ", fd);
|
fdputs ("#<closure ", fd);
|
||||||
display_helper (CDR (x), cont, "", fd, 0);
|
SCM circ = CADR (x);
|
||||||
|
SCM name = CADR (circ);
|
||||||
|
SCM args = CAR (CDDR (x));
|
||||||
|
display_helper (CAR (name), 0, "", fd, 0);
|
||||||
|
fdputc (' ', fd);
|
||||||
|
display_helper (args, 0, "", fd, 0);
|
||||||
fdputs (">", fd);
|
fdputs (">", fd);
|
||||||
}
|
}
|
||||||
else if (t == TFUNCTION)
|
else if (t == TFUNCTION)
|
||||||
|
@ -166,11 +171,34 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
|
||||||
if (TYPE (x) == TPORT)
|
if (TYPE (x) == TPORT)
|
||||||
fdputs (">", fd);
|
fdputs (">", fd);
|
||||||
}
|
}
|
||||||
|
else if (t == TREF)
|
||||||
|
fdisplay_ (REF (x), fd, write_p);
|
||||||
|
else if (t == TSTRUCT)
|
||||||
|
{
|
||||||
|
SCM printer = STRUCT (x) + 1;
|
||||||
|
if (TYPE (printer) == TREF)
|
||||||
|
printer = REF (printer);
|
||||||
|
if (printer != cell_unspecified)
|
||||||
|
apply (printer, cons (x, cell_nil), r0);
|
||||||
|
else
|
||||||
|
{
|
||||||
|
fdputs ("#<", fd);
|
||||||
|
fdisplay_ (STRUCT (x), fd, write_p);
|
||||||
|
SCM t = CAR (x);
|
||||||
|
long size = LENGTH (x);
|
||||||
|
for (long i=2; i<size; i++)
|
||||||
|
{
|
||||||
|
fdputc (' ', fd);
|
||||||
|
fdisplay_ (STRUCT (x) + i, fd, write_p);
|
||||||
|
}
|
||||||
|
fdputc ('>', fd);
|
||||||
|
}
|
||||||
|
}
|
||||||
else if (t == TVECTOR)
|
else if (t == TVECTOR)
|
||||||
{
|
{
|
||||||
fdputs ("#(", fd);
|
fdputs ("#(", fd);
|
||||||
SCM t = CAR (x);
|
SCM t = CAR (x);
|
||||||
for (long i = 0; i < LENGTH (x); i++)
|
for (long i = 0; i<LENGTH (x); i++)
|
||||||
{
|
{
|
||||||
if (i)
|
if (i)
|
||||||
fdputc (' ', fd);
|
fdputc (' ', fd);
|
||||||
|
@ -245,6 +273,84 @@ exit_ (SCM x) ///((name . "exit"))
|
||||||
exit (VALUE (x));
|
exit (VALUE (x));
|
||||||
}
|
}
|
||||||
|
|
||||||
|
#if !MES_MINI
|
||||||
|
SCM
|
||||||
|
frame_printer (SCM frame)
|
||||||
|
{
|
||||||
|
fdputs ("#<", g_stdout); display_ (struct_ref_ (frame, 2));
|
||||||
|
fdputc (' ', g_stdout);
|
||||||
|
fdputs ("procedure: ", g_stdout); display_ (struct_ref_ (frame, 3));
|
||||||
|
fdputc ('>', g_stdout);
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
make_frame_type () ///((internal))
|
||||||
|
{
|
||||||
|
SCM record_type = cell_symbol_record_type; // FIXME
|
||||||
|
SCM fields = cell_nil;
|
||||||
|
fields = cons (cell_symbol_procedure, fields);
|
||||||
|
fields = cons (fields, cell_nil);
|
||||||
|
fields = cons (cell_symbol_frame, fields);
|
||||||
|
return make_struct (record_type, fields, cell_unspecified);
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
make_frame (SCM stack, long index)
|
||||||
|
{
|
||||||
|
SCM frame_type = make_frame_type ();
|
||||||
|
long array_index = (STACK_SIZE-(index*FRAME_SIZE));
|
||||||
|
SCM procedure = g_stack_array[array_index+FRAME_PROCEDURE];
|
||||||
|
if (!procedure)
|
||||||
|
procedure = cell_f;
|
||||||
|
SCM values = cell_nil;
|
||||||
|
values = cons (procedure, values);
|
||||||
|
values = cons (cell_symbol_frame, values);
|
||||||
|
return make_struct (frame_type, values, cell_frame_printer);
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
make_stack_type () ///((internal))
|
||||||
|
{
|
||||||
|
SCM record_type = cell_symbol_record_type; // FIXME
|
||||||
|
SCM fields = cell_nil;
|
||||||
|
fields = cons (cstring_to_symbol ("frames"), fields);
|
||||||
|
fields = cons (fields, cell_nil);
|
||||||
|
fields = cons (cell_symbol_stack, fields);
|
||||||
|
return make_struct (record_type, fields, cell_unspecified);
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
make_stack (SCM stack) ///((arity . n))
|
||||||
|
{
|
||||||
|
SCM stack_type = make_stack_type ();
|
||||||
|
long size = (STACK_SIZE-g_stack) / FRAME_SIZE;
|
||||||
|
SCM frames = make_vector__ (size);
|
||||||
|
for (long i=0; i<size; i++)
|
||||||
|
{
|
||||||
|
SCM frame = make_frame (stack, i);
|
||||||
|
vector_set_x_ (frames, i, frame);
|
||||||
|
}
|
||||||
|
SCM values = cell_nil;
|
||||||
|
values = cons (frames, values);
|
||||||
|
values = cons (cell_symbol_stack, values);
|
||||||
|
return make_struct (stack_type, values, cell_unspecified);
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
stack_length (SCM stack)
|
||||||
|
{
|
||||||
|
SCM frames = struct_ref_ (stack, 3);
|
||||||
|
return vector_length (frames);
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
stack_ref (SCM stack, SCM index)
|
||||||
|
{
|
||||||
|
SCM frames = struct_ref_ (stack, 3);
|
||||||
|
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
|
||||||
{
|
{
|
||||||
|
@ -325,3 +431,9 @@ last_pair (SCM x)
|
||||||
x = CDR (x);
|
x = CDR (x);
|
||||||
return x;
|
return x;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
pair_p (SCM x)
|
||||||
|
{
|
||||||
|
return TYPE (x) == TPAIR ? cell_t : cell_f;
|
||||||
|
}
|
||||||
|
|
|
@ -0,0 +1,124 @@
|
||||||
|
/* -*-comment-start: "//";comment-end:""-*-
|
||||||
|
* 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/>.
|
||||||
|
*/
|
||||||
|
|
||||||
|
SCM struct_ref_ (SCM x, long i);
|
||||||
|
SCM struct_set_x_ (SCM x, long i, SCM e);
|
||||||
|
|
||||||
|
SCM
|
||||||
|
make_module_type () ///(internal))
|
||||||
|
{
|
||||||
|
SCM record_type = cell_symbol_record_type; // FIXME
|
||||||
|
SCM fields = cell_nil;
|
||||||
|
fields = cons (cstring_to_symbol ("globals"), fields);
|
||||||
|
fields = cons (cstring_to_symbol ("locals"), fields);
|
||||||
|
fields = cons (cstring_to_symbol ("name"), fields);
|
||||||
|
fields = cons (fields, cell_nil);
|
||||||
|
fields = cons (cell_symbol_module, fields);
|
||||||
|
return make_struct (record_type, fields, cell_unspecified);
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
make_initial_module (SCM a) ///((internal))
|
||||||
|
{
|
||||||
|
SCM module_type = make_module_type ();
|
||||||
|
a = acons (cell_symbol_module, module_type, a);
|
||||||
|
|
||||||
|
SCM hashq_type = make_hashq_type ();
|
||||||
|
a = acons (cell_symbol_hashq_table, hashq_type, a);
|
||||||
|
|
||||||
|
SCM name = cons (cstring_to_symbol ("boot"), cell_nil);
|
||||||
|
SCM globals = make_hash_table_ (0);
|
||||||
|
SCM locals = cell_nil;
|
||||||
|
|
||||||
|
SCM values = cell_nil;
|
||||||
|
values = cons (globals, values);
|
||||||
|
values = cons (locals, values);
|
||||||
|
values = cons (name, values);
|
||||||
|
values = cons (cell_symbol_module, values);
|
||||||
|
SCM module = make_struct (module_type, values, cell_module_printer);
|
||||||
|
r0 = cell_nil;
|
||||||
|
r0 = cons (CADR (a), r0);
|
||||||
|
r0 = cons (CAR (a), r0);
|
||||||
|
m0 = module;
|
||||||
|
while (TYPE (a) == TPAIR)
|
||||||
|
{
|
||||||
|
if (g_debug > 3)
|
||||||
|
{
|
||||||
|
eputs ("entry="); write_error_ (CAR (a)); eputs ("\n");
|
||||||
|
}
|
||||||
|
module_define_x (module, CAAR (a), CDAR (a));
|
||||||
|
a = CDR (a);
|
||||||
|
}
|
||||||
|
|
||||||
|
return module;
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
module_printer (SCM module)
|
||||||
|
{
|
||||||
|
//module = m0;
|
||||||
|
fdputs ("#<", g_stdout); display_ (struct_ref_ (module, 2)); fdputc (' ', g_stdout);
|
||||||
|
fdputs ("name: ", g_stdout); display_ (struct_ref_ (module, 3)); fdputc (' ', g_stdout);
|
||||||
|
fdputs ("locals: ", g_stdout); display_ (struct_ref_ (module, 4)); fdputc (' ', g_stdout);
|
||||||
|
SCM table = struct_ref_ (module, 5);
|
||||||
|
fdputs ("globals:\n ", g_stdout);
|
||||||
|
display_ (table);
|
||||||
|
fdputc ('>', g_stdout);
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
module_variable (SCM module, SCM name)
|
||||||
|
{
|
||||||
|
//SCM locals = struct_ref_ (module, 3);
|
||||||
|
SCM locals = module;
|
||||||
|
SCM x = assq (name, locals);
|
||||||
|
if (x == cell_f)
|
||||||
|
{
|
||||||
|
module = m0;
|
||||||
|
SCM globals = struct_ref_ (module, 5);
|
||||||
|
x = hashq_get_handle (globals, name, cell_f);
|
||||||
|
}
|
||||||
|
return x;
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
module_ref (SCM module, SCM name)
|
||||||
|
{
|
||||||
|
if (g_debug > 4)
|
||||||
|
{
|
||||||
|
eputs ("module_ref: "); display_error_ (name); eputs ("\n");
|
||||||
|
}
|
||||||
|
SCM x = module_variable (module, name);
|
||||||
|
if (x == cell_f)
|
||||||
|
return cell_undefined;
|
||||||
|
return CDR (x);
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
module_define_x (SCM module, SCM name, SCM value)
|
||||||
|
{
|
||||||
|
if (g_debug > 4)
|
||||||
|
{
|
||||||
|
eputs ("module_define_x: "); display_error_ (name); eputs ("\n");
|
||||||
|
}
|
||||||
|
module = m0;
|
||||||
|
SCM globals = struct_ref_ (module, 5);
|
||||||
|
return hashq_set_x (globals, name, value);
|
||||||
|
}
|
59
src/posix.c
59
src/posix.c
|
@ -18,10 +18,12 @@
|
||||||
* 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 <sys/stat.h>
|
|
||||||
#include <sys/wait.h>
|
|
||||||
#include <fcntl.h>
|
#include <fcntl.h>
|
||||||
#include <stdlib.h>
|
#include <stdlib.h>
|
||||||
|
#include <sys/stat.h>
|
||||||
|
#include <sys/time.h>
|
||||||
|
#include <sys/wait.h>
|
||||||
|
#include <time.h>
|
||||||
#include <unistd.h>
|
#include <unistd.h>
|
||||||
|
|
||||||
int readchar ();
|
int readchar ();
|
||||||
|
@ -110,8 +112,11 @@ write_char (SCM i) ///((arity . n))
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM
|
SCM
|
||||||
read_string ()
|
read_string (SCM port) ///((arity . n))
|
||||||
{
|
{
|
||||||
|
int fd = g_stdin;
|
||||||
|
if (TYPE (port) == TPAIR && TYPE (car (port)) == TNUMBER)
|
||||||
|
g_stdin = VALUE (CAR (port));
|
||||||
SCM lst = cell_nil;
|
SCM lst = cell_nil;
|
||||||
SCM c = read_char ();
|
SCM c = read_char ();
|
||||||
while (VALUE (c) != -1)
|
while (VALUE (c) != -1)
|
||||||
|
@ -119,6 +124,7 @@ read_string ()
|
||||||
lst = append2 (lst, cons (c, cell_nil));
|
lst = append2 (lst, cons (c, cell_nil));
|
||||||
c = read_char ();
|
c = read_char ();
|
||||||
}
|
}
|
||||||
|
g_stdin = fd;
|
||||||
return MAKE_STRING (lst);
|
return MAKE_STRING (lst);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -303,3 +309,50 @@ waitpid_ (SCM pid, SCM options)
|
||||||
int child = waitpid (VALUE (pid), &status, VALUE (options));
|
int child = waitpid (VALUE (pid), &status, VALUE (options));
|
||||||
return cons (MAKE_NUMBER (child), MAKE_NUMBER (status));
|
return cons (MAKE_NUMBER (child), MAKE_NUMBER (status));
|
||||||
}
|
}
|
||||||
|
|
||||||
|
#if __x86_64__
|
||||||
|
/* Nanoseconds on 64-bit systems with POSIX timers. */
|
||||||
|
#define TIME_UNITS_PER_SECOND 1000000000
|
||||||
|
#else
|
||||||
|
/* Milliseconds for everyone else. */
|
||||||
|
#define TIME_UNITS_PER_SECOND 1000
|
||||||
|
#endif
|
||||||
|
|
||||||
|
struct timespec g_start_time;
|
||||||
|
SCM
|
||||||
|
init_time (SCM a) ///((internal))
|
||||||
|
{
|
||||||
|
clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &g_start_time);
|
||||||
|
a = acons (cell_symbol_internal_time_units_per_second, MAKE_NUMBER (TIME_UNITS_PER_SECOND), a);
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
current_time ()
|
||||||
|
{
|
||||||
|
return MAKE_NUMBER (time (0));
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
gettimeofday_ () ///((name . "gettimeofday"))
|
||||||
|
{
|
||||||
|
struct timeval time;
|
||||||
|
gettimeofday (&time, 0);
|
||||||
|
return cons (MAKE_NUMBER (time.tv_sec), MAKE_NUMBER (time.tv_usec));
|
||||||
|
}
|
||||||
|
|
||||||
|
long
|
||||||
|
seconds_and_nanoseconds_to_long (long s, long ns)
|
||||||
|
{
|
||||||
|
return s * TIME_UNITS_PER_SECOND
|
||||||
|
+ ns / (1000000000 / TIME_UNITS_PER_SECOND);
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
get_internal_run_time ()
|
||||||
|
{
|
||||||
|
struct timespec ts;
|
||||||
|
clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &ts);
|
||||||
|
long time = seconds_and_nanoseconds_to_long (ts.tv_sec - g_start_time.tv_sec,
|
||||||
|
ts.tv_nsec - g_start_time.tv_nsec);
|
||||||
|
return MAKE_NUMBER (time);
|
||||||
|
}
|
||||||
|
|
|
@ -34,8 +34,9 @@ read_input_file_env_ (SCM e, SCM a)
|
||||||
SCM
|
SCM
|
||||||
read_input_file_env (SCM a)
|
read_input_file_env (SCM a)
|
||||||
{
|
{
|
||||||
r0 = a;
|
//r0 = a;
|
||||||
return read_input_file_env_ (read_env (r0), r0);
|
//return read_input_file_env_ (read_env (r0), r0);
|
||||||
|
return read_input_file_env_ (read_env (cell_nil), cell_nil);
|
||||||
}
|
}
|
||||||
|
|
||||||
int
|
int
|
||||||
|
@ -103,7 +104,7 @@ reader_read_identifier_or_number (int c)
|
||||||
}
|
}
|
||||||
unreadchar (c);
|
unreadchar (c);
|
||||||
buf[i] = 0;
|
buf[i] = 0;
|
||||||
return lookup_symbol_ (cstring_to_list (buf));
|
return cstring_to_symbol (buf);
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM
|
SCM
|
||||||
|
|
|
@ -0,0 +1,83 @@
|
||||||
|
/* -*-comment-start: "//";comment-end:""-*-
|
||||||
|
* 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/>.
|
||||||
|
*/
|
||||||
|
|
||||||
|
SCM
|
||||||
|
make_struct (SCM type, SCM fields, SCM printer)
|
||||||
|
{
|
||||||
|
long size = 2 + length__ (fields);
|
||||||
|
SCM v = alloc (size);
|
||||||
|
SCM x = make_cell__ (TSTRUCT, size, v);
|
||||||
|
g_cells[v] = g_cells[vector_entry (type)];
|
||||||
|
g_cells[v+1] = g_cells[vector_entry (printer)];
|
||||||
|
for (long i=2; i<size; i++)
|
||||||
|
{
|
||||||
|
SCM e = cell_unspecified;
|
||||||
|
if (fields != cell_nil)
|
||||||
|
{
|
||||||
|
e = CAR (fields);
|
||||||
|
fields = CDR (fields);
|
||||||
|
}
|
||||||
|
g_cells[v+i] = g_cells[vector_entry (e)];
|
||||||
|
}
|
||||||
|
return x;
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
struct_length (SCM x)
|
||||||
|
{
|
||||||
|
assert (TYPE (x) == TSTRUCT);
|
||||||
|
return MAKE_NUMBER (LENGTH (x));
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
struct_ref_ (SCM x, long i)
|
||||||
|
{
|
||||||
|
assert (TYPE (x) == TSTRUCT);
|
||||||
|
assert (i < LENGTH (x));
|
||||||
|
SCM e = STRUCT (x) + i;
|
||||||
|
if (TYPE (e) == TREF)
|
||||||
|
e = REF (e);
|
||||||
|
if (TYPE (e) == TCHAR)
|
||||||
|
e = MAKE_CHAR (VALUE (e));
|
||||||
|
if (TYPE (e) == TNUMBER)
|
||||||
|
e = MAKE_NUMBER (VALUE (e));
|
||||||
|
return e;
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
struct_set_x_ (SCM x, long i, SCM e)
|
||||||
|
{
|
||||||
|
assert (TYPE (x) == TSTRUCT);
|
||||||
|
assert (VALUE (i) < LENGTH (x));
|
||||||
|
g_cells[STRUCT (x)+i] = g_cells[vector_entry (e)];
|
||||||
|
return cell_unspecified;
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
struct_ref (SCM x, SCM i)
|
||||||
|
{
|
||||||
|
return struct_ref_ (x, VALUE (i));
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
struct_set_x (SCM x, SCM i, SCM e)
|
||||||
|
{
|
||||||
|
return struct_set_x_ (x, VALUE (i), e);
|
||||||
|
}
|
24
src/vector.c
24
src/vector.c
|
@ -42,11 +42,11 @@ vector_length (SCM x)
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM
|
SCM
|
||||||
vector_ref (SCM x, SCM i)
|
vector_ref_ (SCM x, long i)
|
||||||
{
|
{
|
||||||
assert (TYPE (x) == TVECTOR);
|
assert (TYPE (x) == TVECTOR);
|
||||||
assert (VALUE (i) < LENGTH (x));
|
assert (i < LENGTH (x));
|
||||||
SCM e = VECTOR (x) + VALUE (i);
|
SCM e = VECTOR (x) + i;
|
||||||
if (TYPE (e) == TREF)
|
if (TYPE (e) == TREF)
|
||||||
e = REF (e);
|
e = REF (e);
|
||||||
if (TYPE (e) == TCHAR)
|
if (TYPE (e) == TCHAR)
|
||||||
|
@ -56,6 +56,12 @@ vector_ref (SCM x, SCM i)
|
||||||
return e;
|
return e;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
vector_ref (SCM x, SCM i)
|
||||||
|
{
|
||||||
|
return vector_ref_ (x, VALUE (i));
|
||||||
|
}
|
||||||
|
|
||||||
SCM
|
SCM
|
||||||
vector_entry (SCM x)
|
vector_entry (SCM x)
|
||||||
{
|
{
|
||||||
|
@ -65,14 +71,20 @@ vector_entry (SCM x)
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM
|
SCM
|
||||||
vector_set_x (SCM x, SCM i, SCM e)
|
vector_set_x_ (SCM x, long i, SCM e)
|
||||||
{
|
{
|
||||||
assert (TYPE (x) == TVECTOR);
|
assert (TYPE (x) == TVECTOR);
|
||||||
assert (VALUE (i) < LENGTH (x));
|
assert (i < LENGTH (x));
|
||||||
g_cells[VECTOR (x)+VALUE (i)] = g_cells[vector_entry (e)];
|
g_cells[VECTOR (x)+i] = g_cells[vector_entry (e)];
|
||||||
return cell_unspecified;
|
return cell_unspecified;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
SCM
|
||||||
|
vector_set_x (SCM x, SCM i, SCM e)
|
||||||
|
{
|
||||||
|
return vector_set_x_ (x, VALUE (i), e);
|
||||||
|
}
|
||||||
|
|
||||||
SCM
|
SCM
|
||||||
list_to_vector (SCM x)
|
list_to_vector (SCM x)
|
||||||
{
|
{
|
||||||
|
|
|
@ -54,18 +54,17 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
|
||||||
(lambda (key . args)
|
(lambda (key . args)
|
||||||
789)))
|
789)))
|
||||||
|
|
||||||
(if mes?
|
(pass-if-equal "catch feel"
|
||||||
(pass-if-equal "catch feel"
|
1
|
||||||
1
|
(catch 'twenty-two
|
||||||
(let ((save-exit exit))
|
(lambda _
|
||||||
(set! exit (lambda (x)
|
(catch 'boo
|
||||||
(set! exit save-exit)
|
(lambda ()
|
||||||
1))
|
(throw-22)
|
||||||
(catch 'boo
|
11)
|
||||||
(lambda ()
|
(lambda (key . args)
|
||||||
(throw-22)
|
(exit 1))))
|
||||||
11)
|
(lambda (key . args)
|
||||||
(lambda (key . args)
|
1)))
|
||||||
22)))))
|
|
||||||
|
|
||||||
(result 'report)
|
(result 'report)
|
||||||
|
|
|
@ -51,14 +51,14 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
|
||||||
;; 0 (with-fluids* (list a b) '(0 1)
|
;; 0 (with-fluids* (list a b) '(0 1)
|
||||||
;; (lambda () (fluid-ref a))))
|
;; (lambda () (fluid-ref a))))
|
||||||
|
|
||||||
(pass-if-equal "with-fluids"
|
(pass-if-eq "with-fluids"
|
||||||
0 (with-fluids ((a 1)
|
0 (with-fluids ((a 1)
|
||||||
(a 2)
|
(a 2)
|
||||||
(a 3))
|
(a 3))
|
||||||
(fluid-set! a 0)
|
(fluid-set! a 0)
|
||||||
(fluid-ref a)))
|
(fluid-ref a)))
|
||||||
|
|
||||||
(pass-if-equal "with-fluids" ; FIXME: fails with Mes
|
(pass-if-eq "with-fluids"
|
||||||
#f (begin
|
#f (begin
|
||||||
(with-fluids ((a 1)
|
(with-fluids ((a 1)
|
||||||
(b 2))
|
(b 2))
|
||||||
|
@ -66,4 +66,4 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
|
||||||
(display "X:") (display (fluid-ref a)) (newline))
|
(display "X:") (display (fluid-ref a)) (newline))
|
||||||
(fluid-ref a)))
|
(fluid-ref a)))
|
||||||
|
|
||||||
(result 'report (if mes? 1 0))
|
(result 'report)
|
||||||
|
|
|
@ -26,11 +26,13 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
|
||||||
(define-module (tests guile)
|
(define-module (tests guile)
|
||||||
#:use-module (ice-9 rdelim)
|
#:use-module (ice-9 rdelim)
|
||||||
#:use-module (mes mes-0)
|
#:use-module (mes mes-0)
|
||||||
|
#:use-module (mes misc)
|
||||||
#:use-module (mes test))
|
#:use-module (mes test))
|
||||||
|
|
||||||
(cond-expand
|
(cond-expand
|
||||||
(mes
|
(mes
|
||||||
(mes-use-module (mes test))
|
(mes-use-module (mes test))
|
||||||
|
(mes-use-module (mes misc))
|
||||||
(mes-use-module (mes guile)))
|
(mes-use-module (mes guile)))
|
||||||
(else))
|
(else))
|
||||||
|
|
||||||
|
@ -71,14 +73,6 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
|
||||||
(set-current-input-port (car ipstk))
|
(set-current-input-port (car ipstk))
|
||||||
(fluid-set! *input-stack* (cdr ipstk))))))
|
(fluid-set! *input-stack* (cdr ipstk))))))
|
||||||
|
|
||||||
;; Return #f if empty
|
|
||||||
(define (pop-input)
|
|
||||||
(let ((ipstk (fluid-ref *input-stack*)))
|
|
||||||
(if (null? ipstk) #f
|
|
||||||
(begin
|
|
||||||
(set-current-input-port (car ipstk))
|
|
||||||
(fluid-set! *input-stack* (cdr ipstk))))))
|
|
||||||
|
|
||||||
(pass-if-equal "push-input"
|
(pass-if-equal "push-input"
|
||||||
"bla"
|
"bla"
|
||||||
(let ()
|
(let ()
|
||||||
|
@ -102,8 +96,7 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
|
||||||
(unless (eof-object? ch) (write-char ch) (iter (read-char))))
|
(unless (eof-object? ch) (write-char ch) (iter (read-char))))
|
||||||
(pop-input)
|
(pop-input)
|
||||||
(let iter ((ch (read-char)))
|
(let iter ((ch (read-char)))
|
||||||
(unless (eof-object? ch) (write-char ch) (iter (read-char))))
|
(unless (eof-object? ch) (write-char ch) (iter (read-char)))))))))
|
||||||
)))))
|
|
||||||
|
|
||||||
(pass-if "input-stack/2"
|
(pass-if "input-stack/2"
|
||||||
(let ((sp (open-input-string "abc")))
|
(let ((sp (open-input-string "abc")))
|
||||||
|
|
|
@ -0,0 +1,119 @@
|
||||||
|
#! /bin/sh
|
||||||
|
# -*-scheme-*-
|
||||||
|
if [ "$MES" != guile ]; then
|
||||||
|
export MES_BOOT=boot-02.scm
|
||||||
|
MES=${MES-$(dirname $0)/../src/mes}
|
||||||
|
$MES < $0
|
||||||
|
exit $?
|
||||||
|
else
|
||||||
|
exit 0
|
||||||
|
fi
|
||||||
|
exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests macro)' -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 boot)
|
||||||
|
#:use-module (mes mes-0)
|
||||||
|
#: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)
|
||||||
|
|
||||||
|
(define gensym
|
||||||
|
((lambda (symbols)
|
||||||
|
(lambda (. rest)
|
||||||
|
((lambda (head tail)
|
||||||
|
(set! symbols tail)
|
||||||
|
head)
|
||||||
|
(car symbols)
|
||||||
|
(cdr symbols))))
|
||||||
|
'(g0 g1 g2 g3 g4)))
|
||||||
|
|
||||||
|
;; type-0.mes
|
||||||
|
(define (string . lst)
|
||||||
|
(core:make-cell <cell:string> lst 0))
|
||||||
|
|
||||||
|
(define (string->symbol s)
|
||||||
|
(if (not (pair? (core:car s))) '()
|
||||||
|
(list->symbol (core:car s))))
|
||||||
|
|
||||||
|
(define (symbol->list s)
|
||||||
|
(core:car s))
|
||||||
|
|
||||||
|
;; boot-0.scm
|
||||||
|
(define (symbol->string s)
|
||||||
|
(apply string (symbol->list s)))
|
||||||
|
|
||||||
|
(define (string-append . rest)
|
||||||
|
(apply string (apply append (map1 string->list rest))))
|
||||||
|
|
||||||
|
;; scm.mes
|
||||||
|
(define (symbol-append . rest)
|
||||||
|
(string->symbol (apply string-append (map symbol->string rest))))
|
||||||
|
|
||||||
|
(define-macro (make-fluid . default)
|
||||||
|
((lambda (fluid)
|
||||||
|
(list
|
||||||
|
'begin
|
||||||
|
(list
|
||||||
|
'module-define!
|
||||||
|
(list 'boot-module)
|
||||||
|
(list 'quote fluid)
|
||||||
|
(list
|
||||||
|
(lambda (v)
|
||||||
|
(lambda ( . rest)
|
||||||
|
(if (null? rest) v
|
||||||
|
(set! v (car rest)))))
|
||||||
|
(and (pair? default) (car default))))
|
||||||
|
(list 'quote fluid)))
|
||||||
|
(symbol-append 'fluid: (gensym))))
|
||||||
|
|
||||||
|
(define fluid (make-fluid 42))
|
||||||
|
|
||||||
|
(pass-if-eq "fluid" 42 (fluid))
|
||||||
|
|
||||||
|
(fluid 0)
|
||||||
|
(pass-if-eq "fluid 0" 0 (fluid))
|
||||||
|
|
||||||
|
(fluid '())
|
||||||
|
(pass-if-eq "fluid null" '() (fluid))
|
||||||
|
|
||||||
|
(define (fluid-ref fluid)
|
||||||
|
(fluid))
|
||||||
|
|
||||||
|
(define (fluid-set! fluid value)
|
||||||
|
(fluid value))
|
||||||
|
|
||||||
|
(fluid-set! fluid 0)
|
||||||
|
(pass-if-eq "fluid 0" 0 (fluid-ref fluid))
|
||||||
|
|
||||||
|
(fluid-set! fluid '())
|
||||||
|
(pass-if-eq "fluid null" '() (fluid-ref fluid))
|
||||||
|
|
||||||
|
(result 'report)
|
|
@ -0,0 +1,58 @@
|
||||||
|
#! /bin/sh
|
||||||
|
# -*-scheme-*-
|
||||||
|
if [ "$MES" != guile ]; then
|
||||||
|
export MES_BOOT=boot-02.scm
|
||||||
|
MES=${MES-$(dirname $0)/../src/mes}
|
||||||
|
$MES < $0
|
||||||
|
exit $?
|
||||||
|
fi
|
||||||
|
exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests perform)' -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 boot)
|
||||||
|
#:use-module (mes mes-0)
|
||||||
|
#:use-module (mes test))
|
||||||
|
|
||||||
|
(cond-expand
|
||||||
|
(mes
|
||||||
|
(define (round x) x)
|
||||||
|
(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)
|
||||||
|
|
||||||
|
(pass-if-timeout "loop 1M"
|
||||||
|
100
|
||||||
|
((lambda (loop)
|
||||||
|
(set! loop
|
||||||
|
(lambda (i)
|
||||||
|
(if (> i 0)
|
||||||
|
(loop (- i 1)))))
|
||||||
|
(loop 100000))
|
||||||
|
*unspecified*))
|
||||||
|
|
||||||
|
(result 'report (if mes? 1 0)) ; at least until we have bogomips,
|
||||||
|
; allow mes to fail
|
|
@ -0,0 +1,48 @@
|
||||||
|
#! /bin/sh
|
||||||
|
# -*-scheme-*-
|
||||||
|
if [ "$MES" != guile ]; then
|
||||||
|
export MES_BOOT=boot-02.scm
|
||||||
|
MES=${MES-$(dirname $0)/../src/mes}
|
||||||
|
$MES < $0
|
||||||
|
exit $?
|
||||||
|
fi
|
||||||
|
exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@"
|
||||||
|
!#
|
||||||
|
|
||||||
|
;;; -*-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-0)
|
||||||
|
#:use-module (mes mes-0)
|
||||||
|
#:use-module (mes test))
|
||||||
|
|
||||||
|
(display "srfi-0...\n")
|
||||||
|
|
||||||
|
(cond-expand
|
||||||
|
(mes
|
||||||
|
(display "mes\n")
|
||||||
|
(exit 0))
|
||||||
|
(guile
|
||||||
|
(display "guile\n")
|
||||||
|
(exit guile?))
|
||||||
|
(else
|
||||||
|
(exit 1)))
|
||||||
|
|
||||||
|
(exit 1)
|
Loading…
Reference in New Issue