aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xconfigure18
-rw-r--r--configure.ac2
-rw-r--r--configure.ac.pamphlet2
-rw-r--r--src/ChangeLog14
-rw-r--r--src/algebra/strap/DFLOAT.lsp7
-rw-r--r--src/algebra/strap/INT.lsp7
-rw-r--r--src/algebra/strap/ISTRING.lsp7
-rw-r--r--src/algebra/strap/OUTFORM.lsp52
-rw-r--r--src/algebra/strap/SINT.lsp18
-rw-r--r--src/interp/c-util.boot50
-rw-r--r--src/interp/define.boot9
-rw-r--r--src/interp/g-opt.boot29
12 files changed, 162 insertions, 53 deletions
diff --git a/configure b/configure
index abb09c29..2fbf5ff3 100755
--- a/configure
+++ b/configure
@@ -1,6 +1,6 @@
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.63 for OpenAxiom 1.4.0-2010-03-05.
+# Generated by GNU Autoconf 2.63 for OpenAxiom 1.4.0-2010-03-06.
#
# Report bugs to <open-axiom-bugs@lists.sf.net>.
#
@@ -745,8 +745,8 @@ SHELL=${CONFIG_SHELL-/bin/sh}
# Identity of this package.
PACKAGE_NAME='OpenAxiom'
PACKAGE_TARNAME='openaxiom'
-PACKAGE_VERSION='1.4.0-2010-03-05'
-PACKAGE_STRING='OpenAxiom 1.4.0-2010-03-05'
+PACKAGE_VERSION='1.4.0-2010-03-06'
+PACKAGE_STRING='OpenAxiom 1.4.0-2010-03-06'
PACKAGE_BUGREPORT='open-axiom-bugs@lists.sf.net'
ac_unique_file="src/Makefile.pamphlet"
@@ -1511,7 +1511,7 @@ if test "$ac_init_help" = "long"; then
# Omit some internal or obsolete options to make the list less imposing.
# This message is too long to be a string in the A/UX 3.1 sh.
cat <<_ACEOF
-\`configure' configures OpenAxiom 1.4.0-2010-03-05 to adapt to many kinds of systems.
+\`configure' configures OpenAxiom 1.4.0-2010-03-06 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
@@ -1581,7 +1581,7 @@ fi
if test -n "$ac_init_help"; then
case $ac_init_help in
- short | recursive ) echo "Configuration of OpenAxiom 1.4.0-2010-03-05:";;
+ short | recursive ) echo "Configuration of OpenAxiom 1.4.0-2010-03-06:";;
esac
cat <<\_ACEOF
@@ -1688,7 +1688,7 @@ fi
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
-OpenAxiom configure 1.4.0-2010-03-05
+OpenAxiom configure 1.4.0-2010-03-06
generated by GNU Autoconf 2.63
Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
@@ -1702,7 +1702,7 @@ cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
-It was created by OpenAxiom $as_me 1.4.0-2010-03-05, which was
+It was created by OpenAxiom $as_me 1.4.0-2010-03-06, which was
generated by GNU Autoconf 2.63. Invocation command line was
$ $0 $@
@@ -21165,7 +21165,7 @@ exec 6>&1
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
-This file was extended by OpenAxiom $as_me 1.4.0-2010-03-05, which was
+This file was extended by OpenAxiom $as_me 1.4.0-2010-03-06, which was
generated by GNU Autoconf 2.63. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
@@ -21228,7 +21228,7 @@ Report bugs to <bug-autoconf@gnu.org>."
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_version="\\
-OpenAxiom config.status 1.4.0-2010-03-05
+OpenAxiom config.status 1.4.0-2010-03-06
configured by $0, generated by GNU Autoconf 2.63,
with options \\"`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\"
diff --git a/configure.ac b/configure.ac
index d9ca7f6f..8c0e64d8 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1,6 +1,6 @@
sinclude(config/open-axiom.m4)
sinclude(config/aclocal.m4)
-AC_INIT([OpenAxiom], [1.4.0-2010-03-05],
+AC_INIT([OpenAxiom], [1.4.0-2010-03-06],
[open-axiom-bugs@lists.sf.net])
AC_CONFIG_AUX_DIR(config)
diff --git a/configure.ac.pamphlet b/configure.ac.pamphlet
index d5a8c51e..0d3cb531 100644
--- a/configure.ac.pamphlet
+++ b/configure.ac.pamphlet
@@ -1200,7 +1200,7 @@ information:
<<Autoconf init>>=
sinclude(config/open-axiom.m4)
sinclude(config/aclocal.m4)
-AC_INIT([OpenAxiom], [1.4.0-2010-03-05],
+AC_INIT([OpenAxiom], [1.4.0-2010-03-06],
[open-axiom-bugs@lists.sf.net])
@
diff --git a/src/ChangeLog b/src/ChangeLog
index 59e0a207..6874485c 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,17 @@
+2010-03-06 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * interp/g-opt.boot ($VMsideEffectFreeOperators): New.
+ ($simpleVMoperators): Augment it.
+ (semiSimpleRelativeTo?): New.
+ (isSimpleVMForm): Use it.
+ * interp/c-util.boot (forwardingCall?): New.
+ (usesVariablesLinearly?): Likewise.
+ (expandableDefinition?): Likewise.
+ (foldSpadcall): Tidy.
+ (foldExportedFunctionReferences): If a function is discovered to
+ be expandable, make it so.
+ * interp/define.boot (spadCompileOrSetq): Tidy.
+
2010-03-05 Gabriel Dos Reis <gdr@cs.tamu.edu>
* interp/nruncomp.boot (optDeltaEntry): Silently fail for domains
diff --git a/src/algebra/strap/DFLOAT.lsp b/src/algebra/strap/DFLOAT.lsp
index 9795065f..61278b24 100644
--- a/src/algebra/strap/DFLOAT.lsp
+++ b/src/algebra/strap/DFLOAT.lsp
@@ -93,6 +93,9 @@
|%Boolean|)
|DFLOAT;<=;2$B;22|))
+(PUT '|DFLOAT;<=;2$B;22| '|SPADreplace|
+ '(XLAM (|x| |y|) (NOT (> |x| |y|))))
+
(DECLAIM (FTYPE (FUNCTION (|%DoubleFloat| |%DoubleFloat| |%Shell|)
|%Boolean|)
|DFLOAT;>=;2$B;23|))
@@ -504,7 +507,9 @@
(DEFUN |DFLOAT;>;2$B;21| (|x| |y| $) (DECLARE (IGNORE $)) (> |x| |y|))
-(DEFUN |DFLOAT;<=;2$B;22| (|x| |y| $) (NOT (> |x| |y|)))
+(DEFUN |DFLOAT;<=;2$B;22| (|x| |y| $)
+ (DECLARE (IGNORE $))
+ (NOT (> |x| |y|)))
(DEFUN |DFLOAT;>=;2$B;23| (|x| |y| $)
(DECLARE (IGNORE $))
diff --git a/src/algebra/strap/INT.lsp b/src/algebra/strap/INT.lsp
index 39bb22ff..8640f50b 100644
--- a/src/algebra/strap/INT.lsp
+++ b/src/algebra/strap/INT.lsp
@@ -160,6 +160,9 @@
(DECLAIM (FTYPE (FUNCTION (|%Integer| |%Integer| |%Shell|) |%Boolean|)
|INT;<=;2$B;37|))
+(PUT '|INT;<=;2$B;37| '|SPADreplace|
+ '(XLAM (|x| |y|) (NOT (> |x| |y|))))
+
(DECLAIM (FTYPE (FUNCTION (|%Integer| |%Integer| |%Shell|) |%Boolean|)
|INT;>=;2$B;38|))
@@ -411,7 +414,9 @@
(DEFUN |INT;>;2$B;36| (|x| |y| $) (DECLARE (IGNORE $)) (> |x| |y|))
-(DEFUN |INT;<=;2$B;37| (|x| |y| $) (NOT (> |x| |y|)))
+(DEFUN |INT;<=;2$B;37| (|x| |y| $)
+ (DECLARE (IGNORE $))
+ (NOT (> |x| |y|)))
(DEFUN |INT;>=;2$B;38| (|x| |y| $) (DECLARE (IGNORE $)) (>= |x| |y|))
diff --git a/src/algebra/strap/ISTRING.lsp b/src/algebra/strap/ISTRING.lsp
index 70450c5b..24cf2826 100644
--- a/src/algebra/strap/ISTRING.lsp
+++ b/src/algebra/strap/ISTRING.lsp
@@ -9,9 +9,6 @@
(DECLAIM (FTYPE (FUNCTION (|%Shell|) |%Thing|) |ISTRING;empty;$;2|))
-(PUT '|ISTRING;empty;$;2| '|SPADreplace|
- '(XLAM NIL (MAKE-FULL-CVEC 0)))
-
(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%Boolean|)
|ISTRING;empty?;$B;3|))
@@ -135,9 +132,7 @@
(DECLARE (IGNORE $))
(MAKE-FULL-CVEC |n| |c|))
-(DEFUN |ISTRING;empty;$;2| ($)
- (DECLARE (IGNORE $))
- (MAKE-FULL-CVEC 0))
+(DEFUN |ISTRING;empty;$;2| ($) (MAKE-FULL-CVEC 0))
(DEFUN |ISTRING;empty?;$B;3| (|s| $) (EQL (QCSIZE |s|) 0))
diff --git a/src/algebra/strap/OUTFORM.lsp b/src/algebra/strap/OUTFORM.lsp
index fca0ec38..2d765749 100644
--- a/src/algebra/strap/OUTFORM.lsp
+++ b/src/algebra/strap/OUTFORM.lsp
@@ -355,8 +355,6 @@
(DECLAIM (FTYPE (FUNCTION (|%Shell|) |%Thing|) |OUTFORM;empty;$;73|))
-(PUT '|OUTFORM;empty;$;73| '|SPADreplace| '(XLAM NIL (LIST 'NOTHING)))
-
(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%Boolean|)
|OUTFORM;infix?;$B;74|))
@@ -518,6 +516,15 @@
(PUT '|OUTFORM;int;4$;106| '|SPADreplace|
'(XLAM (|a| |b| |c|) (LIST 'INTSIGN |b| |c| |a|)))
+(PUT '|OUTFORM;postfix;3$;79| '|SPADreplace|
+ '(XLAM (|a| |b|) (LIST 'CONCAT |b| |a|)))
+
+(PUT '|OUTFORM;dot;2$;83| '|SPADreplace|
+ '(XLAM (|a|) (LIST 'SUPERSUB |a| " " '|.|)))
+
+(PUT '|OUTFORM;prime;2$;84| '|SPADreplace|
+ '(XLAM (|a|) (LIST 'SUPERSUB |a| " " '|,|)))
+
(DEFUN |OUTFORM;doubleFloatFormat;2S;1| (|s| $)
(PROG (|ss|)
(RETURN
@@ -539,7 +546,7 @@
(DEFUN |OUTFORM;message;S$;7| (|s| $)
(COND
- ((SPADCALL |s| (|getShellEntry| $ 12)) (LIST 'NOTHING))
+ ((SPADCALL |s| (|getShellEntry| $ 12)) (|OUTFORM;empty;$;73| $))
('T |s|)))
(DEFUN |OUTFORM;messagePrint;SV;8| (|s| $)
@@ -615,15 +622,18 @@
((> |n| 0)
(|OUTFORM;vconcat;3$;50| " " (|OUTFORM;vspace;I$;28| (- |n| 1) $)
$))
- ('T (LIST 'NOTHING))))
+ ('T (|OUTFORM;empty;$;73| $))))
(DEFUN |OUTFORM;hspace;I$;29| (|n| $)
- (COND ((> |n| 0) (|fillerSpaces| |n|)) ('T (LIST 'NOTHING))))
+ (COND
+ ((> |n| 0) (|fillerSpaces| |n|))
+ ('T (|OUTFORM;empty;$;73| $))))
(DEFUN |OUTFORM;rspace;2I$;30| (|n| |m| $)
(SEQ (COND
- ((> |n| 0) (COND ((NOT (> |m| 0)) (EXIT (LIST 'NOTHING)))))
- ('T (EXIT (LIST 'NOTHING))))
+ ((> |n| 0)
+ (COND ((NOT (> |m| 0)) (EXIT (|OUTFORM;empty;$;73| $)))))
+ ('T (EXIT (|OUTFORM;empty;$;73| $))))
(EXIT (|OUTFORM;vconcat;3$;50| (|OUTFORM;hspace;I$;29| |n| $)
(|OUTFORM;rspace;2I$;30| |n| (- |m| 1) $) $))))
@@ -734,7 +744,7 @@
(DEFUN |OUTFORM;supersub;$L$;47| (|a| |l| $)
(SEQ (COND
((ODDP (LENGTH |l|))
- (LETT |l| (APPEND |l| (LIST (LIST 'NOTHING)))
+ (LETT |l| (APPEND |l| (LIST (|OUTFORM;empty;$;73| $)))
|OUTFORM;supersub;$L$;47|)))
(EXIT (CONS 'ALTSUPERSUB (CONS |a| |l|)))))
@@ -836,7 +846,7 @@
(DECLARE (IGNORE $))
(LIST 'BINOMIAL |a| |b|))
-(DEFUN |OUTFORM;empty;$;73| ($) (DECLARE (IGNORE $)) (LIST 'NOTHING))
+(DEFUN |OUTFORM;empty;$;73| ($) (LIST 'NOTHING))
(DEFUN |OUTFORM;infix?;$B;74| (|a| $)
(PROG (#0=#:G1495 |e|)
@@ -866,7 +876,7 @@
(DEFUN |OUTFORM;infix;$L$;77| (|a| |l| $)
(COND
- ((NULL |l|) (LIST 'NOTHING))
+ ((NULL |l|) (|OUTFORM;empty;$;73| $))
((NULL (CDR |l|)) (SPADCALL |l| (|getShellEntry| $ 78)))
((|OUTFORM;infix?;$B;74| |a| $) (CONS |a| |l|))
('T
@@ -880,7 +890,9 @@
((|OUTFORM;infix?;$B;74| |a| $) (LIST |a| |b| |c|))
('T (|OUTFORM;hconcat;L$;49| (LIST |b| |a| |c|) $))))
-(DEFUN |OUTFORM;postfix;3$;79| (|a| |b| $) (LIST 'CONCAT |b| |a|))
+(DEFUN |OUTFORM;postfix;3$;79| (|a| |b| $)
+ (DECLARE (IGNORE $))
+ (LIST 'CONCAT |b| |a|))
(DEFUN |OUTFORM;string;2$;80| (|a| $)
(DECLARE (IGNORE $))
@@ -894,9 +906,13 @@
(DECLARE (IGNORE $))
(LIST 'OVERBAR |a|))
-(DEFUN |OUTFORM;dot;2$;83| (|a| $) (LIST 'SUPERSUB |a| " " '|.|))
+(DEFUN |OUTFORM;dot;2$;83| (|a| $)
+ (DECLARE (IGNORE $))
+ (LIST 'SUPERSUB |a| " " '|.|))
-(DEFUN |OUTFORM;prime;2$;84| (|a| $) (LIST 'SUPERSUB |a| " " '|,|))
+(DEFUN |OUTFORM;prime;2$;84| (|a| $)
+ (DECLARE (IGNORE $))
+ (LIST 'SUPERSUB |a| " " '|,|))
(DEFUN |OUTFORM;dot;$Nni$;85| (|a| |nn| $)
(PROG (|s|)
@@ -975,7 +991,8 @@
(EXIT (|OUTFORM;super;3$;43| |a| (LIST 'PAREN |s|)
$)))))))))
-(DEFUN |OUTFORM;sum;2$;98| (|a| $) (LIST 'SIGMA (LIST 'NOTHING) |a|))
+(DEFUN |OUTFORM;sum;2$;98| (|a| $)
+ (LIST 'SIGMA (|OUTFORM;empty;$;73| $) |a|))
(DEFUN |OUTFORM;sum;3$;99| (|a| |b| $)
(DECLARE (IGNORE $))
@@ -985,7 +1002,8 @@
(DECLARE (IGNORE $))
(LIST 'SIGMA2 |b| |c| |a|))
-(DEFUN |OUTFORM;prod;2$;101| (|a| $) (LIST 'PI (LIST 'NOTHING) |a|))
+(DEFUN |OUTFORM;prod;2$;101| (|a| $)
+ (LIST 'PI (|OUTFORM;empty;$;73| $) |a|))
(DEFUN |OUTFORM;prod;3$;102| (|a| |b| $)
(DECLARE (IGNORE $))
@@ -996,10 +1014,10 @@
(LIST 'PI2 |b| |c| |a|))
(DEFUN |OUTFORM;int;2$;104| (|a| $)
- (LIST 'INTSIGN (LIST 'NOTHING) (LIST 'NOTHING) |a|))
+ (LIST 'INTSIGN (|OUTFORM;empty;$;73| $) (|OUTFORM;empty;$;73| $) |a|))
(DEFUN |OUTFORM;int;3$;105| (|a| |b| $)
- (LIST 'INTSIGN |b| (LIST 'NOTHING) |a|))
+ (LIST 'INTSIGN |b| (|OUTFORM;empty;$;73| $) |a|))
(DEFUN |OUTFORM;int;4$;106| (|a| |b| |c| $)
(DECLARE (IGNORE $))
diff --git a/src/algebra/strap/SINT.lsp b/src/algebra/strap/SINT.lsp
index 6f567c8e..840a7fcf 100644
--- a/src/algebra/strap/SINT.lsp
+++ b/src/algebra/strap/SINT.lsp
@@ -112,6 +112,9 @@
(DECLAIM (FTYPE (FUNCTION (|%Short| |%Short| |%Shell|) |%Boolean|)
|SINT;<=;2$B;26|))
+(PUT '|SINT;<=;2$B;26| '|SPADreplace|
+ '(XLAM (|x| |y|) (NOT (> |x| |y|))))
+
(DECLAIM (FTYPE (FUNCTION (|%Short| |%Short| |%Shell|) |%Boolean|)
|SINT;>=;2$B;27|))
@@ -239,12 +242,18 @@
(DECLAIM (FTYPE (FUNCTION (|%Shell|) (|%IntegerSection| 0))
|SINT;size;Nni;52|))
+(PUT '|SINT;size;Nni;52| '|SPADreplace|
+ '(XLAM NIL (+ (- |$ShortMaximum| |$ShortMinimum|) 1)))
+
(DECLAIM (FTYPE (FUNCTION ((|%IntegerSection| 1) |%Shell|) |%Short|)
|SINT;index;Pi$;53|))
(DECLAIM (FTYPE (FUNCTION (|%Short| |%Shell|) (|%IntegerSection| 1))
|SINT;lookup;$Pi;54|))
+(PUT '|SINT;lookup;$Pi;54| '|SPADreplace|
+ '(XLAM (|x|) (+ (- |x| |$ShortMinimum|) 1)))
+
(DECLAIM (FTYPE (FUNCTION (|%Thing| (|%Vector| *) |%Shell|) |%Pair|)
|SINT;reducedSystem;MVR;55|))
@@ -375,7 +384,9 @@
(DECLARE (IGNORE $))
(QSGREATERP |x| |y|))
-(DEFUN |SINT;<=;2$B;26| (|x| |y| $) (NOT (> |x| |y|)))
+(DEFUN |SINT;<=;2$B;26| (|x| |y| $)
+ (DECLARE (IGNORE $))
+ (NOT (> |x| |y|)))
(DEFUN |SINT;>=;2$B;27| (|x| |y| $) (DECLARE (IGNORE $)) (>= |x| |y|))
@@ -458,6 +469,7 @@
(QSMINUSP |x|))
(DEFUN |SINT;size;Nni;52| ($)
+ (DECLARE (IGNORE $))
(+ (- |$ShortMaximum| |$ShortMinimum|) 1))
(DEFUN |SINT;index;Pi$;53| (|i| $)
@@ -467,7 +479,9 @@
|SINT;index;Pi$;53|)
(|check-subtype| (SMINTP #0#) '(|SingleInteger|) #0#)))))
-(DEFUN |SINT;lookup;$Pi;54| (|x| $) (+ (- |x| |$ShortMinimum|) 1))
+(DEFUN |SINT;lookup;$Pi;54| (|x| $)
+ (DECLARE (IGNORE $))
+ (+ (- |x| |$ShortMinimum|) 1))
(DEFUN |SINT;reducedSystem;MVR;55| (|m| |v| $)
(DECLARE (IGNORE $))
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 45afea96..4df0052f 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -1105,11 +1105,50 @@ replaceSimpleFunctions form ==
form
+++ We are processing a function definition with parameter list `vars'
+++ and body given by `body'. If `body' is a forwarding function call,
+++ return the target function. Otherwise, return nil.
+forwardingCall?(vars,body) ==
+ vars is [:vars',.] and body is [fun,: =vars'] and IDENTP fun => fun
+ nil
+
+
+++ Return true if `form' has a linear usage of all variables in `vars'.
+usesVariablesLinearly?(form,vars) ==
+ isAtomicForm form => true
+ and/[numOfOccurencesOf(var,form) < 2 for var in vars]
+
+++ We are processing a function definition with parameter list `vars'
+++ and body given by `body'. If `body' is a form that can be inlined,
+++ then return the inline form. Otherwise, return nil.
+expandableDefinition?(vars,body) ==
+ expand? :=
+ -- We definitely don't want to expand a form that uses
+ -- the domain of computation environment.
+ vars isnt [:vars',env] or CONTAINED(env,body) => false
+
+ -- Constants are currently implemented as niladic functions, and
+ -- we want to avoid disturbing object identity, so we rule
+ -- out use of side-effect full operators.
+ -- FIXME: This should be done only for constant creators.
+ null vars' => semiSimpleRelativeTo?(body,$VMsideEffectFreeOperators)
+
+ isAtomicForm body => true
+ [op,:args] := body
+ not IDENTP op => false
+ and/[isAtomicForm x for x in args]
+ or semiSimpleRelativeTo?(body,$simpleVMoperators) =>
+ usesVariablesLinearly?(body,vars')
+ false
+ expand? => ["XLAM",vars',body]
+ nil
+
++ Replace all SPADCALLs to operations defined in the current
++ domain. Conditional operations are not folded.
foldSpadcall: %Form -> %Form
foldSpadcall form ==
- isAtomicForm form => form
+ isAtomicForm form => form -- leave atomic forms alone
+ form is ["DECLARE",:.] => form -- don't walk declarations
form is ["LET",inits,:body] =>
mutateLETFormWithUnaryFunction(form,"foldSpadcall")
form is ["COND",:stmts] =>
@@ -1129,8 +1168,13 @@ foldSpadcall form ==
++ with their corresponding linkage names.
foldExportedFunctionReferences defs ==
for fun in defs repeat
- foldSpadcall fun is [.,lamex] =>
- rplac(third lamex, replaceSimpleFunctions third lamex)
+ fun isnt [name,lamex] => nil
+ lamex isnt ["LAM",vars,body] => nil
+ body := replaceSimpleFunctions foldSpadcall body
+ form := expandableDefinition?(vars,body) =>
+ registerFunctionReplacement(name,form)
+ rplac(second fun, ["LAM",vars,["DECLARE",["IGNORE",last vars]],body])
+ rplac(third lamex,body)
defs
++ record optimizations permitted at level `level'.
diff --git a/src/interp/define.boot b/src/interp/define.boot
index d25302e8..5a8930ee 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -1246,17 +1246,16 @@ spadCompileOrSetq (form is [nam,[lam,vl,body]]) ==
if $optReplaceSimpleFunctions then
body := replaceSimpleFunctions body
- if vl is [:vl',E] and body is [nam',: =vl'] then
+ if nam' := forwardingCall?(vl,body) then
registerFunctionReplacement(nam,nam')
sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam']
- else if (isAtomicForm body or and/[isAtomicForm x for x in body])
- and vl is [:vl',E] and not CONTAINED(E,body) then
- macform := ['XLAM,vl',body]
+ else if macform := expandableDefinition?(vl,body) then
registerFunctionReplacement(nam,macform)
sayBrightly ['" ",:bright nam,'"is replaced by",:bright body]
form :=
- getFunctionReplacement nam => [nam,[lam,vl,["DECLARE",["IGNORE",E]],body]]
+ getFunctionReplacement nam =>
+ [nam,[lam,vl,["DECLARE",["IGNORE",last vl]],body]]
[nam,[lam,vl,body]]
$insideCapsuleFunctionIfTrue =>
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index 8110587e..38613f11 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -392,16 +392,31 @@ optLESSP u ==
['GREATERP,b,a]
u
-$simpleVMoperators ==
- '(CONS CAR CDR LENGTH SIZE EQUAL EQL EQ NOT NULL OR AND
- SPADfirst QVELT _+ _- _* _< _= ASH INTEGER_-LENGTH
+++ List of VM side effect free operators.
+$VMsideEffectFreeOperators ==
+ '(CAR CDR LENGTH SIZE EQUAL EQL EQ NOT NULL OR AND
+ SPADfirst QVELT _+ _- _* _< _= _<_= _> _>_= ASH INTEGER_-LENGTH
QEQCAR QCDR QCAR INTEGERP FLOATP STRINGP IDENTP SYMBOLP
- MINUSP GREATERP)
+ MINUSP GREATERP ZEROP ODDP FLOAT_-RADIX FLOAT FLOAT_-SIGN FLOAT_-DIGITS
+ CGREATERP GGREATERP CHAR BOOLE GET BVEC_-GREATER FUNCALL)
-isSimpleVMForm form ==
+++ List of simple VM operators
+$simpleVMoperators ==
+ append($VMsideEffectFreeOperators,
+ ["CONS","LIST","VECTOR","STRINGIMAGE",
+ "MAKE-FULL-CVEC","BVEC-MAKE-FULL","COND"])
+
+++ Return true if the `form' is semi-simple with respect to
+++ to the list of operators `ops'.
+semiSimpleRelativeTo?(form,ops) ==
isAtomicForm form => true
- form is [op,:args] and MEMQ(op,$simpleVMoperators)
- and ("and"/[isAtomicForm arg for arg in args])
+ form isnt [op,:args] or not MEMQ(op,ops) => false
+ and/[semiSimpleRelativeTo?(f,ops) for f in args]
+
+++ Return true if `form' is a simple VM form.
+++ See $simpleVMoperators for the definition of simple operators.
+isSimpleVMForm form ==
+ semiSimpleRelativeTo?(form,$simpleVMoperators)
++ Return true if `form' is a VM form whose evaluation does not depend
++ on the program point where it is evaluated.
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-08 16:26:50 +0000