mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-04-27 16:51:06 -07:00
Merging improvements from version 1.110 branch.
Copied from Perforce Change: 179643 ServerID: perforce.ravenbrook.com
This commit is contained in:
Richard Brooksby
commit
885154e8ed
9 changed files with 188 additions and 100 deletions
|
|
@ -3143,6 +3143,7 @@
|
|||
"-Wno-extended-offsetof",
|
||||
);
|
||||
SDKROOT = macosx;
|
||||
SYMROOT = xc;
|
||||
WARNING_CFLAGS = (
|
||||
"-pedantic",
|
||||
"-Wpointer-arith",
|
||||
|
|
@ -3508,6 +3509,7 @@
|
|||
"-Wno-extended-offsetof",
|
||||
);
|
||||
SDKROOT = macosx;
|
||||
SYMROOT = xc;
|
||||
WARNING_CFLAGS = (
|
||||
"-pedantic",
|
||||
"-Wpointer-arith",
|
||||
|
|
@ -3560,6 +3562,7 @@
|
|||
"-Wno-extended-offsetof",
|
||||
);
|
||||
SDKROOT = macosx;
|
||||
SYMROOT = xc;
|
||||
WARNING_CFLAGS = (
|
||||
"-pedantic",
|
||||
"-Wpointer-arith",
|
||||
|
|
|
|||
|
|
@ -252,7 +252,7 @@
|
|||
|
||||
|
||||
#else
|
||||
#error "Unable to detect target platform"
|
||||
#error "The MPS Kit does not have a configuration for this platform out of the box; see manual/build.txt"
|
||||
#endif
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -943,6 +943,16 @@ static Res amcInitComm(Pool pool, RankSet rankSet, va_list arg)
|
|||
Index i;
|
||||
size_t genArraySize;
|
||||
size_t genCount;
|
||||
|
||||
/* Suppress a warning about this structure not being used when there
|
||||
are no statistics. Note that simply making the declaration conditional
|
||||
does not work, because we carefully reference expressions inside
|
||||
STATISTICS to prevent such warnings on parameters and local variables.
|
||||
It's just that clang 4.0 on Mac OS X does some sort of extra check
|
||||
that produces a special warnings about static variables. */
|
||||
#if !defined(STATISTICS)
|
||||
UNUSED(pageretstruct_Zero);
|
||||
#endif
|
||||
|
||||
AVER(pool != NULL);
|
||||
|
||||
|
|
|
|||
27
mps/configure
vendored
27
mps/configure
vendored
|
|
@ -2569,6 +2569,12 @@ ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
|
|||
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
|
||||
ac_compiler_gnu=$ac_cv_c_compiler_gnu
|
||||
|
||||
ac_ext=c
|
||||
ac_cpp='$CPP $CPPFLAGS'
|
||||
ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
|
||||
ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
|
||||
ac_compiler_gnu=$ac_cv_c_compiler_gnu
|
||||
|
||||
# Find a good install program. We prefer a C program (faster),
|
||||
# so one script is as good as another. But avoid the broken or
|
||||
# incompatible versions:
|
||||
|
|
@ -2663,6 +2669,15 @@ test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}'
|
|||
test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644'
|
||||
|
||||
|
||||
AX_CFLAGS_WARN_ALL
|
||||
|
||||
# These flags aren't used for building the MPS, but for sample programs.
|
||||
CFLAGS_GC="-ansi -pedantic -Wall -Werror -Wpointer-arith \
|
||||
-Wstrict-prototypes -Wmissing-prototypes \
|
||||
-Winline -Waggregate-return -Wnested-externs \
|
||||
-Wcast-qual -Wshadow -Wstrict-aliasing=2 -O -g3"
|
||||
CFLAGS_LL="$CFLAGS_GC -Wno-extended-offsetof"
|
||||
|
||||
# Make sure we can run config.sub.
|
||||
$SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 ||
|
||||
as_fn_error $? "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5
|
||||
|
|
@ -2744,11 +2759,13 @@ case $host in
|
|||
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: Linux x86" >&5
|
||||
$as_echo "Linux x86" >&6; }
|
||||
MPS_TARGET_NAME=lii3gc
|
||||
CFLAGS="$CFLAGS_GC"
|
||||
;;
|
||||
x86_64-*-linux*)
|
||||
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: Linux x86_64" >&5
|
||||
$as_echo "Linux x86_64" >&6; }
|
||||
MPS_TARGET_NAME=lii6gc
|
||||
CFLAGS="$CFLAGS_GC"
|
||||
;;
|
||||
i*86-*-darwin*)
|
||||
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: Mac OS X x86" >&5
|
||||
|
|
@ -2757,6 +2774,7 @@ $as_echo "Mac OS X x86" >&6; }
|
|||
BUILD_TARGET=build-via-xcode
|
||||
CLEAN_TARGET=clean-xcode-build
|
||||
INSTALL_TARGET=install-xcode-build
|
||||
CFLAGS="$CFLAGS_LL"
|
||||
;;
|
||||
x86_64-apple-darwin*)
|
||||
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: Mac OS X x86_64" >&5
|
||||
|
|
@ -2765,16 +2783,19 @@ $as_echo "Mac OS X x86_64" >&6; }
|
|||
BUILD_TARGET=build-via-xcode
|
||||
CLEAN_TARGET=clean-xcode-build
|
||||
INSTALL_TARGET=install-xcode-build
|
||||
CFLAGS="$CFLAGS_LL"
|
||||
;;
|
||||
i*86-*-freebsd*)
|
||||
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: FreeBSD x86" >&5
|
||||
$as_echo "FreeBSD x86" >&6; }
|
||||
MPS_TARGET_NAME=fri3gc
|
||||
CFLAGS="$CFLAGS_GC"
|
||||
;;
|
||||
amd64-*-freebsd*)
|
||||
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: FreeBSD x86_64" >&5
|
||||
$as_echo "FreeBSD x86_64" >&6; }
|
||||
MPS_TARGET_NAME=fri6gc
|
||||
CFLAGS="$CFLAGS_GC"
|
||||
;;
|
||||
*)
|
||||
as_fn_error $? "MPS does not support this platform out of the box. See manual/build.txt" "$LINENO" 5
|
||||
|
|
@ -2831,7 +2852,8 @@ fi
|
|||
|
||||
|
||||
|
||||
ac_config_files="$ac_config_files Makefile"
|
||||
|
||||
ac_config_files="$ac_config_files Makefile example/scheme/Makefile"
|
||||
|
||||
|
||||
cat >confcache <<\_ACEOF
|
||||
|
|
@ -3542,6 +3564,7 @@ for ac_config_target in $ac_config_targets
|
|||
do
|
||||
case $ac_config_target in
|
||||
"Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
|
||||
"example/scheme/Makefile") CONFIG_FILES="$CONFIG_FILES example/scheme/Makefile" ;;
|
||||
|
||||
*) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;
|
||||
esac
|
||||
|
|
@ -3996,3 +4019,5 @@ if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then
|
|||
$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;}
|
||||
fi
|
||||
|
||||
|
||||
echo 1>&2 "CONFIGURE/MAKE IS NOT THE BEST WAY TO BUILD THE MPS -- see <manual/build.txt>"
|
||||
|
|
|
|||
|
|
@ -25,8 +25,18 @@ AC_CONFIG_SRCDIR([code/mps.c])
|
|||
|
||||
# Checks for programs.
|
||||
AC_PROG_CC
|
||||
AC_LANG_C
|
||||
AC_PROG_INSTALL
|
||||
|
||||
AX_CFLAGS_WARN_ALL
|
||||
|
||||
# These flags aren't used for building the MPS, but for sample programs.
|
||||
CFLAGS_GC="-ansi -pedantic -Wall -Werror -Wpointer-arith \
|
||||
-Wstrict-prototypes -Wmissing-prototypes \
|
||||
-Winline -Waggregate-return -Wnested-externs \
|
||||
-Wcast-qual -Wshadow -Wstrict-aliasing=2 -O -g3"
|
||||
CFLAGS_LL="$CFLAGS_GC -Wno-extended-offsetof"
|
||||
|
||||
AC_CANONICAL_HOST
|
||||
AC_MSG_CHECKING([target platform])
|
||||
BUILD_TARGET=build-via-make
|
||||
|
|
@ -36,10 +46,12 @@ case $host in
|
|||
i*86-*-linux*)
|
||||
AC_MSG_RESULT([Linux x86])
|
||||
MPS_TARGET_NAME=lii3gc
|
||||
CFLAGS="$CFLAGS_GC"
|
||||
;;
|
||||
x86_64-*-linux*)
|
||||
AC_MSG_RESULT([Linux x86_64])
|
||||
MPS_TARGET_NAME=lii6gc
|
||||
CFLAGS="$CFLAGS_GC"
|
||||
;;
|
||||
i*86-*-darwin*)
|
||||
AC_MSG_RESULT([Mac OS X x86])
|
||||
|
|
@ -47,6 +59,7 @@ case $host in
|
|||
BUILD_TARGET=build-via-xcode
|
||||
CLEAN_TARGET=clean-xcode-build
|
||||
INSTALL_TARGET=install-xcode-build
|
||||
CFLAGS="$CFLAGS_LL"
|
||||
;;
|
||||
x86_64-apple-darwin*)
|
||||
AC_MSG_RESULT([Mac OS X x86_64])
|
||||
|
|
@ -54,14 +67,17 @@ case $host in
|
|||
BUILD_TARGET=build-via-xcode
|
||||
CLEAN_TARGET=clean-xcode-build
|
||||
INSTALL_TARGET=install-xcode-build
|
||||
CFLAGS="$CFLAGS_LL"
|
||||
;;
|
||||
i*86-*-freebsd*)
|
||||
AC_MSG_RESULT([FreeBSD x86])
|
||||
MPS_TARGET_NAME=fri3gc
|
||||
CFLAGS="$CFLAGS_GC"
|
||||
;;
|
||||
amd64-*-freebsd*)
|
||||
AC_MSG_RESULT([FreeBSD x86_64])
|
||||
MPS_TARGET_NAME=fri6gc
|
||||
CFLAGS="$CFLAGS_GC"
|
||||
;;
|
||||
*)
|
||||
AC_MSG_ERROR([MPS does not support this platform out of the box. See manual/build.txt])
|
||||
|
|
@ -76,6 +92,9 @@ AC_SUBST(MPS_TARGET_NAME)
|
|||
AC_SUBST(BUILD_TARGET)
|
||||
AC_SUBST(CLEAN_TARGET)
|
||||
AC_SUBST(INSTALL_TARGET)
|
||||
AC_CONFIG_FILES(Makefile)
|
||||
AC_SUBST(CFLAGS)
|
||||
AC_CONFIG_FILES(Makefile example/scheme/Makefile)
|
||||
|
||||
AC_OUTPUT
|
||||
|
||||
echo 1>&2 "CONFIGURE/MAKE IS NOT THE BEST WAY TO BUILD THE MPS -- see <manual/build.txt>"
|
||||
|
|
|
|||
|
|
@ -1,6 +0,0 @@
|
|||
# example/scheme/Makefile -- Makefile for the MPS Scheme example
|
||||
#
|
||||
# $Id$
|
||||
|
||||
scheme: scheme.c
|
||||
$(CC) -g3 -ansi -pedantic -Wall -Wno-extended-offsetof -o scheme -I ../../code scheme.c ../../code/mps.c
|
||||
8
mps/example/scheme/Makefile.in
Normal file
8
mps/example/scheme/Makefile.in
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
# example/scheme/Makefile -- Makefile for the MPS Scheme example
|
||||
#
|
||||
# $Id$
|
||||
|
||||
CFLAGS = @CFLAGS@
|
||||
|
||||
scheme: scheme.c
|
||||
$(CC) $(CFLAGS) -o scheme -I ../../code scheme.c ../../code/mps.c
|
||||
|
|
@ -41,7 +41,6 @@
|
|||
* - Quasiquote implementation is messy.
|
||||
* - Lots of library.
|
||||
* - \#foo unsatisfactory in read and print
|
||||
* - tail recursion (pass current function to eval)
|
||||
*/
|
||||
|
||||
#include <stdio.h>
|
||||
|
|
@ -284,6 +283,7 @@ static obj_t obj_error; /* error indicator */
|
|||
static obj_t obj_true; /* #t, boolean true */
|
||||
static obj_t obj_false; /* #f, boolean false */
|
||||
static obj_t obj_undefined; /* undefined result indicator */
|
||||
static obj_t obj_tail; /* tail recursion indicator */
|
||||
|
||||
|
||||
/* predefined symbols
|
||||
|
|
@ -1110,40 +1110,53 @@ static obj_t eval(obj_t env, obj_t op_env, obj_t exp);
|
|||
|
||||
static obj_t eval(obj_t env, obj_t op_env, obj_t exp)
|
||||
{
|
||||
/* self-evaluating */
|
||||
if(TYPE(exp) == TYPE_INTEGER ||
|
||||
(TYPE(exp) == TYPE_SPECIAL && exp != obj_empty) ||
|
||||
TYPE(exp) == TYPE_STRING ||
|
||||
TYPE(exp) == TYPE_CHARACTER)
|
||||
return exp;
|
||||
|
||||
/* symbol lookup */
|
||||
if(TYPE(exp) == TYPE_SYMBOL) {
|
||||
obj_t binding = lookup(env, exp);
|
||||
if(binding == obj_undefined)
|
||||
error("eval: unbound symbol \"%s\"", exp->symbol.string);
|
||||
return CDR(binding);
|
||||
}
|
||||
|
||||
/* apply operator or function */
|
||||
if(TYPE(exp) == TYPE_PAIR) {
|
||||
for(;;) {
|
||||
obj_t operator;
|
||||
obj_t result;
|
||||
|
||||
/* self-evaluating */
|
||||
if(TYPE(exp) == TYPE_INTEGER ||
|
||||
(TYPE(exp) == TYPE_SPECIAL && exp != obj_empty) ||
|
||||
TYPE(exp) == TYPE_STRING ||
|
||||
TYPE(exp) == TYPE_CHARACTER)
|
||||
return exp;
|
||||
|
||||
/* symbol lookup */
|
||||
if(TYPE(exp) == TYPE_SYMBOL) {
|
||||
obj_t binding = lookup(env, exp);
|
||||
if(binding == obj_undefined)
|
||||
error("eval: unbound symbol \"%s\"", exp->symbol.string);
|
||||
return CDR(binding);
|
||||
}
|
||||
|
||||
if(TYPE(exp) != TYPE_PAIR) {
|
||||
error("eval: unknown syntax");
|
||||
return obj_error;
|
||||
}
|
||||
|
||||
/* apply operator or function */
|
||||
if(TYPE(CAR(exp)) == TYPE_SYMBOL) {
|
||||
obj_t binding = lookup(op_env, CAR(exp));
|
||||
if(binding != obj_undefined) {
|
||||
operator = CDR(binding);
|
||||
assert(TYPE(operator) == TYPE_OPERATOR);
|
||||
return (*operator->operator.entry)(env, op_env, operator, CDR(exp));
|
||||
result = (*operator->operator.entry)(env, op_env, operator, CDR(exp));
|
||||
goto found;
|
||||
}
|
||||
}
|
||||
operator = eval(env, op_env, CAR(exp));
|
||||
unless(TYPE(operator) == TYPE_OPERATOR)
|
||||
error("eval: application of non-function");
|
||||
return (*operator->operator.entry)(env, op_env, operator, CDR(exp));
|
||||
result = (*operator->operator.entry)(env, op_env, operator, CDR(exp));
|
||||
|
||||
found:
|
||||
if (!(TYPE(result) == TYPE_PAIR && CAR(result) == obj_tail))
|
||||
return result;
|
||||
|
||||
env = CADR(result);
|
||||
op_env = CADDR(result);
|
||||
exp = CAR(CDDDR(result));
|
||||
}
|
||||
|
||||
error("eval: unknown syntax");
|
||||
return obj_error;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1241,6 +1254,42 @@ static void eval_args_rest(char *name, obj_t env, obj_t op_env,
|
|||
}
|
||||
|
||||
|
||||
/* eval_tail -- return an object that will cause eval to loop
|
||||
*
|
||||
* Rather than calling `eval` an operator can return a special object that
|
||||
* causes a calling `eval` to loop, avoiding using up a C stack frame.
|
||||
* This implements tail recursion (in a simple way).
|
||||
*/
|
||||
|
||||
static obj_t eval_tail(obj_t env, obj_t op_env, obj_t exp)
|
||||
{
|
||||
return make_pair(obj_tail,
|
||||
make_pair(env,
|
||||
make_pair(op_env,
|
||||
make_pair(exp,
|
||||
obj_empty))));
|
||||
}
|
||||
|
||||
|
||||
/* eval_body -- evaluate a list of expressions, returning last result
|
||||
*
|
||||
* This is used for the bodies of forms such as let, begin, etc. where
|
||||
* a list of expressions is allowed.
|
||||
*/
|
||||
|
||||
static obj_t eval_body(obj_t env, obj_t op_env, obj_t operator, obj_t body)
|
||||
{
|
||||
for (;;) {
|
||||
if (TYPE(body) != TYPE_PAIR)
|
||||
error("%s: illegal expression list", operator->operator.name);
|
||||
if (CDR(body) == obj_empty)
|
||||
return eval_tail(env, op_env, CAR(body));
|
||||
(void)eval(env, op_env, CAR(body));
|
||||
body = CDR(body);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/* BUILT-IN OPERATORS */
|
||||
|
||||
|
||||
|
|
@ -1287,7 +1336,7 @@ static obj_t entry_interpret(obj_t env, obj_t op_env, obj_t operator, obj_t oper
|
|||
if(arguments != obj_empty)
|
||||
error("eval: function applied to too few arguments");
|
||||
|
||||
return eval(fun_env, fun_op_env, operator->operator.body);
|
||||
return eval_tail(fun_env, fun_op_env, operator->operator.body);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1356,9 +1405,9 @@ static obj_t entry_if(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
|
|||
test = eval(env, op_env, CAR(operands));
|
||||
/* Anything which is not #f counts as true [R4RS 6.1]. */
|
||||
if(test != obj_false)
|
||||
return eval(env, op_env, CADR(operands));
|
||||
return eval_tail(env, op_env, CADR(operands));
|
||||
if(TYPE(CDDR(operands)) == TYPE_PAIR)
|
||||
return eval(env, op_env, CADDR(operands));
|
||||
return eval_tail(env, op_env, CADDR(operands));
|
||||
return obj_undefined;
|
||||
}
|
||||
|
||||
|
|
@ -1385,14 +1434,9 @@ static obj_t entry_cond(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
|
|||
} else
|
||||
result = eval(env, op_env, CAR(clause));
|
||||
if(result != obj_false) {
|
||||
for(;;) {
|
||||
clause = CDR(clause);
|
||||
if(TYPE(clause) != TYPE_PAIR) break;
|
||||
result = eval(env, op_env, CAR(clause));
|
||||
}
|
||||
if(clause != obj_empty)
|
||||
error("%s: illegal clause syntax", operator->operator.name);
|
||||
return result;
|
||||
if (CDR(clause) == obj_empty)
|
||||
return result;
|
||||
return eval_body(env, op_env, operator, CDR(clause));
|
||||
}
|
||||
operands = CDR(operands);
|
||||
}
|
||||
|
|
@ -1404,15 +1448,18 @@ static obj_t entry_cond(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
|
|||
|
||||
static obj_t entry_and(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
|
||||
{
|
||||
while(TYPE(operands) == TYPE_PAIR) {
|
||||
obj_t test = eval(env, op_env, CAR(operands));
|
||||
if(test == obj_false)
|
||||
return obj_false;
|
||||
obj_t test;
|
||||
if (operands == obj_empty)
|
||||
return obj_true;
|
||||
do {
|
||||
if (TYPE(operands) != TYPE_PAIR)
|
||||
error("%s: illegal syntax", operator->operator.name);
|
||||
if (CDR(operands) == obj_empty)
|
||||
return eval_tail(env, op_env, CAR(operands));
|
||||
test = eval(env, op_env, CAR(operands));
|
||||
operands = CDR(operands);
|
||||
}
|
||||
if(operands != obj_empty)
|
||||
error("%s: illegal syntax", operator->operator.name);
|
||||
return obj_true;
|
||||
} while (test != obj_false);
|
||||
return test;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1420,15 +1467,18 @@ static obj_t entry_and(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
|
|||
|
||||
static obj_t entry_or(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
|
||||
{
|
||||
while(TYPE(operands) == TYPE_PAIR) {
|
||||
obj_t test = eval(env, op_env, CAR(operands));
|
||||
if(test != obj_false)
|
||||
return obj_true;
|
||||
obj_t test;
|
||||
if (operands == obj_empty)
|
||||
return obj_false;
|
||||
do {
|
||||
if (TYPE(operands) != TYPE_PAIR)
|
||||
error("%s: illegal syntax", operator->operator.name);
|
||||
if (CDR(operands) == obj_empty)
|
||||
return eval_tail(env, op_env, CAR(operands));
|
||||
test = eval(env, op_env, CAR(operands));
|
||||
operands = CDR(operands);
|
||||
}
|
||||
if(operands != obj_empty)
|
||||
error("%s: illegal syntax", operator->operator.name);
|
||||
return obj_false;
|
||||
} while (test == obj_false);
|
||||
return test;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1437,7 +1487,7 @@ static obj_t entry_or(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
|
|||
|
||||
static obj_t entry_let(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
|
||||
{
|
||||
obj_t inner_env, bindings, result;
|
||||
obj_t inner_env, bindings;
|
||||
unless(TYPE(operands) == TYPE_PAIR &&
|
||||
TYPE(CDR(operands)) == TYPE_PAIR)
|
||||
error("%s: illegal syntax", operator->operator.name);
|
||||
|
|
@ -1455,14 +1505,7 @@ static obj_t entry_let(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
|
|||
}
|
||||
if(bindings != obj_empty)
|
||||
error("%s: illegal bindings list", operator->operator.name);
|
||||
operands = CDR(operands);
|
||||
while(TYPE(operands) == TYPE_PAIR) {
|
||||
result = eval(inner_env, op_env, CAR(operands));
|
||||
operands = CDR(operands);
|
||||
}
|
||||
if(operands != obj_empty)
|
||||
error("%s: illegal expression list", operator->operator.name);
|
||||
return result;
|
||||
return eval_body(inner_env, op_env, operator, CDR(operands));
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1471,7 +1514,7 @@ static obj_t entry_let(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
|
|||
|
||||
static obj_t entry_let_star(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
|
||||
{
|
||||
obj_t inner_env, bindings, result;
|
||||
obj_t inner_env, bindings;
|
||||
unless(TYPE(operands) == TYPE_PAIR &&
|
||||
TYPE(CDR(operands)) == TYPE_PAIR)
|
||||
error("%s: illegal syntax", operator->operator.name);
|
||||
|
|
@ -1489,14 +1532,7 @@ static obj_t entry_let_star(obj_t env, obj_t op_env, obj_t operator, obj_t opera
|
|||
}
|
||||
if(bindings != obj_empty)
|
||||
error("%s: illegal bindings list", operator->operator.name);
|
||||
operands = CDR(operands);
|
||||
while(TYPE(operands) == TYPE_PAIR) {
|
||||
result = eval(inner_env, op_env, CAR(operands));
|
||||
operands = CDR(operands);
|
||||
}
|
||||
if(operands != obj_empty)
|
||||
error("%s: illegal expression list", operator->operator.name);
|
||||
return result;
|
||||
return eval_body(inner_env, op_env, operator, CDR(operands));
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1505,7 +1541,7 @@ static obj_t entry_let_star(obj_t env, obj_t op_env, obj_t operator, obj_t opera
|
|||
|
||||
static obj_t entry_letrec(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
|
||||
{
|
||||
obj_t inner_env, bindings, result;
|
||||
obj_t inner_env, bindings;
|
||||
unless(TYPE(operands) == TYPE_PAIR &&
|
||||
TYPE(CDR(operands)) == TYPE_PAIR)
|
||||
error("%s: illegal syntax", operator->operator.name);
|
||||
|
|
@ -1529,14 +1565,7 @@ static obj_t entry_letrec(obj_t env, obj_t op_env, obj_t operator, obj_t operand
|
|||
define(inner_env, CAR(binding), eval(inner_env, op_env, CADR(binding)));
|
||||
bindings = CDR(bindings);
|
||||
}
|
||||
operands = CDR(operands);
|
||||
while(TYPE(operands) == TYPE_PAIR) {
|
||||
result = eval(inner_env, op_env, CAR(operands));
|
||||
operands = CDR(operands);
|
||||
}
|
||||
if(operands != obj_empty)
|
||||
error("%s: illegal expression list", operator->operator.name);
|
||||
return result;
|
||||
return eval_body(inner_env, op_env, operator, CDR(operands));
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -1699,14 +1728,7 @@ static obj_t entry_lambda(obj_t env, obj_t op_env, obj_t operator, obj_t operand
|
|||
|
||||
static obj_t entry_begin(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
|
||||
{
|
||||
obj_t result;
|
||||
do {
|
||||
unless(TYPE(operands) == TYPE_PAIR)
|
||||
error("%s: illegal syntax", operator->operator.name);
|
||||
result = eval(env, op_env, CAR(operands));
|
||||
operands = CDR(operands);
|
||||
} while(operands != obj_empty);
|
||||
return result;
|
||||
return eval_body(env, op_env, operator, operands);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -2335,7 +2357,8 @@ static struct {char *name; obj_t *varp;} sptab[] = {
|
|||
{"#[error]", &obj_error},
|
||||
{"#t", &obj_true},
|
||||
{"#f", &obj_false},
|
||||
{"#[undefined]", &obj_undefined}
|
||||
{"#[undefined]", &obj_undefined},
|
||||
{"#[tail]", &obj_tail}
|
||||
};
|
||||
|
||||
|
||||
|
|
@ -2792,7 +2815,11 @@ static void *start(void *p, size_t s)
|
|||
mps_res_t res;
|
||||
mps_root_t globals_root;
|
||||
|
||||
puts("MPS Toy Scheme Example");
|
||||
puts("MPS Toy Scheme Example\n"
|
||||
"The prompt shows total allocated bytes and number of collections.\n"
|
||||
"Try (vector-length (make-vector 100000 1)) to see the MPS in action.\n"
|
||||
"You can force a complete garbage collection with (gc).\n"
|
||||
"If you recurse too much the interpreter may crash from using too much C stack.");
|
||||
|
||||
total = (size_t)0;
|
||||
|
||||
|
|
|
|||
|
|
@ -27,14 +27,14 @@ libraries, tools, and tests. See "Building the MPS for development".
|
|||
|
||||
In the simplest case, you can compile the MPS to an object file with just:
|
||||
|
||||
cc -c mps.c (Unix/Mac OS)
|
||||
cc -c mps.c (Unix/Mac OS X)
|
||||
cl /c mps.c (Windows)
|
||||
|
||||
This will build a "hot" variety (for production) object file for use
|
||||
with "mps.h". You can greatly improve performance by allowing global
|
||||
optimization, for example:
|
||||
|
||||
cc -O2 -c mps.c (Unix/Mac OS)
|
||||
cc -O2 -c mps.c (Unix/Mac OS X)
|
||||
cl /O2 /c mps.c (Windows)
|
||||
|
||||
|
||||
|
|
@ -59,7 +59,7 @@ myformat.c, then you could make a file mymps.c containing
|
|||
|
||||
then
|
||||
|
||||
cc -O2 -c mymps.c (Unix/Mac OS)
|
||||
cc -O2 -c mymps.c (Unix/Mac OS X)
|
||||
cl /O2 /c mymps.c (Windows)
|
||||
|
||||
This will get your format code inlined with the MPS garbage collector.
|
||||
|
|
@ -78,7 +78,7 @@ but you must then provide your own implementation of
|
|||
[mpsliban.c](../code/mpsliban.c).
|
||||
|
||||
If you want to do anything beyond these simple cases, use the MPS build
|
||||
as described in section 5.2, "Building the MPS for development".
|
||||
as described in the section "Building the MPS for development" below.
|
||||
|
||||
|
||||
Building the MPS for development
|
||||
|
|
@ -204,6 +204,8 @@ Document History
|
|||
- 2012-09-05 RB First draft ready for version 1.110, based partly on
|
||||
the old readme, which had grown far too long.
|
||||
|
||||
- 2012-09-19 RB Tidying up a few points after feedback from GDR.
|
||||
|
||||
|
||||
Copyright and Licence
|
||||
---------------------
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue