diff options
30 files changed, 860 insertions, 848 deletions
@@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.60 for OpenAxiom 1.1.0-2007-11-06. +# Generated by GNU Autoconf 2.60 for OpenAxiom 1.1.0-2007-11-08. # # Report bugs to <open-axiom-bugs@lists.sf.net>. # @@ -713,8 +713,8 @@ SHELL=${CONFIG_SHELL-/bin/sh} # Identity of this package. PACKAGE_NAME='OpenAxiom' PACKAGE_TARNAME='openaxiom' -PACKAGE_VERSION='1.1.0-2007-11-06' -PACKAGE_STRING='OpenAxiom 1.1.0-2007-11-06' +PACKAGE_VERSION='1.1.0-2007-11-08' +PACKAGE_STRING='OpenAxiom 1.1.0-2007-11-08' PACKAGE_BUGREPORT='open-axiom-bugs@lists.sf.net' ac_unique_file="src/Makefile.pamphlet" @@ -1388,7 +1388,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.1.0-2007-11-06 to adapt to many kinds of systems. +\`configure' configures OpenAxiom 1.1.0-2007-11-08 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1458,7 +1458,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of OpenAxiom 1.1.0-2007-11-06:";; + short | recursive ) echo "Configuration of OpenAxiom 1.1.0-2007-11-08:";; esac cat <<\_ACEOF @@ -1562,7 +1562,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -OpenAxiom configure 1.1.0-2007-11-06 +OpenAxiom configure 1.1.0-2007-11-08 generated by GNU Autoconf 2.60 Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, @@ -1576,7 +1576,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.1.0-2007-11-06, which was +It was created by OpenAxiom $as_me 1.1.0-2007-11-08, which was generated by GNU Autoconf 2.60. Invocation command line was $ $0 $@ @@ -25198,7 +25198,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.1.0-2007-11-06, which was +This file was extended by OpenAxiom $as_me 1.1.0-2007-11-08, which was generated by GNU Autoconf 2.60. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -25247,7 +25247,7 @@ Report bugs to <bug-autoconf@gnu.org>." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF ac_cs_version="\\ -OpenAxiom config.status 1.1.0-2007-11-06 +OpenAxiom config.status 1.1.0-2007-11-08 configured by $0, generated by GNU Autoconf 2.60, with options \\"`echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\" diff --git a/configure.ac b/configure.ac index 0ac31dc5..1b4987b4 100644 --- a/configure.ac +++ b/configure.ac @@ -1,6 +1,6 @@ sinclude(config/open-axiom.m4) sinclude(config/aclocal.m4) -AC_INIT([OpenAxiom], [1.1.0-2007-11-06], +AC_INIT([OpenAxiom], [1.1.0-2007-11-08], [open-axiom-bugs@lists.sf.net]) AC_CONFIG_AUX_DIR(config) diff --git a/configure.ac.pamphlet b/configure.ac.pamphlet index 9851875d..840a8ecf 100644 --- a/configure.ac.pamphlet +++ b/configure.ac.pamphlet @@ -1010,7 +1010,7 @@ information: <<Autoconf init>>= sinclude(config/open-axiom.m4) sinclude(config/aclocal.m4) -AC_INIT([OpenAxiom], [1.1.0-2007-11-06], +AC_INIT([OpenAxiom], [1.1.0-2007-11-08], [open-axiom-bugs@lists.sf.net]) @ diff --git a/src/interp/ChangeLog b/src/interp/ChangeLog index f40fbd5f..9309fc94 100644 --- a/src/interp/ChangeLog +++ b/src/interp/ChangeLog @@ -1,3 +1,48 @@ +2007-11-07 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * Makefile.pamphlet (i-toplev.$(FASLEXT)): New rule. + (i-syscmd.$(FASLEXT)): Likewise. + (i-spec2.$(FASLEXT)): Likewise. + (i-spec1.$(FASLEXT)): Likewise. + (i-funsel.$(FASLEXT)): Likewise. + (i-map.$(FASLEXT)): Likewise. + (i-eval.$(FASLEXT)): Likewise. + (i-coerfn.$(FASLEXT)): Likewise. + (i-coerce.$(FASLEXT)): Likewise. + (i-resolv.$(FASLEXT)): Likewise. + (i-analy.$(FASLEXT)): Likewise. + (i-code.$(FASLEXT)): Likewise. + (i-intern.$(FASLEXT)): Likewise. + (<<i-analy.clisp>>): Remove. + (<<i-code.clisp>>): Likewise. + (<<i-coerce.clisp>>): Likewise. + (<<i-coerfn.clisp>>): Likewise. + (<<i-eval.clisp>>): Likewise. + (<<i-funsel.clisp>>): Likewise. + (<<i-intern.clisp>>): Likewise. + (<<i-map.clisp>>): Likewise. + (<<i-resolv.clisp>>): Likewise. + (<<i-spec1.clisp>>): Likewise. + (<<i-spec2.clisp>>): Likewise. + (<<i-syscmd.clisp>>): Likewise. + (<<i-toplev.clisp>>): Likewise. + (<<i-util.clisp>>): Likewise. + * apply.boot (compFormWithModemap): Fix syntax. + * i-analy.boot.pamphlet: Push into package "BOOT". + * i-code.boot.pamphlet: Likewise. + * i-coerce.boot.pamphlet: Likewise. + * i-coerfn.boot.pamphlet: Likewise. + * i-eval.boot.pamphlet: Likewise. + * i-funsel.boot.pamphlet: Likewise. + * i-intern.boot.pamphlet: Likewise. + * i-map.boot.pamphlet: Likewise. + * i-resolv.boot.pamphlet: Likewise. + * i-spec1.boot.pamphlet: Likewise. + * i-spec2.boot.pamphlet: Likewise. + * i-syscmd.bot.pamphlet: Likewise. + * i-toplev.boot.pamphlet: Likewise. + * i-util.boot.pamphlet: Likewise. + 2007-11-05 Gabriel Dos Reis <gdr@cs.tamu.edu> * Makefile.pamphlet (compiler.$(FASLEXT)): New rule. diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index 1bc269bf..29cd5263 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -421,10 +421,52 @@ profile.$(FASLEXT): profile.boot macros.$(FASLEXT) rulesets.$(FASLEXT): rulesets.boot vmlisp.$(FASLEXT) $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< +i-toplev.$(FASLEXT): i-toplev.boot i-analy.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-syscmd.$(FASLEXT): i-syscmd.boot i-object.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + i-output.$(FASLEXT): i-output.boot sys-macros.$(FASLEXT) $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< -i-object.$(FASLEXT): i-object.boot sys-macros.$(FASLEXT) +i-spec2.$(FASLEXT): i-spec2.boot i-spec1.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-spec1.$(FASLEXT): i-spec1.boot i-analy.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-funsel.$(FASLEXT): i-funsel.boot i-coerfn.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-map.$(FASLEXT): i-map.boot i-object.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-eval.$(FASLEXT): i-eval.boot i-analy.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-coerfn.$(FASLEXT): i-coerfn.boot i-coerce.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-coerce.$(FASLEXT): i-coerce.boot i-analy.$(FASLEXT) i-resolv.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-resolv.$(FASLEXT): i-resolv.boot i-object.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-analy.$(FASLEXT): i-analy.boot i-object.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-intern.$(FASLEXT): i-intern.boot i-object.$(FASLEXT) ptrees.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-code.$(FASLEXT): i-code.boot i-object.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-object.$(FASLEXT): i-object.boot g-util.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-util.$(FASLEXT): i-util.boot g-util.$(FASLEXT) $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< format.$(FASLEXT): format.boot macros.$(FASLEXT) @@ -691,66 +733,10 @@ clammed.clisp: clammed.boot @ echo 226 making $@ from $< @ echo '(old-boot::boot "clammed.boot")' | ${DEPSYS} -i-analy.clisp: i-analy.boot - @ echo 280 making $@ from $< - @ echo '(old-boot::boot "i-analy.boot")' | ${DEPSYS} - -i-code.clisp: i-code.boot - @ echo 283 making $@ from $< - @ echo '(old-boot::boot "i-code.boot")' | ${DEPSYS} - -i-coerce.clisp: i-coerce.boot - @ echo 286 making $@ from $< - @ echo '(old-boot::boot "i-coerce.boot")' | ${DEPSYS} - -i-coerfn.clisp: i-coerfn.boot - @ echo 289 making $@ from $< - @ echo '(old-boot::boot "i-coerfn.boot")' | ${DEPSYS} - -i-eval.clisp: i-eval.boot - @ echo 292 making $@ from $< - @ echo '(old-boot::boot "i-eval.boot")' | ${DEPSYS} - -i-funsel.clisp: i-funsel.boot - @ echo 295 making $@ from $< - @ echo '(old-boot::boot "i-funsel.boot")' | ${DEPSYS} - bookvol5.lisp: $(srcdir)/bookvol5.pamphlet @ echo 298 making $@ from $< $(axiom_build_document) --tangle=Interpreter --output=$@ $< -i-intern.clisp: i-intern.boot - @ echo 301 making $@ from $< - @ echo '(old-boot::boot "i-intern.boot")' | ${DEPSYS} - -i-map.clisp: i-map.boot - @ echo 304 making $@ from $< - @ echo '(old-boot::boot "i-map.boot")' | ${DEPSYS} - -i-resolv.clisp: i-resolv.boot - @ echo 310 making $@ from $< - @ echo '(old-boot::boot "i-resolv.boot")' | ${DEPSYS} - -i-spec1.clisp: i-spec1.boot - @ echo 313 making $@ from $< - @ echo '(old-boot::boot "i-spec1.boot")' | ${DEPSYS} - -i-spec2.clisp: i-spec2.boot - @ echo 316 making $@ from i-spec2.boot - @ echo '(old-boot::boot "i-spec2.boot")' | ${DEPSYS} - -i-syscmd.clisp: i-syscmd.boot - @ echo 319 making $@ from $< - @ echo '(old-boot::boot "i-syscmd.boot")' | ${DEPSYS} - -i-toplev.clisp: i-toplev.boot - @ echo 322 making $@ from $< - @ echo '(old-boot::boot "i-toplev.boot")' | ${DEPSYS} - -i-util.clisp: i-util.boot - @ echo 325 making $@ from $< - @ echo '(old-boot::boot "i-util.boot")' | ${DEPSYS} - nruncomp.clisp: nruncomp.boot @ echo 353 making $@ from $< @ echo '(old-boot::boot "nruncomp.boot")' | ${DEPSYS} diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 94c1b16d..5689459a 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -832,54 +832,6 @@ clammed.clisp: clammed.boot @ echo '(old-boot::boot "clammed.boot")' | ${DEPSYS} @ -\subsection{i-analy.boot} - -<<i-analy.clisp>>= -i-analy.clisp: i-analy.boot - @ echo 280 making $@ from $< - @ echo '(old-boot::boot "i-analy.boot")' | ${DEPSYS} -@ - -\subsection{i-code.boot} - -<<i-code.clisp>>= -i-code.clisp: i-code.boot - @ echo 283 making $@ from $< - @ echo '(old-boot::boot "i-code.boot")' | ${DEPSYS} -@ - -\subsection{i-coerce.boot} - -<<i-coerce.clisp>>= -i-coerce.clisp: i-coerce.boot - @ echo 286 making $@ from $< - @ echo '(old-boot::boot "i-coerce.boot")' | ${DEPSYS} -@ - -\subsection{i-coerfn.boot} - -<<i-coerfn.clisp>>= -i-coerfn.clisp: i-coerfn.boot - @ echo 289 making $@ from $< - @ echo '(old-boot::boot "i-coerfn.boot")' | ${DEPSYS} -@ - -\subsection{i-eval.boot} - -<<i-eval.clisp>>= -i-eval.clisp: i-eval.boot - @ echo 292 making $@ from $< - @ echo '(old-boot::boot "i-eval.boot")' | ${DEPSYS} -@ - -\subsection{i-funsel.boot} - -<<i-funsel.clisp>>= -i-funsel.clisp: i-funsel.boot - @ echo 295 making $@ from $< - @ echo '(old-boot::boot "i-funsel.boot")' | ${DEPSYS} -@ - \subsection{bookvol5.lsp} @@ -889,70 +841,6 @@ bookvol5.lisp: $(srcdir)/bookvol5.pamphlet $(axiom_build_document) --tangle=Interpreter --output=$@ $< @ -\subsection{i-intern.boot} - -<<i-intern.clisp>>= -i-intern.clisp: i-intern.boot - @ echo 301 making $@ from $< - @ echo '(old-boot::boot "i-intern.boot")' | ${DEPSYS} -@ - -\subsection{i-map.boot} - -<<i-map.clisp>>= -i-map.clisp: i-map.boot - @ echo 304 making $@ from $< - @ echo '(old-boot::boot "i-map.boot")' | ${DEPSYS} -@ - -\subsection{i-resolv.boot} - -<<i-resolv.clisp>>= -i-resolv.clisp: i-resolv.boot - @ echo 310 making $@ from $< - @ echo '(old-boot::boot "i-resolv.boot")' | ${DEPSYS} -@ - -\subsection{i-spec1.boot} - -<<i-spec1.clisp>>= -i-spec1.clisp: i-spec1.boot - @ echo 313 making $@ from $< - @ echo '(old-boot::boot "i-spec1.boot")' | ${DEPSYS} -@ - -\subsection{i-spec2.boot} - -<<i-spec2.clisp>>= -i-spec2.clisp: i-spec2.boot - @ echo 316 making $@ from i-spec2.boot - @ echo '(old-boot::boot "i-spec2.boot")' | ${DEPSYS} -@ - -\subsection{i-syscmd.boot} - -<<i-syscmd.clisp>>= -i-syscmd.clisp: i-syscmd.boot - @ echo 319 making $@ from $< - @ echo '(old-boot::boot "i-syscmd.boot")' | ${DEPSYS} -@ - -\subsection{i-toplev.boot} - -<<i-toplev.clisp>>= -i-toplev.clisp: i-toplev.boot - @ echo 322 making $@ from $< - @ echo '(old-boot::boot "i-toplev.boot")' | ${DEPSYS} -@ - -\subsection{i-util.boot} - -<<i-util.clisp>>= -i-util.clisp: i-util.boot - @ echo 325 making $@ from $< - @ echo '(old-boot::boot "i-util.boot")' | ${DEPSYS} -@ - \subsection{nruncomp.boot} <<nruncomp.clisp>>= @@ -1206,10 +1094,52 @@ profile.$(FASLEXT): profile.boot macros.$(FASLEXT) rulesets.$(FASLEXT): rulesets.boot vmlisp.$(FASLEXT) $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< +i-toplev.$(FASLEXT): i-toplev.boot i-analy.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-syscmd.$(FASLEXT): i-syscmd.boot i-object.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + i-output.$(FASLEXT): i-output.boot sys-macros.$(FASLEXT) $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< -i-object.$(FASLEXT): i-object.boot sys-macros.$(FASLEXT) +i-spec2.$(FASLEXT): i-spec2.boot i-spec1.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-spec1.$(FASLEXT): i-spec1.boot i-analy.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-funsel.$(FASLEXT): i-funsel.boot i-coerfn.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-map.$(FASLEXT): i-map.boot i-object.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-eval.$(FASLEXT): i-eval.boot i-analy.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-coerfn.$(FASLEXT): i-coerfn.boot i-coerce.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-coerce.$(FASLEXT): i-coerce.boot i-analy.$(FASLEXT) i-resolv.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-resolv.$(FASLEXT): i-resolv.boot i-object.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-analy.$(FASLEXT): i-analy.boot i-object.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-intern.$(FASLEXT): i-intern.boot i-object.$(FASLEXT) ptrees.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-code.$(FASLEXT): i-code.boot i-object.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-object.$(FASLEXT): i-object.boot g-util.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + +i-util.$(FASLEXT): i-util.boot g-util.$(FASLEXT) $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< format.$(FASLEXT): format.boot macros.$(FASLEXT) @@ -1460,36 +1390,8 @@ boot-pkg.$(FASLEXT): boot-pkg.lisp <<clammed.clisp>> -<<i-analy.clisp>> - -<<i-code.clisp>> - -<<i-coerce.clisp>> - -<<i-coerfn.clisp>> - -<<i-eval.clisp>> - -<<i-funsel.clisp>> - <<bookvol5.lisp>> -<<i-intern.clisp>> - -<<i-map.clisp>> - -<<i-resolv.clisp>> - -<<i-spec1.clisp>> - -<<i-spec2.clisp>> - -<<i-syscmd.clisp>> - -<<i-toplev.clisp>> - -<<i-util.clisp>> - <<nruncomp.clisp>> <<nrunfast.clisp>> diff --git a/src/interp/apply.boot b/src/interp/apply.boot index 144f9cbf..c02e4646 100644 --- a/src/interp/apply.boot +++ b/src/interp/apply.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are @@ -116,8 +118,8 @@ compFormWithModemap(form is [op,:argl],m,e,modemap) == -- try to deal with new-style Unions where we know the conditions op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and (c:=get(z,'condition,e)) and - c is [['case,=z,c1]] and - (c1 is ['_:,=(CADR argl),=m] or EQ(c1,CADR argl) ) => + c is [["case",=z,c1]] and + (c1 is [":",=(CADR argl),=m] or EQ(c1,CADR argl) ) => -- first is a full tag, as placed by getInverseEnvironment -- second is what getSuccessEnvironment will place there ["CDR",z] diff --git a/src/interp/i-analy.boot.pamphlet b/src/interp/i-analy.boot.pamphlet index ff751ace..b89b1df8 100644 --- a/src/interp/i-analy.boot.pamphlet +++ b/src/interp/i-analy.boot.pamphlet @@ -46,6 +46,9 @@ <<*>>= <<license>> +import '"i-object" +)package "BOOT" + --% Interpreter Analysis Functions getMinimalVariableTower(var,t) == diff --git a/src/interp/i-code.boot.pamphlet b/src/interp/i-code.boot.pamphlet index c6551bb5..e014e55b 100644 --- a/src/interp/i-code.boot.pamphlet +++ b/src/interp/i-code.boot.pamphlet @@ -46,6 +46,9 @@ <<*>>= <<license>> +import '"i-object" +)package "BOOT" + --% Interpreter Code Generation Routines --Modified by JHD 9/9/93 to fix a problem with coerces inside diff --git a/src/interp/i-coerce.boot.pamphlet b/src/interp/i-coerce.boot.pamphlet index ff43961f..b488ce9d 100644 --- a/src/interp/i-coerce.boot.pamphlet +++ b/src/interp/i-coerce.boot.pamphlet @@ -100,6 +100,11 @@ getConstantFromDomain(form,domainForm) == @ <<*>>= <<license>> + +import '"i-analy" +import '"i-resolv" +)package "BOOT" + --% Algebraic coercions using interactive code algCoerceInteractive(p,source,target) == diff --git a/src/interp/i-coerfn.boot.pamphlet b/src/interp/i-coerfn.boot.pamphlet index 16eb1850..24f14bf5 100644 --- a/src/interp/i-coerfn.boot.pamphlet +++ b/src/interp/i-coerfn.boot.pamphlet @@ -112,7 +112,10 @@ all these coercion functions have the following result: <<*>>= <<license>> -SETANDFILEQ($coerceFailure,GENSYM()) +import '"i-coerce" +)package "BOOT" + +$coerceFailure := GENSYM() position1(x,y) == -- this is used where we want to assume a 1-based index @@ -684,7 +687,7 @@ L2M(u,[.,D],[.,R]) == L2Record(l,[.,D],[.,:al]) == l = '_$fromCoerceable_$ => nil #l = #al => - v:= [u for x in l for [":",.,D'] in al] where u == + v:= [u for x in l for [":",.,D'] in al] where u() == T:= coerceInt(objNewWrap(x,D),D') or return 'failed objValUnwrap(T) v = 'failed => coercionFailure() diff --git a/src/interp/i-eval.boot.pamphlet b/src/interp/i-eval.boot.pamphlet index 3ec9050b..ed05090d 100644 --- a/src/interp/i-eval.boot.pamphlet +++ b/src/interp/i-eval.boot.pamphlet @@ -46,6 +46,9 @@ <<*>>= <<license>> +import '"i-analy" +)package "BOOT" + --% Constructor Evaluation $noEvalTypeMsg := nil @@ -70,7 +73,7 @@ mkEvalable form == loadIfNecessary op kind:= GETDATABASE(op,'CONSTRUCTORKIND) cosig := GETDATABASE(op, 'COSIG) => - [op,:[val for x in argl for typeFlag in rest cosig]] where val == + [op,:[val for x in argl for typeFlag in rest cosig]] where val() == typeFlag => kind = 'category => MKQ x VECP x => MKQ x @@ -178,7 +181,7 @@ evaluateType1 form == ml := replaceSharps(ml,form) # argl ^= #ml => throwEvalTypeMsg("S2IE0003",[form,form]) for x in argl for m in ml for argnum in 1.. repeat - typeList := [v,:typeList] where v == + typeList := [v,:typeList] where v() == categoryForm?(m) => m := evaluateType MSUBSTQ(x,'_$,m) evalCategory(x' := (evaluateType x), m) => x' @@ -187,7 +190,7 @@ evaluateType1 form == GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'domain and (tree := mkAtree x) and putTarget(tree,m) and ((bottomUp tree) is [m1]) => [zt,:zv]:= z1:= getAndEvalConstructorArgument tree - (v:= coerceOrRetract(z1,m)) => objValUnwrap v + (v' := coerceOrRetract(z1,m)) => objValUnwrap v' throwKeyedMsgCannotCoerceWithValue(zv,zt,m) if x = $EmptyMode then x := $quadSymbol throwEvalTypeMsg("S2IE0006",[makeOrdinal argnum,m,form]) diff --git a/src/interp/i-funsel.boot.pamphlet b/src/interp/i-funsel.boot.pamphlet index 3ba29f64..5f5d4278 100644 --- a/src/interp/i-funsel.boot.pamphlet +++ b/src/interp/i-funsel.boot.pamphlet @@ -79,7 +79,10 @@ isPartialMode m == <<*>>= <<license>> -SETANDFILEQ($constructorExposureList, '(Boolean Integer String)) +import '"i-coerfn" +)package "BOOT" + +$constructorExposureList := '(Boolean Integer String) sayFunctionSelection(op,args,target,dc,func) == $abbreviateTypes : local := true @@ -442,7 +445,7 @@ defaultTarget(opNode,op,nargs,args) == target target - op = '_/ => + op = "/" => isEqualOrSubDomain(a1, $Integer) and isEqualOrSubDomain(a2, $Integer) => putTarget(opNode, target := $RationalNumber) target @@ -1094,39 +1097,12 @@ selectMmsGen(op,tar,args1,args2) == sayMSG ['%l,:bright '"Modemaps from Associated Packages"] if haves then - [havesExact,havesInexact] := exact?(haves,tar,args1) where - exact?(mmS,tar,args) == - ex := inex := NIL - for (mm := [sig,[mmC,:.],:.]) in mmS repeat - [c,t,:a] := sig - ok := true - for pat in a for arg in args while ok repeat - not CONTAINED(['isDomain,pat,arg],mmC) => ok := NIL - ok => ex := CONS(mm,ex) - inex := CONS(mm,inex) - [ex,inex] + [havesExact,havesInexact] := exact?(haves,tar,args1) if $reportBottomUpFlag then for mm in APPEND(havesExact,havesInexact) for i in 1.. repeat sayModemapWithNumber(mm,i) if havesExact then - mmS := matchMms(havesExact,op,tar,args1,args2) where - matchMms(mmaps,op,tar,args1,args2) == - mmS := NIL - for [sig,mmC] in mmaps repeat - -- sig is [dc,result,:args] - $Subst := - tar and not isPartialMode tar => - -- throw in the target if it is not the same as one - -- of the arguments - res := CADR sig - member(res,CDDR sig) => NIL - [[res,:tar]] - NIL - [c,t,:a] := sig - if a then matchTypes(a,args1,args2) - not EQ($Subst,'failed) => - mmS := nconc(evalMm(op,tar,sig,mmC),mmS) - mmS + mmS := matchMms(havesExact,op,tar,args1,args2) if mmS then if $reportBottomUpFlag then sayMSG '" found an exact match!" @@ -1153,6 +1129,34 @@ selectMmsGen(op,tar,args1,args2) == mmS := matchMms(havesNInexact,op,tar,args1,args2) else if $reportBottomUpFlag then sayMSG '" no modemaps" mmS + where + exact?(mmS,tar,args) == + ex := inex := NIL + for (mm := [sig,[mmC,:.],:.]) in mmS repeat + [c,t,:a] := sig + ok := true + for pat in a for arg in args while ok repeat + not CONTAINED(['isDomain,pat,arg],mmC) => ok := NIL + ok => ex := CONS(mm,ex) + inex := CONS(mm,inex) + [ex,inex] + matchMms(mmaps,op,tar,args1,args2) == + mmS := NIL + for [sig,mmC] in mmaps repeat + -- sig is [dc,result,:args] + $Subst := + tar and not isPartialMode tar => + -- throw in the target if it is not the same as one + -- of the arguments + res := CADR sig + member(res,CDDR sig) => NIL + [[res,:tar]] + NIL + [c,t,:a] := sig + if a then matchTypes(a,args1,args2) + not EQ($Subst,'failed) => + mmS := nconc(evalMm(op,tar,sig,mmC),mmS) + mmS matchTypes(pm,args1,args2) == -- pm is a list of pattern variables, args1 a list of argument types, @@ -1658,11 +1662,11 @@ hasAtt(dom,att,SL) == 'failed hasCatExpression(cond,SL) == - cond is ['OR,:l] => + cond is ["OR",:l] => or/[(y:=hasCatExpression(x,SL)) ^= 'failed for x in l] => y - cond is ['AND,:l] => + cond is ["AND",:l] => and/[(SL:= hasCatExpression(x,SL)) ^= 'failed for x in l] => SL - cond is ['has,a,b] => hasCate(a,b,SL) + cond is ["has",a,b] => hasCate(a,b,SL) keyedSystemError("S2GE0016", ['"hasSig",'"unexpected condition for attribute"]) @@ -1670,8 +1674,8 @@ unifyStruct(s1,s2,SL) == -- tests for equality of s1 and s2 under substitutions SL and $Subst -- the result is a substitution list or 'failed s1=s2 => SL - if s1 is ['_:,x,.] then s1:= x - if s2 is ['_:,x,.] then s2:= x + if s1 is [":",x,.] then s1:= x + if s2 is [":",x,.] then s2:= x if ^atom s1 and CAR s1 = '_# then s1:= LENGTH CADR s1 if ^atom s2 and CAR s2 = '_# then s2:= LENGTH CADR s2 s1=s2 => SL diff --git a/src/interp/i-intern.boot.pamphlet b/src/interp/i-intern.boot.pamphlet index 1ac1079b..aabd6a7e 100644 --- a/src/interp/i-intern.boot.pamphlet +++ b/src/interp/i-intern.boot.pamphlet @@ -9,30 +9,7 @@ \eject \tableofcontents \eject -\begin{verbatim} -Internal Interpreter Facilities - -Vectorized Attributed Trees - -The interpreter translates parse forms into vats for analysis. -These contain a number of slots in each node for information. -The leaves are now all vectors, though the leaves for basic types -such as integers and strings used to just be the objects themselves. -The vectors for the leaves with such constants now have the value -of $immediateDataSymbol as their name. Their are undoubtably still -some functions that still check whether a leaf is a constant. Note -that if it is not a vector it is a subtree. - -attributed tree nodes have the following form: -slot description ----- ----------------------------------------------------- - 0 operation name or literal - 1 declared mode of variable - 2 computed value of subtree from this node - 3 modeset: list of single computed mode of subtree - 4 prop list for extra things - -\end{verbatim} + \section{License} <<license>>= -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. @@ -70,16 +47,14 @@ slot description <<*>>= <<license>> -SETANDFILEQ($useParserSrcPos, NIL) -SETANDFILEQ($transferParserSrcPos, NIL) +import '"i-object" +import '"ptrees" +)package "BOOT" --- Making Trees +$useParserSrcPos := NIL +$transferParserSrcPos := NIL -mkAtreeNode x == - -- maker of attrib tree node - v := MAKE_-VEC 5 - v.0 := x - v +-- Making Trees mkAtree x == -- maker of attrib tree from parser form @@ -111,14 +86,14 @@ transferSrcPosInfo(pf, atree) == mkAtreeExpandMacros x == -- handle macro expansion. if the macros have args we require that -- we match the correct number of args - if x isnt ['MDEF,:.] and x isnt ['DEF,['macro,:.],:.] then + if x isnt ["MDEF",:.] and x isnt ["DEF",["macro",:.],:.] then atom x and (m := isInterpMacro x) => [args,:body] := m - args => 'doNothing + args => "doNothing" x := body x is [op,:argl] => - op = 'QUOTE => 'doNothing - op = 'where and argl is [before,after] => + op = "QUOTE" => "doNothing" + op = "where" and argl is [before,after] => -- in a where clause, what follows "where" (the "after" parm -- above) might be a local macro, so do not expand the "before" -- part yet @@ -160,23 +135,23 @@ mkAtree1 x == mkAtree2(x,op,argl) == nargl := #argl - (op= '_-) and (nargl = 1) and (INTEGERP CAR argl) => + (op= "-") and (nargl = 1) and (INTEGERP CAR argl) => mkAtree1(MINUS CAR argl) - op='_: and argl is [y,z] => [mkAtreeNode 'Declare,:argl] - op='COLLECT => [mkAtreeNode op,:transformCollect argl] - op= 'break => + op=":" and argl is [y,z] => [mkAtreeNode "Declare",:argl] + op="COLLECT" => [mkAtreeNode op,:transformCollect argl] + op= "break" => argl is [.,val] => if val = '$NoValue then val := '(void) [mkAtreeNode op,mkAtree1 val] [mkAtreeNode op,mkAtree1 '(void)] - op= 'return => + op= "return" => argl is [val] => if val = '$NoValue then val := '(void) [mkAtreeNode op,mkAtree1 val] [mkAtreeNode op,mkAtree1 '(void)] - op='exit => mkAtree1 CADR argl - op = 'QUOTE => [mkAtreeNode op,:argl] - op='SEGMENT => + op="exit" => mkAtree1 CADR argl + op = "QUOTE" => [mkAtreeNode op,:argl] + op="SEGMENT" => argl is [a] => [mkAtreeNode op, mkAtree1 a] z := null argl.1 => nil @@ -184,9 +159,9 @@ mkAtree2(x,op,argl) == [mkAtreeNode op, mkAtree1 argl.0,z] op in '(pretend is isnt) => [mkAtreeNode op,mkAtree1 first argl,:rest argl] - op = '_:_: => - [mkAtreeNode 'COERCE,mkAtree1 first argl,CADR argl] - x is ['_@, expr, type] => + op = "::" => + [mkAtreeNode "COERCE",mkAtree1 first argl,CADR argl] + x is ["@", expr, type] => t := evaluateType unabbrev type t = '(DoubleFloat) and expr is [['_$elt, '(Float), 'float], :args] => mkAtree1 [['_$elt, '(DoubleFloat), 'float], :args] @@ -199,18 +174,18 @@ mkAtree2(x,op,argl) == typeIsASmallInteger(t) and INTEGERP expr => mkAtree1 ["::", expr, t] [mkAtreeNode 'TARGET,mkAtree1 expr, type] - (op='case) and (nargl = 2) => - [mkAtreeNode 'case,mkAtree1 first argl,unabbrev CADR argl] - op='REPEAT => [mkAtreeNode op,:transformREPEAT argl] - op='LET and argl is [['construct,:.],rhs] => - [mkAtreeNode 'LET,first argl,mkAtree1 rhs] - op='LET and argl is [['_:,a,.],rhs] => - mkAtree1 ['SEQ,first argl,['LET,a,rhs]] + (op="case") and (nargl = 2) => + [mkAtreeNode "case",mkAtree1 first argl,unabbrev CADR argl] + op="REPEAT" => [mkAtreeNode op,:transformREPEAT argl] + op="LET" and argl is [['construct,:.],rhs] => + [mkAtreeNode "LET",first argl,mkAtree1 rhs] + op="LET" and argl is [[":",a,.],rhs] => + mkAtree1 ["SEQ",first argl,["LET",a,rhs]] op is ['_$elt,D,op1] => - op1 is '_= => + op1 is "=" => a' := [mkAtreeNode '_=,:[mkAtree1 arg for arg in argl]] - [mkAtreeNode 'Dollar,D,a'] - [mkAtreeNode 'Dollar,D,mkAtree1 [op1,:argl]] + [mkAtreeNode "Dollar",D,a'] + [mkAtreeNode "Dollar",D,mkAtree1 [op1,:argl]] op='_$elt => argl is [D,a] => INTEGERP a => @@ -222,20 +197,20 @@ mkAtree2(x,op,argl) == putValue(v,objNewWrap(a, t)) v mkAtree1 ["*",a,[['_$elt,D,'One]]] - [mkAtreeNode 'Dollar,D,mkAtree1 a] + [mkAtreeNode "Dollar",D,mkAtree1 a] keyedSystemError("S2II0003",['"$",argl, '"not qualifying an operator"]) mkAtree3(x,op,argl) mkAtree3(x,op,argl) == - op='REDUCE and argl is [op1,axis,body] => + op="REDUCE" and argl is [op1,axis,body] => [mkAtreeNode op,axis,mkAtree1 op1,mkAtree1 body] - op='has => [mkAtreeNode op, :argl] - op='_| => [mkAtreeNode 'AlgExtension,:[mkAtree1 arg for arg in argl]] - op='_= => [mkAtreeNode 'equation,:[mkAtree1 arg for arg in argl]] - op='not and argl is [["=",lhs,rhs]] => - [mkAtreeNode 'not,[mkAtreeNode "=",mkAtree1 lhs,mkAtree1 rhs]] - op='in and argl is [var ,['SEGMENT,lb,ul]] => + op="has" => [mkAtreeNode op, :argl] + op="|" => [mkAtreeNode "AlgExtension",:[mkAtree1 arg for arg in argl]] + op="=" => [mkAtreeNode "equation",:[mkAtree1 arg for arg in argl]] + op="not" and argl is [["=",lhs,rhs]] => + [mkAtreeNode "not",[mkAtreeNode "=",mkAtree1 lhs,mkAtree1 rhs]] + op="in" and argl is [var ,["SEGMENT",lb,ul]] => upTest:= null ul => NIL mkLessOrEqual(var,ul) @@ -244,13 +219,13 @@ mkAtree3(x,op,argl) == ul => ['and,lowTest,upTest] lowTest mkAtree1 z - x is ['IF,p,'noBranch,a] => mkAtree1 ['IF,['not,p],a,'noBranch] - x is ['RULEDEF,:.] => [mkAtreeNode 'RULEDEF,:CDR x] - x is ['MDEF,sym,junk1,junk2,val] => + x is ["IF",p,"noBranch",a] => mkAtree1 ["IF",["not",p],a,"noBranch"] + x is ["RULEDEF",:.] => [mkAtreeNode "RULEDEF",:CDR x] + x is ["MDEF",sym,junk1,junk2,val] => -- new macros look like macro f == or macro f(x) === -- so transform into that format - mkAtree1 ['DEF,['macro,sym],junk1,junk2,val] - x is ["~=",a,b] => mkAtree1 ['not,["=",a,b]] + mkAtree1 ["DEF",["macro",sym],junk1,junk2,val] + x is ["~=",a,b] => mkAtree1 ["not",["=",a,b]] x is ["+->",funargs,funbody] => if funbody is [":",body,type] then types := [type] @@ -258,7 +233,7 @@ mkAtree3(x,op,argl) == else types := [NIL] v := collectDefTypesAndPreds funargs types := [:types,:v.1] - [mkAtreeNode 'ADEF,[v.0,types,[NIL for a in types],funbody], + [mkAtreeNode "ADEF",[v.0,types,[NIL for a in types],funbody], if v.2 then v.2 else true, false] x is ['ADEF,arg,:r] => r := mkAtreeValueOf r @@ -269,19 +244,14 @@ mkAtree3(x,op,argl) == null rest arg => collectDefTypesAndPreds first arg collectDefTypesAndPreds arg [types,:r'] := r - at := [fn(x,y) for x in rest types for y in v.1] where - fn(a,b) == - a and b => - if a = b then a - else throwMessage '" double declaration of parameter" - a or b + at := [fn(x,y) for x in rest types for y in v.1] r := [[first types,:at],:r'] - [mkAtreeNode 'ADEF,[v.0,:r],if v.2 then v.2 else true,false] - x is ['where,before,after] => - [mkAtreeNode 'where,before,mkAtree1 after] - x is ['DEF,['macro,form],.,.,body] => - [mkAtreeNode 'MDEF,form,body] - x is ['DEF,a,:r] => + [mkAtreeNode "ADEF",[v.0,:r],if v.2 then v.2 else true,false] + x is ["where",before,after] => + [mkAtreeNode "where",before,mkAtree1 after] + x is ["DEF",["macro",form],.,.,body] => + [mkAtreeNode "MDEF",form,body] + x is ["DEF",a,:r] => r := mkAtreeValueOf r a is [op,:arg] => v := @@ -313,6 +283,12 @@ mkAtree3(x,op,argl) == atom op => mkAtreeNode op mkAtree1 op [z,:[mkAtree1 y for y in argl]] + where + fn(a,b) == + a and b => + if a = b then a + else throwMessage '" double declaration of parameter" + a or b collectDefTypesAndPreds args == -- given an arglist to a DEF-like form, this function returns @@ -329,11 +305,7 @@ collectDefTypesAndPreds args == types := [type] var is ["|",var',p] => vars := [var'] - pred := addPred(pred,p) where - addPred(old,new) == - null new => old - null old => new - ['and,old,new] + pred := addPred(pred,p) vars := [var] args is ["|",var,p] => pred := addPred(pred,p) @@ -356,211 +328,27 @@ collectDefTypesAndPreds args == types := [NIL] vars := [args] VECTOR(vars,types,pred) + where + addPred(old,new) == + null new => old + null old => new + ['and,old,new] mkAtreeValueOf l == -- scans for ['valueOf,atom] - not CONTAINED('valueOf,l) => l + not CONTAINED("valueOf",l) => l mkAtreeValueOf1 l mkAtreeValueOf1 l == null l or atom l or null rest l => l - l is ['valueOf,u] and IDENTP u => + l is ["valueOf",u] and IDENTP u => v := mkAtreeNode $immediateDataSymbol - putValue(v,get(u,'value,$InteractiveFrame) or + putValue(v,get(u,"value",$InteractiveFrame) or objNewWrap(u,['Variable,u])) v [mkAtreeValueOf1 x for x in l] -mkLessOrEqual(lhs,rhs) == ['not,['_<,rhs,lhs]] - -emptyAtree expr == - -- remove mode, value, and misc. info from attrib tree - VECP expr => - $immediateDataSymbol = expr.0 => nil - expr.1:= NIL - expr.2:= NIL - expr.3:= NIL - -- kill proplist too? - atom expr => nil - for e in expr repeat emptyAtree e - -unVectorize body == - -- transforms from an atree back into a tree - VECP body => - name := getUnname body - name ^= $immediateDataSymbol => name - objValUnwrap getValue body - atom body => body - body is [op,:argl] => - newOp:=unVectorize op - if newOp = 'SUCHTHAT then newOp := '_| - if newOp = 'COERCE then newOp := '_:_: - if newOp = 'Dollar then newOp := "$elt" - [newOp,:unVectorize argl] - systemErrorHere '"unVectorize" - - --- Stuffing and Getting Info - -putAtree(x,prop,val) == - x is [op,:.] => - -- only willing to add property if op is a vector - -- otherwise will be pushing to deeply into calling structure - if VECP op then putAtree(op,prop,val) - x - null VECP x => x -- just ignore it - n := QLASSQ(prop,'((mode . 1) (value . 2) (modeSet . 3))) - => x.n := val - x.4 := insertShortAlist(prop,val,x.4) - x - -getAtree(x,prop) == - x is [op,:.] => - -- only willing to get property if op is a vector - -- otherwise will be pushing to deeply into calling structure - VECP op => getAtree(op,prop) - NIL - null VECP x => NIL -- just ignore it - n:= QLASSQ(prop,'((mode . 1) (value . 2) (modeSet . 3))) - => x.n - QLASSQ(prop,x.4) - -putTarget(x, targ) == - -- want to put nil modes perhaps to clear old target - if targ = $EmptyMode then targ := nil - putAtree(x,'target,targ) - -getTarget(x) == getAtree(x,'target) - -insertShortAlist(prop,val,al) == - pair := QASSQ(prop,al) => - RPLACD(pair,val) - al - [[prop,:val],:al] - -transferPropsToNode(x,t) == - propList := getProplist(x,$env) - QLASSQ('Led,propList) or QLASSQ('Nud,propList) => nil - node := - VECP t => t - first t - for prop in '(mode localModemap value name generatedCode) - repeat transfer(x,node,prop) - where - transfer(x,node,prop) == - u := get(x,prop,$env) => putAtree(node,prop,u) - (not (x in $localVars)) and (u := get(x,prop,$e)) => - putAtree(node,prop,u) - if not getMode(t) and (am := get(x,'automode,$env)) then - putModeSet(t,[am]) - putMode(t,am) - t - -isLeaf x == atom x --may be a number or a vector - -getMode x == - x is [op,:.] => getMode op - VECP x => x.1 - m := getBasicMode x => m - keyedSystemError("S2II0001",[x]) - -putMode(x,y) == - x is [op,:.] => putMode(op,y) - null VECP x => keyedSystemError("S2II0001",[x]) - x.1 := y - -getValue x == - VECP x => x.2 - atom x => - t := getBasicObject x => t - keyedSystemError("S2II0001",[x]) - getValue first x - -putValue(x,y) == - x is [op,:.] => putValue(op,y) - null VECP x => keyedSystemError("S2II0001",[x]) - x.2 := y - -putValueValue(vec,val) == - putValue(vec,val) - vec - -getUnnameIfCan x == - VECP x => x.0 - x is [op,:.] => getUnnameIfCan op - atom x => x - nil - -getUnname x == - x is [op,:.] => getUnname op - getUnname1 x - -getUnname1 x == - VECP x => x.0 - null atom x => keyedSystemError("S2II0001",[x]) - x - -computedMode t == - getModeSet t is [m] => m - keyedSystemError("S2GE0016",['"computedMode",'"non-singleton modeset"]) - -putModeSet(x,y) == - x is [op,:.] => putModeSet(op,y) - not VECP x => keyedSystemError("S2II0001",[x]) - x.3 := y - y - -getModeOrFirstModeSetIfThere x == - x is [op,:.] => getModeOrFirstModeSetIfThere op - VECP x => - m := x.1 => m - val := x.2 => objMode val - y := x.aModeSet => - (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) => m - first y - NIL - m := getBasicMode x => m - NIL - -getModeSet x == - x and PAIRP x => getModeSet first x - VECP x => - y:= x.aModeSet => - (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) => - [m] - y - keyedSystemError("S2GE0016",['"getModeSet",'"no mode set"]) - m:= getBasicMode x => [m] - null atom x => getModeSet first x - keyedSystemError("S2GE0016",['"getModeSet", - '"not an attributed tree"]) - -getModeSetUseSubdomain x == - x and PAIRP x => getModeSetUseSubdomain first x - VECP(x) => - -- don't play subdomain games with retracted args - getAtree(x,'retracted) => getModeSet x - y := x.aModeSet => - (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) => - [m] - val := getValue x - (x.0 = $immediateDataSymbol) and (y = [$Integer]) => - val := objValUnwrap val - m := getBasicMode0(val,true) - x.2 := objNewWrap(val,m) - x.aModeSet := [m] - [m] - null val => y - isEqualOrSubDomain(objMode(val),$Integer) and - INTEGERP(f := objValUnwrap val) => - [getBasicMode0(f,true)] - y - keyedSystemError("S2GE0016", - ['"getModeSetUseSubomain",'"no mode set"]) - m := getBasicMode0(x,true) => [m] - null atom x => getModeSetUseSubdomain first x - keyedSystemError("S2GE0016", - ['"getModeSetUseSubomain",'"not an attributed tree"]) +mkLessOrEqual(lhs,rhs) == ["not",["<",rhs,lhs]] atree2EvaluatedTree x == atree2Tree1(x,true) @@ -682,44 +470,6 @@ addIntSymTabBinding(var,proplist,e is [[curContour,:.],:.]) == e ---% Source and position information - --- In the following, src is a string containing an original input line, --- line is the line number of the string within the source file, --- and col is the index within src of the start of the form represented --- by x. x is a VAT. - -putSrcPos(x, file, src, line, col) == - putAtree(x, 'srcAndPos, srcPos_New(file, src, line, col)) - -getSrcPos(x) == getAtree(x, 'srcAndPos) - -srcPosNew(file, src, line, col) == LIST2VEC [file, src, line, col] - -srcPosFile(sp) == - if sp then sp.0 else nil - -srcPosSource(sp) == - if sp then sp.1 else nil - -srcPosLine(sp) == - if sp then sp.2 else nil - -srcPosColumn(sp) == - if sp then sp.3 else nil - -srcPosDisplay(sp) == - null sp => nil - s := STRCONC('"_"", srcPosFile sp, '"_", line ", - STRINGIMAGE srcPosLine sp, '": ") - sayBrightly [s, srcPosSource sp] - col := srcPosColumn sp - dots := - col = 0 => '"" - fillerSpaces(col, '".") - sayBrightly [fillerSpaces(#s, '" "), dots, '"^"] - true - @ \eject \begin{thebibliography}{99} diff --git a/src/interp/i-map.boot.pamphlet b/src/interp/i-map.boot.pamphlet index b66f02b9..c64a4318 100644 --- a/src/interp/i-map.boot.pamphlet +++ b/src/interp/i-map.boot.pamphlet @@ -50,18 +50,21 @@ <<*>>= <<license>> +import '"i-object" +)package "BOOT" + --% User Function Creation and Analysis Code -SETANDFILEQ($mapTarget,nil) -SETANDFILEQ($mapReturnTypes,nil) -SETANDFILEQ($mapName,'noMapName) -SETANDFILEQ($mapThrowCount, 0) -- times a "return" occurs in map -SETANDFILEQ($compilingMap, NIL) -SETANDFILEQ($definingMap, NIL) +$mapTarget := nil +$mapReturnTypes := nil +$mapName := 'noMapName +$mapThrowCount := 0 -- times a "return" occurs in map +$compilingMap := NIL +$definingMap := NIL --% Generating internal names for functions -SETANDFILEQ($specialMapNameSuffix, NIL) +$specialMapNameSuffix := NIL makeInternalMapName(userName,numArgs,numMms,extraPart) == name := CONCAT('"*",STRINGIMAGE numArgs,'";", @@ -183,7 +186,7 @@ addMap(lhs,rhs,pred) == for x in argl for s in $FormalMapVariableList] argList:= [fn for x in formalArgList] where - fn == + fn() == if x is ["SUCHTHAT",s,p] then (predList:= [p,:predList]; x:= s) x mkMapAlias(op,argl) @@ -223,7 +226,7 @@ augmentMap(op,args,pred,body,oldMap) == deleteMap(op,pattern,map) == map is ["MAP",:tail] => - newMap:= ['MAP,:[x for x in tail | w]] where w == + newMap:= ['MAP,:[x for x in tail | w]] where w() == x is [=pattern,:replacement] => sayDroppingFunctions(op,[x]) true null rest newMap => nil @@ -244,7 +247,7 @@ getUserIdentifiersIn body == body is [op,:l] => argIdList:= "append"/[getUserIdentifiersIn y for y in l] bodyIdList := - CONSP op or not (GET(op,'Nud) or GET(op,'Led) or GET(op,'up))=> + CONSP op or not (GETL(op,'Nud) or GETL(op,'Led) or GETL(op,'up))=> NCONC(getUserIdentifiersIn op, argIdList) argIdList REMDUP bodyIdList @@ -384,7 +387,7 @@ clearDep1(x,toDoList,doneList,depList) == a:= ASSQ(x,depList) a => depList:= delete(a,depList) - toDoList:= setUnion(toDoList, + toDoList:= union(toDoList, setDifference(CDR a,doneList)) toDoList is [a,:res] => clearDep1(a,res,newDone,depList) 'done @@ -551,7 +554,7 @@ mkInterpFun(op,opName,argTypes) == getMode op isnt ['Mapping,:sig] => nil parms := [var for type in argTypes for var in $FormalMapVariableList] arglCode := ['LIST,:[argCode for type in argTypes - for argName in parms]] where argCode == + for argName in parms]] where argCode() == ['putValueValue,['mkAtreeNode,MKQ argName], objNewCode(['wrap,argName],type)] funName := GENSYM() @@ -567,7 +570,7 @@ rewriteMap(op,opName,argl) == get(opName,'mode,$e) isnt ['Mapping,:sig] => compFailure ['" Cannot compile map:",:bright opName] arglCode := ['LIST,:[argCode for arg in argl for argName in - $FormalMapVariableList]] where argCode == + $FormalMapVariableList]] where argCode() == ['putValueValue,['mkAtreeNode,MKQ argName], objNewCode(['wrap,wrapped2Quote(objVal getValue arg)], getMode arg)] diff --git a/src/interp/i-object.boot b/src/interp/i-object.boot index 0543e466..8443c55e 100644 --- a/src/interp/i-object.boot +++ b/src/interp/i-object.boot @@ -31,7 +31,7 @@ -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -import '"sys-macros" +import '"g-util" )package "BOOT" --% Functions on interpreter objects @@ -69,7 +69,7 @@ objCodeMode obj == CADR obj wrap x == isWrapped x => x - ['WRAPPED,:x] + ["WRAPPED",:x] isWrapped x == x is ['WRAPPED,:.] or NUMBERP x or FLOATP x or CVECP x @@ -83,7 +83,7 @@ wrapped2Quote x == x quote2Wrapped x == - x is ['QUOTE,y] => wrap y + x is ["QUOTE",y] => wrap y x removeQuote x == @@ -142,3 +142,270 @@ getBasicObject x == FLOATP x => objNewWrap(x,$DoubleFloat) NIL + +--%% Vectorized Attributed Trees + +--% The interpreter translates parse forms into vats for analysis. +--% These contain a number of slots in each node for information. +--% The leaves are now all vectors, though the leaves for basic types +--% such as integers and strings used to just be the objects themselves. +--% The vectors for the leaves with such constants now have the value +--% of $immediateDataSymbol as their name. Their are undoubtably still +--% some functions that still check whether a leaf is a constant. Note +--% that if it is not a vector it is a subtree. + +--% attributed tree nodes have the following form: +--% slot description +--% ---- ----------------------------------------------------- +--% 0 operation name or literal +--% 1 declared mode of variable +--% 2 computed value of subtree from this node +--% 3 modeset: list of single computed mode of subtree +--% 4 prop list for extra things + + +++ create a leaf VAT node. +mkAtreeNode x == + -- maker of attrib tree node + v := MAKE_-VEC 5 + v.0 := x + v + +++ remove mode, value, and misc. info from attrib tree +emptyAtree expr == + VECP expr => + $immediateDataSymbol = expr.0 => nil + expr.1:= NIL + expr.2:= NIL + expr.3:= NIL + -- kill proplist too? + atom expr => nil + for e in expr repeat emptyAtree e + + +++ returns true if x is a leaf VAT object. +isLeaf x == + atom x --may be a number or a vector + +++ returns the mode of the VAT node x. +getMode x == + x is [op,:.] => getMode op + VECP x => x.1 + m := getBasicMode x => m + keyedSystemError("S2II0001",[x]) + +++ sets the mode for the VAT node x to y. +putMode(x,y) == + x is [op,:.] => putMode(op,y) + null VECP x => keyedSystemError("S2II0001",[x]) + x.1 := y + +++ returns an interpreter object that represents the value of node x. +++ Note that an interpreter object is a pair of mode and value. +getValue x == + VECP x => x.2 + atom x => + t := getBasicObject x => t + keyedSystemError("S2II0001",[x]) + getValue first x + +++ sets the value of VAT node x to interpreter object y. +putValue(x,y) == + x is [op,:.] => putValue(op,y) + null VECP x => keyedSystemError("S2II0001",[x]) + x.2 := y + +++ same as putValue(vec, val), except that vec is returned instead of val. +putValueValue(vec,val) == + putValue(vec,val) + vec + +++ Returns the node class of x, if possible; otherwise nil. +getUnnameIfCan x == + VECP x => x.0 + x is [op,:.] => getUnnameIfCan op + atom x => x + nil + +++ Returns the node class of x; otherwise raise an error. +getUnname x == + x is [op,:.] => getUnname op + getUnname1 x + +++ Subroutine of getUnname. +getUnname1 x == + VECP x => x.0 + null atom x => keyedSystemError("S2II0001",[x]) + x + +++ returns the mode-set of VAT node x. +getModeSet x == + x and PAIRP x => getModeSet first x + VECP x => + y:= x.aModeSet => + (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) => + [m] + y + keyedSystemError("S2GE0016",['"getModeSet",'"no mode set"]) + m:= getBasicMode x => [m] + not atom x => getModeSet first x + keyedSystemError("S2GE0016",['"getModeSet", + '"not an attributed tree"]) + +++ Sets the mode-set of VAT node x to y. +putModeSet(x,y) == + x is [op,:.] => putModeSet(op,y) + not VECP x => keyedSystemError("S2II0001",[x]) + x.3 := y + y + +getModeOrFirstModeSetIfThere x == + x is [op,:.] => getModeOrFirstModeSetIfThere op + VECP x => + m := x.1 => m + val := x.2 => objMode val + y := x.aModeSet => + (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) => m + first y + NIL + m := getBasicMode x => m + NIL + +getModeSetUseSubdomain x == + x and PAIRP x => getModeSetUseSubdomain first x + VECP(x) => + -- don't play subdomain games with retracted args + getAtree(x,'retracted) => getModeSet x + y := x.aModeSet => + (y = [$EmptyMode]) and ((m := getMode x) is ['Mapping,:.]) => + [m] + val := getValue x + (x.0 = $immediateDataSymbol) and (y = [$Integer]) => + val := objValUnwrap val + m := getBasicMode0(val,true) + x.2 := objNewWrap(val,m) + x.aModeSet := [m] + [m] + null val => y + isEqualOrSubDomain(objMode(val),$Integer) and + INTEGERP(f := objValUnwrap val) => + [getBasicMode0(f,true)] + y + keyedSystemError("S2GE0016", + ['"getModeSetUseSubomain",'"no mode set"]) + m := getBasicMode0(x,true) => [m] + null atom x => getModeSetUseSubdomain first x + keyedSystemError("S2GE0016", + ['"getModeSetUseSubomain",'"not an attributed tree"]) + + +computedMode t == + getModeSet t is [m] => m + keyedSystemError("S2GE0016",['"computedMode",'"non-singleton modeset"]) + +--% Other VAT properties + +insertShortAlist(prop,val,al) == + pair := QASSQ(prop,al) => + RPLACD(pair,val) + al + [[prop,:val],:al] + +putAtree(x,prop,val) == + x is [op,:.] => + -- only willing to add property if op is a vector + -- otherwise will be pushing to deeply into calling structure + if VECP op then putAtree(op,prop,val) + x + null VECP x => x -- just ignore it + n := QLASSQ(prop,'((mode . 1) (value . 2) (modeSet . 3))) + => x.n := val + x.4 := insertShortAlist(prop,val,x.4) + x + +getAtree(x,prop) == + x is [op,:.] => + -- only willing to get property if op is a vector + -- otherwise will be pushing to deeply into calling structure + VECP op => getAtree(op,prop) + NIL + null VECP x => NIL -- just ignore it + n:= QLASSQ(prop,'((mode . 1) (value . 2) (modeSet . 3))) + => x.n + QLASSQ(prop,x.4) + +putTarget(x, targ) == + -- want to put nil modes perhaps to clear old target + if targ = $EmptyMode then targ := nil + putAtree(x,'target,targ) + +getTarget(x) == + getAtree(x,'target) + +--% Source and position information + +-- In the following, src is a string containing an original input line, +-- line is the line number of the string within the source file, +-- and col is the index within src of the start of the form represented +-- by x. x is a VAT. + +++ returns source position information for VAT node x. +getSrcPos(x) == + getAtree(x, 'srcAndPos) + +++ sets the source location information for VAT node x. +putSrcPos(x, file, src, line, col) == + putAtree(x, 'srcAndPos, srcPos_New(file, src, line, col)) + +srcPosNew(file, src, line, col) == + LIST2VEC [file, src, line, col] + +++ returns the name of source file for source location `sp'. +srcPosFile(sp) == + if sp then sp.0 else nil + +++ returns the input source string for source location `sp'. +srcPosSource(sp) == + if sp then sp.1 else nil + +++ returns the line number for source location `sp'. +srcPosLine(sp) == + if sp then sp.2 else nil + +++ returns the column number for source location `sp'. +srcPosColumn(sp) == + if sp then sp.3 else nil + +srcPosDisplay(sp) == + null sp => nil + s := STRCONC('"_"", srcPosFile sp, '"_", line ", + STRINGIMAGE srcPosLine sp, '": ") + sayBrightly [s, srcPosSource sp] + col := srcPosColumn sp + dots := + col = 0 => '"" + fillerSpaces(col, '".") + sayBrightly [fillerSpaces(#s, '" "), dots, '"^"] + true + + +--% Transfer of VAT properties. + + +transferPropsToNode(x,t) == + propList := getProplist(x,$env) + QLASSQ('Led,propList) or QLASSQ('Nud,propList) => nil + node := + VECP t => t + first t + for prop in '(mode localModemap value name generatedCode) + repeat transfer(x,node,prop) + where + transfer(x,node,prop) == + u := get(x,prop,$env) => putAtree(node,prop,u) + (not (x in $localVars)) and (u := get(x,prop,$e)) => + putAtree(node,prop,u) + if not getMode(t) and (am := get(x,'automode,$env)) then + putModeSet(t,[am]) + putMode(t,am) + t diff --git a/src/interp/i-output.boot b/src/interp/i-output.boot index e2c83fd9..833f070f 100644 --- a/src/interp/i-output.boot +++ b/src/interp/i-output.boot @@ -335,9 +335,9 @@ outputTran x == x is ['MAP,:l] => outputMapTran l x is ['brace, :l] => ['BRACE, ['AGGLST,:[outputTran y for y in l]]] - x is ['return,l] => ['return,outputTran l] - x is ['return,.,:l] => ['return,:outputTran l] - x is ['construct,:l] => + x is ["return",l] => ["return",outputTran l] + x is ["return",.,:l] => ["return",:outputTran l] + x is ["construct",:l] => ['BRACKET,['AGGLST,:[outputTran y for y in l]]] x is [["$elt",domain,"float"], x, y, z] and (domain = $DoubleFloat or @@ -963,11 +963,11 @@ maprin0 x == maprinChk x == null $MatrixList => maPrin x - ATOM x and (u:= ASSOC(x,$MatrixList)) => + ATOM x and (u:= assoc(x,$MatrixList)) => $MatrixList := delete(u,$MatrixList) maPrin deMatrix CDR u x is ["=",arg,y] => --case for tracing with )math and printing matrices - u:=ASSOC(y,$MatrixList) => + u:=assoc(y,$MatrixList) => -- we don't want to print matrix1 = matrix2 ... $MatrixList := delete(u,$MatrixList) maPrin ["=",arg, deMatrix CDR u] @@ -981,7 +981,7 @@ maprinChk x == -- m:=[[1,2,3],[4,5,6],[7,8,9]] -- mm:=[[m,1,0],[0,m,1],[0,1,m]] -- and try to print mm**5 - u := ASSOC(y,$MatrixList) + u := assoc(y,$MatrixList) --$MatrixList := deleteAssoc(first u,$MatrixList) -- deleteAssoc no longer exists $MatrixList := delete(u,$MatrixList) @@ -1556,8 +1556,8 @@ charyTrouble1(u,v,start,linelength) == d := GETL(x,'INFIXOP) => charyBinary(d,u,v,start,linelength) x = 'OVER => charyBinary(GETL("/",'INFIXOP),u,v,start,linelength) - EQ(3,LENGTH u) and GET(x,'Led) => - d:= PNAME first GET(x,'Led) + EQ(3,LENGTH u) and GETL(x,'Led) => + d:= PNAME first GETL(x,'Led) charyBinary(d,u,v,start,linelength) EQ(x,'CONCAT) => concatTrouble(rest v,d,start,linelength,nil) @@ -2199,7 +2199,7 @@ qTWidth(u) == remWidth(x) == atom x => x true => CONS( (atom first x => first x; true => CAAR x), - MMAPCAR(remWidth, rest x) ) + MMAPCAR(function remWidth, rest x) ) subSub(u) == height CDDR u diff --git a/src/interp/i-resolv.boot.pamphlet b/src/interp/i-resolv.boot.pamphlet index fd46a0e6..a9c2e362 100644 --- a/src/interp/i-resolv.boot.pamphlet +++ b/src/interp/i-resolv.boot.pamphlet @@ -87,6 +87,9 @@ this symmetric resolution is done the following way: <<*>>= <<license>> +import '"i-object" +)package "BOOT" + resolveTypeList u == u is [a,:tail] => @@ -391,7 +394,7 @@ resolveTTRed3(t) == t is ['SetUnion,a,b] => union(a,b) t is ['VarEqual,a,b] => (a = b) and a t is ['SetEqual,a,b] => - (and/[member(x,a) for x in b] and and/[member(x,b) for x in a]) and a + (and/[member(x,a) for x in b] and "and"/[member(x,b) for x in a]) and a [( atom x and x ) or ((not cs and x and not interpOp? x and x) or resolveTTRed3 x) or return NIL for x in t for cs in GETDATABASE(CAR t, 'COSIG) ] @@ -442,7 +445,7 @@ resolveTCat1(t,c) == null (conds := getConditionsForCategoryOnType(t,c)) => NIL --rest(conds) => NIL -- will handle later cond := first conds - cond isnt [.,['has, pat, c1],:.] => NIL + cond isnt [.,["has", pat, c1],:.] => NIL rest(c1) => NIL -- make it simple argN := 0 @@ -498,7 +501,7 @@ matchUpToPatternVars(pat,form,patAlist) == EQUAL(pat,form) => true isSharpVarWithNum(pat) => -- see is pattern variable is in alist - (p := ASSOC(pat,patAlist)) => EQUAL(form,CDR p) + (p := assoc(pat,patAlist)) => EQUAL(form,CDR p) patAlist := [[pat,:form],:patAlist] true PAIRP(pat) => @@ -738,12 +741,12 @@ resolveTMRed1(t) == resolveTM1(a,b) t is ['Incl,a,b] => PAIRP b and member(a,b) and b t is ['Diff,a,b] => PAIRP a and member(b,a) and SETDIFFERENCE(a,[b]) - t is ['SetIncl,a,b] => PAIRP b and and/[member(x,b) for x in a] and b + t is ['SetIncl,a,b] => PAIRP b and "and"/[member(x,b) for x in a] and b t is ['SetDiff,a,b] => PAIRP b and PAIRP b and intersection(a,b) and SETDIFFERENCE(a,b) t is ['VarEqual,a,b] => (a = b) and b t is ['SetComp,a,b] => PAIRP a and PAIRP b and - and/[member(x,a) for x in b] and SETDIFFERENCE(a,b) + "and"/[member(x,a) for x in b] and SETDIFFERENCE(a,b) t is ['SimpleAlgebraicExtension,a,b,p] => -- this is a hack. RSS ['SimpleAlgebraicExtension, resolveTMRed1 a, resolveTMRed1 b,p] [( atom x and x ) or resolveTMRed1 x or return NIL for x in t] diff --git a/src/interp/i-spec1.boot.pamphlet b/src/interp/i-spec1.boot.pamphlet index 8175bc6a..2e178fe0 100644 --- a/src/interp/i-spec1.boot.pamphlet +++ b/src/interp/i-spec1.boot.pamphlet @@ -89,17 +89,20 @@ There are several special modes used in these functions: <<*>>= <<license>> +import '"i-analy" +)package "BOOT" + -- Functions which require special handlers (also see end of file) -SETANDFILEQ($repeatLabel, NIL) -SETANDFILEQ($breakCount, 0) -SETANDFILEQ($anonymousMapCounter, 0) +$repeatLabel := NIL +$breakCount := 0 +$anonymousMapCounter := 0 -SETANDFILEQ($specialOps, '( - ADEF AlgExtension and case COERCE COLLECT construct Declare DEF Dollar - equation error free has IF is isnt iterate break LET local MDEF or - pretend QUOTE REDUCE REPEAT return SEQ TARGET Tuple typeOf where )) +$specialOps := '( + ADEF AlgExtension _and _case COERCE COLLECT construct Declare DEF Dollar + equation error free has IF _is _isnt iterate _break LET _local MDEF _or + pretend QUOTE REDUCE REPEAT _return SEQ TARGET Tuple typeOf _where ) --% Void stuff @@ -185,9 +188,9 @@ mkInterpTargetedADEF(t,vars,types,oldBody) == null first types => throwKeyedMsg("S2IS0056",NIL) throwMessage '" map result type needed but not present." - arglCode := ['LIST,:[argCode for type in rest types for var in vars]] - where argCode == ['putValueValue,['mkAtreeNode,MKQ var], - objNewCode(['wrap,var],type)] + arglCode := ["LIST",:[argCode for type in rest types for var in vars]] + where argCode() == ['putValueValue,['mkAtreeNode,MKQ var], + objNewCode(["wrap",var],type)] put($mapName,'mapBody,oldBody,$e) body := ['rewriteMap1,MKQ $mapName,arglCode,MKQ types] compileADEFBody(t,vars,types,body,first types) @@ -227,7 +230,7 @@ compileADEFBody(t,vars,types,body,computedResultType) == -- -- MCD 13/3/96 if not $definingMap and ($genValue or $compilingMap) then - fun := ['function,['LAMBDA,[:vars,'envArg],body]] + fun := ["function",["LAMBDA",[:vars,'envArg],body]] code := wrap timedEVALFUN ['LIST,fun] else $freeVariables := [] @@ -235,8 +238,8 @@ compileADEFBody(t,vars,types,body,computedResultType) == -- CCL does not support upwards funargs, so we check for any free variables -- and pass them into the lambda as part of envArg. body := checkForFreeVariables(body,"ALL") - fun := ['function,['LAMBDA,[:vars,'envArg],body]] - code := ['CONS, fun, ["VECTOR", :reverse $freeVariables]] + fun := ["function",["LAMBDA",[:vars,'envArg],body]] + code := ["CONS", fun, ["VECTOR", :reverse $freeVariables]] val := objNew(code,rt := ['Mapping,computedResultType,:rest types]) putValue(t,val) @@ -316,9 +319,9 @@ upand x == ms := bottomUp term2 ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"and_""],term2) -- generate an IF expression and let the rest of the code handle it - cond := [mkAtreeNode "=",mkAtree 'false,term1] + cond := [mkAtreeNode "=",mkAtree "false",term1] putTarget(cond,$Boolean) - code := [mkAtreeNode 'IF,cond,mkAtree 'false,term2] + code := [mkAtreeNode "IF",cond,mkAtree "false",term2] putTarget(code,$Boolean) bottomUp code putValue(x,getValue code) @@ -346,9 +349,9 @@ upor x == ms := bottomUp term2 ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"or_""],term2) -- generate an IF expression and let the rest of the code handle it - cond := [mkAtreeNode "=",mkAtree 'true,term1] + cond := [mkAtreeNode "=",mkAtree "true",term1] putTarget(cond,$Boolean) - code := [mkAtreeNode 'IF,cond,mkAtree 'true,term2] + code := [mkAtreeNode "IF",cond,mkAtree "true",term2] putTarget(code,$Boolean) bottomUp code putValue(x,getValue code) @@ -363,16 +366,16 @@ upcase t == objMode(triple) isnt ['Union,:unionDoms] => throwKeyedMsg("S2IS0004",NIL) if (rhs' := isDomainValuedVariable(rhs)) then rhs := rhs' - if first unionDoms is ['_:,.,.] then + if first unionDoms is [":",.,.] then for i in 0.. for d in unionDoms repeat - if d is ['_:,=rhs,.] then rhstag := i - if NULL rhstag then error "upcase: bad Union form" + if d is [":",=rhs,.] then rhstag := i + if NULL rhstag then error '"upcase: bad Union form" $genValue => rhstag = first unwrap objVal triple => code := wrap 'TRUE code := wrap NIL code := - ['COND, - [['EQL,rhstag,['CAR,['unwrap,objVal triple]]], + ["COND", + [["EQL",rhstag,["CAR",["unwrap",objVal triple]]], ''TRUE], [''T,NIL]] else @@ -380,10 +383,10 @@ upcase t == t' := coerceUnion2Branch triple rhs = objMode t' => code := wrap 'TRUE code := wrap NIL - triple' := objNewCode(['wrap,objVal triple],objMode triple) + triple' := objNewCode(["wrap",objVal triple],objMode triple) code := - ['COND, - [['EQUAL,MKQ rhs,['objMode,['coerceUnion2Branch,triple']]], + ["COND", + [["EQUAL",MKQ rhs,["objMode",['coerceUnion2Branch,triple']]], ''TRUE], [''T,NIL]] putValue(op,objNew(code,$Boolean)) @@ -463,29 +466,29 @@ evalCOERCE(op,tree,m) == transformCollect [:itrl,body] == -- syntactic transformation for COLLECT form, called from mkAtree1 - iterList:=[:iterTran1 for it in itrl] where iterTran1 == - it is ['STEP,index,lower,step,:upperList] => - [['STEP,index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper + iterList:=[:iterTran1 for it in itrl] where iterTran1() == + it is ["STEP",index,lower,step,:upperList] => + [["STEP",index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper for upper in upperList]]] - it is ['IN,index,s] => - [['IN,index,mkAtree1 s]] - it is ['ON,index,s] => + it is ["IN",index,s] => + [["IN",index,mkAtree1 s]] + it is ["ON",index,s] => [['IN,index,mkAtree1 ['tails,s]]] - it is ['WHILE,b] => - [['WHILE,mkAtree1 b]] - it is ['_|,pred] => - [['SUCHTHAT,mkAtree1 pred]] + it is ["WHILE",b] => + [["WHILE",mkAtree1 b]] + it is ["|",pred] => + [["SUCHTHAT",mkAtree1 pred]] it is [op,:.] and (op in '(VALUE UNTIL)) => nil bodyTree:=mkAtree1 body iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where - iterTran2 == - it is ['STEP,:.] => nil - it is ['IN,:.] => nil - it is ['ON,:.] => nil - it is ['WHILE,:.] => nil + iterTran2() == + it is ["STEP",:.] => nil + it is ["IN",:.] => nil + it is ["ON",:.] => nil + it is ["WHILE",:.] => nil it is [op,b] and (op in '(UNTIL)) => [[op,mkAtree1 b]] - it is ['_|,pred] => nil + it is ["|",pred] => nil keyedSystemError("S2GE0016", ['"transformCollect",'"Unknown type of iterator"]) [:iterList,bodyTree] @@ -515,7 +518,7 @@ upCOLLECT1 t == ms:= bottomUpCompile body [m]:= ms for itr in itrl repeat - itr is ['UNTIL, pred] => bottomUpCompilePredicate(pred,'"until") + itr is ["UNTIL", pred] => bottomUpCompilePredicate(pred,'"until") mode:= ['Tuple,m] evalCOLLECT(op,rest t,mode) putModeSet(op,[mode]) @@ -523,15 +526,15 @@ upCOLLECT1 t == upLoopIters itrl == -- type analyze iterator loop iterators for iter in itrl repeat - iter is ['WHILE,pred] => + iter is ["WHILE",pred] => bottomUpCompilePredicate(pred,'"while") - iter is ['SUCHTHAT,pred] => + iter is ["SUCHTHAT",pred] => bottomUpCompilePredicate(pred,'"|") - iter is ['UNTIL,:.] => + iter is ["UNTIL",:.] => NIL -- handle after body is analyzed - iter is ['IN,index,s] => + iter is ["IN",index,s] => upLoopIterIN(iter,index,s) - iter is ['STEP,index,lower,step,:upperList] => + iter is ["STEP",index,lower,step,:upperList] => upLoopIterSTEP(index,lower,step,upperList) -- following is an optimization typeIsASmallInteger(get(index,'mode,$env)) => @@ -985,10 +988,10 @@ subVecNodes(new,old,form) == mkIterVarSub(var,numVars) == n := iterVarPos var n=2 => - [mkAtreeNode 'elt,mkNestedElts(numVars-2),mkAtreeNode 'part2] + [mkAtreeNode "elt",mkNestedElts(numVars-2),mkAtreeNode 'part2] n=1 => - [mkAtreeNode 'elt,mkNestedElts(numVars-2),mkAtreeNode 'part1] - [mkAtreeNode 'elt,mkNestedElts(numVars-n),mkAtreeNode 'part1] + [mkAtreeNode "elt",mkNestedElts(numVars-2),mkAtreeNode 'part1] + [mkAtreeNode "elt",mkNestedElts(numVars-n),mkAtreeNode 'part1] iterVarPos var == for [index,:.] in reverse $indexVars for i in 1.. repeat @@ -996,7 +999,7 @@ iterVarPos var == mkNestedElts n == n=0 => mkAtreeNode($index or ($index:= GENSYM())) - [mkAtreeNode 'elt, mkNestedElts(n-1), mkAtreeNode 'part2] + [mkAtreeNode "elt", mkNestedElts(n-1), mkAtreeNode 'part2] --% Handlers for construct @@ -1135,8 +1138,8 @@ upRecordConstruct(op,l,tar) == for arg in l for ['_:,.,type] in types] len := #l code := - (len = 1) => ['CONS, :argCode, '()] - (len = 2) => ['CONS,:argCode] + (len = 1) => ["CONS", :argCode, '()] + (len = 2) => ["CONS",:argCode] ['VECTOR,:argCode] if $genValue then code := wrap timedEVALFUN code putValue(op,objNew(code,tar)) @@ -1154,13 +1157,13 @@ upDeclare t == categoryForm?(mode) => throwKeyedMsgSP("S2IE0011",[mode, 'category],op) packageForm?(mode) => throwKeyedMsgSP("S2IE0011",[mode, 'package],op) junk := - lhs is ['free,['Tuple,:vars]] or lhs is ['free,['LISTOF,:vars]] or - lhs is ['free,:vars] => + lhs is ["free",['Tuple,:vars]] or lhs is ['free,['LISTOF,:vars]] or + lhs is ["free",:vars] => for var in vars repeat declare(['free,var],mode) - lhs is ['local,['Tuple,:vars]] or lhs is ['local,['LISTOF,:vars]] or - lhs is ['local,:vars] => - for var in vars repeat declare(['local,var],mode) - lhs is ['Tuple,:vars] or lhs is ['LISTOF,:vars] => + lhs is ["local",['Tuple,:vars]] or lhs is ['local,['LISTOF,:vars]] or + lhs is ["local",:vars] => + for var in vars repeat declare(["local",var],mode) + lhs is ["Tuple",:vars] or lhs is ["LISTOF",:vars] => for var in vars repeat declare(var,mode) declare(lhs,mode) putValue(op,objNewWrap(voidValue(), $Void)) diff --git a/src/interp/i-spec2.boot.pamphlet b/src/interp/i-spec2.boot.pamphlet index 8b16f053..8d57009a 100644 --- a/src/interp/i-spec2.boot.pamphlet +++ b/src/interp/i-spec2.boot.pamphlet @@ -89,6 +89,9 @@ There are several special modes used in these functions: <<*>>= <<license>> +import '"i-spec1" +)package "BOOT" + -- Functions which require special handlers (also see end of file) --% Handlers for map definitions @@ -96,7 +99,7 @@ There are several special modes used in these functions: upDEF t == -- performs map definitions. value is thrown away t isnt [op,def,pred,.] => nil - v:=addDefMap(['DEF,:def],pred) + v:=addDefMap(["DEF",:def],pred) null(LISTP(def)) or null(def) => keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"]) mapOp := first def @@ -104,7 +107,7 @@ upDEF t == null mapOp => keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"]) mapOp := first mapOp - put(mapOp,'value,v,$e) + put(mapOp,"value",v,$e) putValue(op,objNew(voidValue(), $Void)) putModeSet(op,[$Void]) @@ -114,9 +117,9 @@ upDollar t == -- Puts "dollar" property in atree node, and calls bottom up t isnt [op,D,form] => nil t2 := t - (not $genValue) and or/[CONTAINED(var,D) for var in $localVars] => + (not $genValue) and "or"/[CONTAINED(var,D) for var in $localVars] => keyedMsgCompFailure("S2IS0032",NIL) - EQ(D,'Lisp) => upLispCall(op,form) + EQ(D,"Lisp") => upLispCall(op,form) if VECP D and (SIZE(D) > 0) then D := D.0 t := evaluateType unabbrev D categoryForm? t => @@ -131,7 +134,7 @@ upDollar t == isPartialMode t => throwKeyedMsg("S2IS0020",NIL) if $genValue then val := wrap getConstantFromDomain([f],t) - else val := ['getConstantFromDomain,['LIST,MKQ f],MKQ t] + else val := ["getConstantFromDomain",["LIST",MKQ f],MKQ t] putValue(op,objNew(val,t)) putModeSet(op,[t]) @@ -139,12 +142,12 @@ upDollar t == (ms := upDollarTuple(op, f, t, t2, rest form, nargs)) => ms - f ^= 'construct and null isOpInDomain(f,t,nargs) => + f ^= "construct" and null isOpInDomain(f,t,nargs) => throwKeyedMsg("S2IS0023",[f,t]) if (sig := findCommonSigInDomain(f,t,nargs)) then for x in sig for y in form repeat if x then putTarget(y,x) - putAtree(first form,'dollar,t) + putAtree(first form,"dollar",t) ms := bottomUp form f in '(One Zero) and PAIRP(ms) and CAR(ms) = $OutputForm => throwKeyedMsg("S2IS0021",[f,t]) @@ -167,7 +170,7 @@ upDollarTuple(op, f, t, t2, args, nargs) == ms := bottomUp newArg first ms ^= tuple => NIL form := [first form, newArg] - putAtree(first form,'dollar,t) + putAtree(first form,"dollar",t) ms := bottomUp form putValue(op,getValue first form) putModeSet(op,ms) @@ -236,13 +239,13 @@ uphas t == t isnt [op,type,prop] => nil -- handler for category and attribute queries type := - isLocalVar(type) => ['unabbrev, type] + isLocalVar(type) => ["unabbrev", type] MKQ unabbrev type catCode := prop := unabbrev prop - evaluateType0 prop => ['evaluateType, MKQ prop] + evaluateType0 prop => ["evaluateType", MKQ prop] MKQ prop - code:=['newHasTest,['evaluateType, type], catCode] + code:=["newHasTest",["evaluateType", type], catCode] if $genValue then code := wrap timedEVALFUN code putValue(op,objNew(code,$Boolean)) putModeSet(op,[$Boolean]) @@ -263,10 +266,10 @@ compileIF(op,cond,a,b,t) == -- IF are resolved. ms1 := bottomUp a [m1] := ms1 - b = 'noBranch => + b = "noBranch" => evalIF(op,rest t,$Void) putModeSet(op,[$Void]) - b = 'noMapVal => + b = "noMapVal" => -- if this was a return statement, we take the mode to be that -- of what is being returned. if getUnname a = 'return then @@ -280,9 +283,9 @@ compileIF(op,cond,a,b,t) == m2=m1 => m1 m2 = $Exit => m1 m1 = $Exit => m2 - if EQCAR(m1,'Symbol) then + if EQCAR(m1,"Symbol") then m1:=getMinimalVarMode(getUnname a,$declaredMode) - if EQCAR(m2,'Symbol) then + if EQCAR(m2,"Symbol") then m2:=getMinimalVarMode(getUnname b,$declaredMode) (r := resolveTTAny(m2,m1)) => r rempropI($mapName,'localModemap) @@ -295,14 +298,14 @@ compileIF(op,cond,a,b,t) == evalIF(op,[cond,a,b],m) == -- generate code form compiled IF elseCode:= - b='noMapVal => - [[MKQ true, ['throwKeyedMsg,MKQ "S2IM0018", - ['CONS,MKQ object2Identifier $mapName,NIL]]]] + b="noMapVal" => + [[MKQ true, ["throwKeyedMsg",MKQ "S2IM0018", + ["CONS",MKQ object2Identifier $mapName,NIL]]]] b='noBranch => - $lastLineInSEQ => [[MKQ true,['voidValue]]] + $lastLineInSEQ => [[MKQ true,["voidValue"]]] NIL [[MKQ true,genIFvalCode(b,m)]] - code:=['COND,[getArgValue(cond,$Boolean), + code:=["COND",[getArgValue(cond,$Boolean), genIFvalCode(a,m)],:elseCode] triple:= objNew(code,m) putValue(op,triple) @@ -318,9 +321,9 @@ genIFvalCode(t,m) == IFcodeTran(code,m,m1) == -- coerces values at branches of IF null code => code - code is ['spadThrowBrightly,:.] => code + code is ["spadThrowBrightly",:.] => code m1 = $Exit => code - code isnt ['COND,[p1,a1],[''T,a2]] => + code isnt ["COND",[p1,a1],[''T,a2]] => m = $Void => code code' := coerceInteractive(objNew(quote2Wrapped code,m1),m) => wrapped2Quote objVal code' @@ -335,7 +338,7 @@ interpIF(op,cond,a,b) == val:= getValue cond val:= coerceInteractive(val,$Boolean) => objValUnwrap(val) => upIFgenValue(op,a) - EQ(b,'noBranch) => + EQ(b,"noBranch") => putValue(op,objNew(voidValue(), $Void)) putModeSet(op,[$Void]) upIFgenValue(op,b) @@ -371,13 +374,13 @@ upisAndIsnt(t:=[op,a,pattern]) == putPvarModes(pattern,m) == -- Puts the modes for the pattern variables into $env - m isnt ['List,um] => throwKeyedMsg("S2IS0030",NIL) + m isnt ["List",um] => throwKeyedMsg("S2IS0030",NIL) for pvar in pattern repeat IDENTP pvar => (null (pvar=$quadSymbol)) and put(pvar,'mode,um,$env) pvar is ['_:,var] => - null (var=$quadSymbol) and put(var,'mode,m,$env) + null (var=$quadSymbol) and put(var,"mode",m,$env) pvar is ['_=,var] => - null (var=$quadSymbol) and put(var,'mode,um,$env) + null (var=$quadSymbol) and put(var,"mode",um,$env) putPvarModes(pvar,um) evalis(op,[a,pattern],mode) == @@ -398,8 +401,8 @@ isLocalPred pattern == -- returns true if the is predicate is to be compiled for pat in pattern repeat IDENTP pat and isLocalVar(pat) => return true - pat is ['_:,var] and isLocalVar(var) => return true - pat is ['_=,var] and isLocalVar(var) => return true + pat is [":",var] and isLocalVar(var) => return true + pat is ["=",var] and isLocalVar(var) => return true compileIs(val,pattern) == -- produce code for compiled "is" predicate. makes pattern variables @@ -407,15 +410,15 @@ compileIs(val,pattern) == vars:= NIL for pat in CDR pattern repeat IDENTP(pat) and isLocalVar(pat) => vars:=[pat,:vars] - pat is ['_:,var] => vars:= [var,:vars] - pat is ['_=,var] => vars:= [var,:vars] - predCode:=['LET,g:=GENSYM(),['isPatternMatch, + pat is [":",var] => vars:= [var,:vars] + pat is ["=",var] => vars:= [var,:vars] + predCode:=["LET",g:=GENSYM(),["isPatternMatch", getArgValue(val,computedMode val),MKQ removeConstruct pattern]] for var in REMDUP vars repeat - assignCode:=[['LET,var,['CDR,['ASSQ,MKQ var,g]]],:assignCode] + assignCode:=[["LET",var,["CDR",["ASSQ",MKQ var,g]]],:assignCode] null $opIsIs => - ['COND,[['EQ,predCode,MKQ 'failed],['SEQ,:assignCode,MKQ 'T]]] - ['COND,[['NOT,['EQ,predCode,MKQ 'failed]],['SEQ,:assignCode,MKQ 'T]]] + ["COND",[["EQ",predCode,MKQ "failed"],["SEQ",:assignCode,MKQ 'T]]] + ["COND",[["NOT",["EQ",predCode,MKQ "failed"]],["SEQ",:assignCode,MKQ 'T]]] evalIsPredicate(value,pattern,mode) == --This function pattern matches value to pattern, and returns @@ -435,8 +438,8 @@ evalIsntPredicate(value,pattern,mode) == removeConstruct pat == -- removes the "construct" from the beginning of patterns - if pat is ['construct,:p] then pat:=p - if pat is ['cons, a, b] then pat := [a, ['_:, b]] + if pat is ["construct",:p] then pat:=p + if pat is ["cons", a, b] then pat := [a, [":", b]] atom pat => pat RPLACA(pat,removeConstruct CAR pat) RPLACD(pat,removeConstruct CDR pat) @@ -454,26 +457,26 @@ isPatMatch(l,pats) == $subs:='failed null l => null pats => $subs - pats is [['_:,var]] => + pats is [[":",var]] => $subs := [[var],:$subs] $subs:='failed pats is [pat,:restPats] => IDENTP pat => $subs:=[[pat,:first l],:$subs] isPatMatch(rest l,restPats) - pat is ['_=,var] => + pat is ["=",var] => p:=ASSQ(var,$subs) => CAR l = CDR p => isPatMatch(rest l, restPats) - $subs:='failed - $subs:='failed - pat is ['_:,var] => + $subs:="failed" + $subs:="failed" + pat is [":",var] => n:=#restPats m:=#l-n - m<0 => $subs:='failed + m<0 => $subs:="failed" ZEROP n => $subs:=[[var,:l],:$subs] $subs:=[[var,:[x for x in l for i in 1..m]],:$subs] isPatMatch(DROP(m,l),restPats) - isPatMatch(first l,pat) = 'failed => 'failed + isPatMatch(first l,pat) = "failed" => "failed" isPatMatch(rest l,restPats) keyedSystemError("S2GE0016",['"isPatMatch", '"unknown form of is predicate"]) @@ -483,7 +486,7 @@ isPatMatch(l,pats) == upiterate t == null $repeatBodyLabel => throwKeyedMsg("S2IS0029",['"iterate"]) $iterateCount := $iterateCount + 1 - code := ['THROW,$repeatBodyLabel,'(voidValue)] + code := ["THROW",$repeatBodyLabel,'(voidValue)] $genValue => THROW(eval $repeatBodyLabel,voidValue()) putValue(t,objNew(code,$Void)) putModeSet(t,[$Void]) @@ -494,7 +497,7 @@ upbreak t == t isnt [op,.] => nil null $repeatLabel => throwKeyedMsg("S2IS0029",['"break"]) $breakCount := $breakCount + 1 - code := ['THROW,$repeatLabel,'(voidValue)] + code := ["THROW",$repeatLabel,'(voidValue)] $genValue => THROW(eval $repeatLabel,voidValue()) putValue(op,objNew(code,$Void)) putModeSet(op,[$Void]) @@ -508,8 +511,8 @@ upLET t == $declaredMode: local := NIL PAIRP lhs => var:= getUnname first lhs - var = 'construct => upLETWithPatternOnLhs t - var = 'QUOTE => throwKeyedMsg("S2IS0027",['"A quoted form"]) + var = "construct" => upLETWithPatternOnLhs t + var = "QUOTE" => throwKeyedMsg("S2IS0027",['"A quoted form"]) upLETWithFormOnLhs(op,lhs,rhs) var:= getUnname lhs var = $immediateDataSymbol => @@ -685,7 +688,7 @@ upLETWithFormOnLhs(op,lhs,rhs) == seteltable(lhs is [f,:argl],rhs) == -- produces the setelt form for trees such as "l.2:= 3" null (g := getUnnameIfCan f) => NIL - EQ(g,'elt) => altSeteltable [:argl, rhs] + EQ(g,"elt") => altSeteltable [:argl, rhs] get(g,'value,$e) is [expr,:.] and isMapExpr expr => NIL transferPropsToNode(g,f) getValue(lhs) or getMode(lhs) => @@ -735,13 +738,28 @@ upTableSetelt(op,lhs is [htOp,:args],rhs) == -- function to give it an initial value. bottomUp [mkAtreeNode 'LET,htOp,[mkAtreeNode 'table]] tableCode := objVal getValue htOp - r := upSetelt(op, lhs, [mkAtreeNode 'setelt,:lhs,rhs]) + r := upSetelt(op, lhs, [mkAtreeNode "setelt",:lhs,rhs]) $genValue => r -- construct code t := getValue op putValue(op,objNew(['PROGN,tableCode,objVal t],objMode t)) r +unVectorize body == + -- transforms from an atree back into a tree + VECP body => + name := getUnname body + name ^= $immediateDataSymbol => name + objValUnwrap getValue body + atom body => body + body is [op,:argl] => + newOp:=unVectorize op + if newOp = 'SUCHTHAT then newOp := "|" + if newOp = 'COERCE then newOp := "::" + if newOp = 'Dollar then newOp := "$elt" + [newOp,:unVectorize argl] + systemErrorHere '"unVectorize" + isType t == -- Returns the evaluated type if t is a tree representing a type, -- and NIL otherwise @@ -766,7 +784,7 @@ isType t == upLETtype(op,lhs,type) == -- performs type assignment opName:= getUnname lhs - (not $genValue) and or/[CONTAINED(var,type) for var in $localVars] => + (not $genValue) and "or"/[CONTAINED(var,type) for var in $localVars] => compFailure ['" Cannot compile type assignment to",:bright opName] mode := if isPartialMode type then '(Mode) @@ -792,7 +810,7 @@ assignSymbol(symbol, value, domain) == getInterpMacroNames() == names := [n for [n,:.] in $InterpreterMacroAlist] - if (e := CAAR $InteractiveFrame) and (m := ASSOC("--macros--",e)) then + if (e := CAAR $InteractiveFrame) and (m := assoc("--macros--",e)) then names := append(names,[n for [n,:.] in CDR m]) MSORT names @@ -804,7 +822,7 @@ isInterpMacro name == (m := get("--macros--",name,$e)) => m (m := get("--macros--",name,$InteractiveFrame)) => m -- $InterpreterMacroAlist will probably be phased out soon - (sv := ASSOC(name,$InterpreterMacroAlist)) => CONS(NIL,CDR sv) + (sv := assoc(name,$InterpreterMacroAlist)) => CONS(NIL,CDR sv) NIL --% Handlers for prefix QUOTE @@ -853,7 +871,7 @@ getReduceFunction(op,type,result, locale) == if locale then putAtree(vecOp,'dollar,locale) mmS:= selectMms(vecOp,args,result) mm:= or/[mm for (mm:=[[.,:sig],fun,cond]) in mmS | - (isHomogeneousArgs sig) and and/[null c for c in cond]] + (isHomogeneousArgs sig) and "and"/[null c for c in cond]] null mm => 'failed [[dc,:sig],fun,:.]:=mm dc='local => [MKQ [fun,:'local],:CAR sig] @@ -878,25 +896,25 @@ isHomogeneousArgs sig == transformREPEAT [:itrl,body] == -- syntactic transformation of repeat iterators, called from mkAtree2 - iterList:=[:iterTran1 for it in itrl] where iterTran1 == - it is ['STEP,index,lower,step,:upperList] => - [['STEP,index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper + iterList:=[:iterTran1 for it in itrl] where iterTran1() == + it is ["STEP",index,lower,step,:upperList] => + [["STEP",index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper for upper in upperList]]] - it is ['IN,index,s] => + it is ["IN",index,s] => [['IN,index,mkAtree1 s]] - it is ['ON,index,s] => + it is ["ON",index,s] => [['IN,index,mkAtree1 ['tails,s]]] - it is ['WHILE,b] => - [['WHILE,mkAtree1 b]] - it is ['_|,pred] => - [['SUCHTHAT,mkAtree1 pred]] + it is ["WHILE",b] => + [["WHILE",mkAtree1 b]] + it is ["|",pred] => + [["SUCHTHAT",mkAtree1 pred]] it is [op,:.] and (op in '(VALUE UNTIL)) => nil bodyTree:=mkAtree1 body - iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where iterTran2 == - it is ['STEP,:.] => nil - it is ['IN,:.] => nil - it is ['ON,:.] => nil - it is ['WHILE,:.] => nil + iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where iterTran2() == + it is ["STEP",:.] => nil + it is ["IN",:.] => nil + it is ["ON",:.] => nil + it is ["WHILE",:.] => nil it is [op,b] and (op in '(UNTIL VALUE)) => [[op,mkAtree1 b]] it is ['_|,pred] => nil @@ -942,7 +960,7 @@ upREPEAT1 t == -- now that the body is analyzed, we should know everything that -- is in the UNTIL clause for itr in itrl repeat - itr is ['UNTIL, pred] => bottomUpCompilePredicate(pred,'"until") + itr is ["UNTIL", pred] => bottomUpCompilePredicate(pred,'"until") -- now go do it evalREPEAT(op,rest t,repeatMode) @@ -953,7 +971,7 @@ evalREPEAT(op,[:itrl,body],repeatMode) == bodyMode := computedMode body bodyCode := getArgValue(body,bodyMode) if $iterateCount > 0 then - bodyCode := ['CATCH,$repeatBodyLabel,bodyCode] + bodyCode := ["CATCH",$repeatBodyLabel,bodyCode] code := ['REPEAT,:[evalLoopIter itr for itr in itrl], bodyCode] if repeatMode = $Void then code := ['OR,code,'(voidValue)] code := timedOptimization code @@ -977,8 +995,8 @@ interpREPEAT(op,itrl,body,repeatMode) == $indexTypes: local := NIL code := -- we must insert a CATCH for the iterate clause - ['REPEAT,:[interpIter itr for itr in itrl], - ['CATCH,$repeatBodyLabel,interpLoop(body,$indexVars, + ["REPEAT",:[interpIter itr for itr in itrl], + ["CATCH",$repeatBodyLabel,interpLoop(body,$indexVars, $indexTypes,nil)]] SPADCATCH(eval $repeatLabel,timedEVALFUN code) val:= objNewWrap(voidValue(),repeatMode) @@ -987,7 +1005,7 @@ interpREPEAT(op,itrl,body,repeatMode) == interpLoop(expr,indexList,indexTypes,requiredType) == -- generates code for interp-only repeat body - ['interpLoopIter,MKQ expr,MKQ indexList,['LIST,:indexList], + ['interpLoopIter,MKQ expr,MKQ indexList,["LIST",:indexList], MKQ indexTypes, MKQ requiredType] interpLoopIter(exp,indexList,indexVals,indexTypes,requiredType) == @@ -1184,15 +1202,10 @@ copyHack(env) == -- Creates the function names of the special function handlers and puts -- them on the property list of the function name -EVALANDFILEACTQ - ( - for name in $specialOps repeat - ( - functionName:=INTERNL('up,name) ; - MAKEPROP(name,'up,functionName) ; - CREATE_-SBC functionName - ) - ) +for name in $specialOps repeat + functionName:=INTERNL('up,name) + MAKEPROP(name,'up,functionName) + CREATE_-SBC functionName @ \eject diff --git a/src/interp/i-syscmd.boot.pamphlet b/src/interp/i-syscmd.boot.pamphlet index 8bffe842..37eb1209 100644 --- a/src/interp/i-syscmd.boot.pamphlet +++ b/src/interp/i-syscmd.boot.pamphlet @@ -128,17 +128,22 @@ This will have to be pushed down from the top level Makefile. <<*>>= <<license>> +import '"i-object" +)package "BOOT" + --% Utility Variable Initializations -SETANDFILEQ($cacheAlist,nil) -SETANDFILEQ($compileRecurrence,true) -SETANDFILEQ($errorReportLevel,'warning) -SETANDFILEQ($sourceFileTypes,'(INPUT SPAD BOOT LISP LISP370 META)) +$cacheAlist := nil +$compileRecurrence := true +$errorReportLevel := 'warning +$sourceFileTypes := '(INPUT SPAD BOOT LISP LISP370 META) + +$SYSCOMMANDS := [CAR x for x in $systemCommands] -SETANDFILEQ($SYSCOMMANDS,[CAR x for x in $systemCommands]) +UNDERBAR == '"__" -SETANDFILEQ($whatOptions, '( _ +$whatOptions := '( _ operations _ categories _ domains _ @@ -146,17 +151,17 @@ SETANDFILEQ($whatOptions, '( _ commands _ synonyms _ things _ - )) + ) -SETANDFILEQ($clearOptions, '( _ +$clearOptions := '( _ modes _ operations _ properties _ types _ values _ - )) + ) -SETANDFILEQ($displayOptions, '( _ +$displayOptions := '( _ abbreviations _ all _ macros _ @@ -166,9 +171,9 @@ SETANDFILEQ($displayOptions, '( _ properties _ types _ values _ - )) + ) -SETANDFILEQ($countAssoc,'( (cache countCache) )) +$countAssoc := '( (cache countCache) ) --% Top level system command @@ -431,7 +436,7 @@ clearCmdParts(l is [opt,:vl]) == if option='properties and x in imacs and ^(x in pmacs) then sayMessage ['" You cannot clear the definition of the system-defined macro ", fixObjectForPrinting x,"."] - p1 := ASSOC(x,CAAR $InteractiveFrame) => + p1 := assoc(x,CAAR $InteractiveFrame) => option='properties => if isMap x then (lm := get(x,'localModemap,$InteractiveFrame)) => @@ -442,7 +447,7 @@ clearCmdParts(l is [opt,:vl]) == recordOldValue(x,prop,CDR p2) recordNewValue(x,prop,NIL) SETF(CAAR $InteractiveFrame,deleteAssoc(x,CAAR $InteractiveFrame)) - p2:= ASSOC(option,CDR p1) => + p2:= assoc(option,CDR p1) => recordOldValue(x,option,CDR p2) recordNewValue(x,option,NIL) RPLACD(p2,NIL) @@ -846,6 +851,78 @@ copyright () == --% )credits -- display credit list +CREDITS := '( + "An alphabetical listing of contributors to AXIOM (to October, 2006):" + "Cyril Alberga Roy Adler Christian Aistleitner" + "Richard Anderson George Andrews" + "Henry Baker Stephen Balzac Yurij Baransky" + "David R. Barton Gerald Baumgartner Gilbert Baumslag" + "Fred Blair Vladimir Bondarenko Mark Botch" + "Alexandre Bouyer Peter A. Broadbery Martin Brock" + "Manuel Bronstein Florian Bundschuh Luanne Burns" + "William Burge" + "Quentin Carpent Robert Caviness Bruce Char" + "Cheekai Chin David V. Chudnovsky Gregory V. Chudnovsky" + "Josh Cohen Christophe Conil Don Coppersmith" + "George Corliss Robert Corless Gary Cornell" + "Meino Cramer Claire Di Crescenzo" + "Timothy Daly Sr. Timothy Daly Jr. James H. Davenport" + "Jean Della Dora Gabriel Dos Reis Michael Dewar" + "Claire DiCrescendo Sam Dooley Lionel Ducos" + "Martin Dunstan Brian Dupee Dominique Duval" + "Robert Edwards Heow Eide-Goodman Lars Erickson" + "Richard Fateman Bertfried Fauser Stuart Feldman" + "Brian Ford Albrecht Fortenbacher George Frances" + "Constantine Frangos Timothy Freeman Korrinn Fu" + "Marc Gaetano Rudiger Gebauer Kathy Gerber" + "Patricia Gianni Holger Gollan Teresa Gomez-Diaz" + "Laureano Gonzalez-Vega Stephen Gortler Johannes Grabmeier" + "Matt Grayson James Griesmer Vladimir Grinberg" + "Oswald Gschnitzer Jocelyn Guidry" + "Steve Hague Vilya Harvey Satoshi Hamaguchi" + "Martin Hassner Waldek Hebisch Ralf Hemmecke" + "Henderson Antoine Hersen" + "Pietro Iglio" + "Richard Jenks" + "Kai Kaminski Grant Keady Tony Kennedy" + "Paul Kosinski Klaus Kusche Bernhard Kutzler" + "Larry Lambe Frederic Lehobey Michel Levaud" + "Howard Levy Rudiger Loos Michael Lucks" + "Richard Luczak" + "Camm Maguire Bob McElrath Michael McGettrick" + "Ian Meikle David Mentre Victor S. Miller" + "Gerard Milmeister Mohammed Mobarak H. Michael Moeller" + "Michael Monagan Marc Moreno-Maza Scott Morrison" + "Mark Murray" + "William Naylor C. Andrew Neff John Nelder" + "Godfrey Nolan Arthur Norman Jinzhong Niu" + "Michael O'Connor Kostas Oikonomou" + "Julian A. Padget Bill Page Susan Pelzel" + "Michel Petitot Didier Pinchon Jose Alfredo Portes" + "Claude Quitte" + "Norman Ramsey Michael Richardson Renaud Rioboo" + "Jean Rivlin Nicolas Robidoux Simon Robinson" + "Michael Rothstein Martin Rubey" + "Philip Santas Alfred Scheerhorn William Schelter" + "Gerhard Schneider Martin Schoenert Marshall Schor" + "Frithjof Schulze Fritz Schwarz Nick Simicich" + "William Sit Elena Smirnova Jonathan Steinbach" + "Christine Sundaresan Robert Sutor Moss E. Sweedler" + "Eugene Surowitz" + "James Thatcher Balbir Thomas Mike Thomas" + "Dylan Thurston Barry Trager Themos T. Tsikas" + "Gregory Vanuxem" + "Bernhard Wall Stephen Watt Jaap Weel" + "Juergen Weiss M. Weller Mark Wegman" + "James Wen Thorsten Werther Michael Wester" + "John M. Wiley Berhard Will Clifton J. Williamson" + "Stephen Wilson Shmuel Winograd Robert Wisbauer" + "Sandra Wityak Waldemar Wiwianka Knut Wolf" + "Clifford Yapp David Yun" + "Richard Zippel Evelyn Zoernack Bruno Zuercher" + "Dan Zwillinger" + ) + credits() == for i in CREDITS repeat PRINC(i) @@ -929,7 +1006,7 @@ getParserMacroNames() == --------------------> NEW DEFINITION (override in patches.lisp.pamphlet) clearParserMacro(macro) == -- first see if it is one - not IFCDR ASSOC(macro, ($pfMacros)) => NIL + not IFCDR assoc(macro, ($pfMacros)) => NIL $pfMacros := REMALIST($pfMacros, macro) displayMacro name == @@ -2040,7 +2117,7 @@ dewritify ob == HPUT($seen, nob, nob) nob type = 'PLACE => - nob := READ MAKE_-INSTREAM NIL + nob := VMREAD MAKE_-INSTREAM NIL HPUT($seen, ob, nob) HPUT($seen, nob, nob) nob @@ -2447,7 +2524,7 @@ spool filename == systemError CONCAT('"file ", STRING car filename, '" already exists") DRIBBLE car filename TERPRI() - clearHighlight + clearHighlight() --% )synonym @@ -2530,7 +2607,7 @@ diffAlist(new,old) == acc := [[name,:[[prop] for [prop,:.] in proplist]],:acc] deltas := nil for (propval := [prop,:val]) in proplist repeat - null (oldPropval := ASSOC(prop,oldProplist)) => --missing property + null (oldPropval := assoc(prop,oldProplist)) => --missing property deltas := [[prop],:deltas] EQ(CDR oldPropval,val) => 'skip deltas := [oldPropval,:deltas] @@ -2632,7 +2709,7 @@ undoSingleStep(changes,env) == env undoLocalModemapHack changeList == - [newPair for (pair := [name,:value]) in changeList | newPair] where newPair == + [newPair for (pair := [name,:value]) in changeList | newPair] where newPair() == name = 'localModemap => [name] pair diff --git a/src/interp/i-toplev.boot.pamphlet b/src/interp/i-toplev.boot.pamphlet index d8021246..411d9b05 100644 --- a/src/interp/i-toplev.boot.pamphlet +++ b/src/interp/i-toplev.boot.pamphlet @@ -52,15 +52,18 @@ from LISP. <<*>>= <<license>> +import '"i-analy" +)package "BOOT" + --% Top Level Interpreter Code -- When $QuiteCommand is true Spad will not produce any output from -- a top level command -SETANDFILEQ($QuietCommand, NIL) +$QuietCommand := NIL -- When $ProcessInteractiveValue is true, we don't want the value printed -- or recorded. -SETANDFILEQ($ProcessInteractiveValue, NIL) -SETANDFILEQ($HTCompanionWindowID, NIL) +$ProcessInteractiveValue := NIL +$HTCompanionWindowID := NIL --% Starting the interpreter from LISP diff --git a/src/interp/i-util.boot.pamphlet b/src/interp/i-util.boot.pamphlet index 899cc18f..3539c195 100644 --- a/src/interp/i-util.boot.pamphlet +++ b/src/interp/i-util.boot.pamphlet @@ -58,6 +58,9 @@ lisp code is unwrapped. <<*>>= <<license>> +import '"g-util" +)package "BOOT" + --% The function for making prompts spadPrompt() == @@ -145,7 +148,7 @@ Undef(:u) == u':= LAST u [[domain,slot],op,sig]:= u' domain':=eval mkEvalable domain - ^EQ(CAR ELT(domain',slot),Undef) => + ^EQ(CAR ELT(domain',slot), function Undef) => -- OK - thefunction is now defined [:u'',.]:=u if $reportBottomUpFlag then diff --git a/src/interp/pspad1.boot b/src/interp/pspad1.boot index ce580b14..89fe6b79 100644 --- a/src/interp/pspad1.boot +++ b/src/interp/pspad1.boot @@ -260,7 +260,7 @@ format(x,:options) == qualification := IFCAR options newCOrNil:= x is [op,:argl] => - if op = 'return then argl := rest argl + if op = "return" then argl := rest argl n := #argl op is ['elt,y,"construct"] => formatDollar(y,'construct,argl) op is ['elt,name,p] and UPPER_-CASE_-P (STRINGIMAGE opOf name).0 => diff --git a/src/interp/pspad2.boot b/src/interp/pspad2.boot index e5af3357..4f5a729b 100644 --- a/src/interp/pspad2.boot +++ b/src/interp/pspad2.boot @@ -118,9 +118,9 @@ formatDeftranRepper([op,a],SEQflag) == a is ['LET,a,b] => formatDeftran(['LET,a,[op,b]],SEQflag) a is ['not,[op,a,b]] and (op1 := LASSOC(op,$pspadRelationAlist)) => formatDeftran [op1,a,b] - a is ['return,n,r] => + a is ["return",n,r] => MEMQ(opOf r,'(true false)) => a - ['return,n,[op,formatDeftran(r,SEQflag)]] + ["return",n,[op,formatDeftran(r,SEQflag)]] a is ['error,:.] => a [op,formatDeftran(a,SEQflag)] diff --git a/src/interp/setq.lisp b/src/interp/setq.lisp index 195a1c84..b1872dfc 100644 --- a/src/interp/setq.lisp +++ b/src/interp/setq.lisp @@ -187,7 +187,6 @@ (SETQ RPAR ")") (SETQ SLASH "/") (SETQ STAR "*") -(SETQ UNDERBAR "_") (SETQ |$fortranArrayStartingIndex| 0) ;; These were originally in INIT LISP @@ -392,75 +391,4 @@ ;; By default, don't generate info files with old compiler. (setq |$profileCompiler| nil) -(setq credits '( -"An alphabetical listing of contributors to AXIOM (to October, 2006):" -"Cyril Alberga Roy Adler Christian Aistleitner" -"Richard Anderson George Andrews" -"Henry Baker Stephen Balzac Yurij Baransky" -"David R. Barton Gerald Baumgartner Gilbert Baumslag" -"Fred Blair Vladimir Bondarenko Mark Botch" -"Alexandre Bouyer Peter A. Broadbery Martin Brock" -"Manuel Bronstein Florian Bundschuh Luanne Burns" -"William Burge" -"Quentin Carpent Robert Caviness Bruce Char" -"Cheekai Chin David V. Chudnovsky Gregory V. Chudnovsky" -"Josh Cohen Christophe Conil Don Coppersmith" -"George Corliss Robert Corless Gary Cornell" -"Meino Cramer Claire Di Crescenzo" -"Timothy Daly Sr. Timothy Daly Jr. James H. Davenport" -"Jean Della Dora Gabriel Dos Reis Michael Dewar" -"Claire DiCrescendo Sam Dooley Lionel Ducos" -"Martin Dunstan Brian Dupee Dominique Duval" -"Robert Edwards Heow Eide-Goodman Lars Erickson" -"Richard Fateman Bertfried Fauser Stuart Feldman" -"Brian Ford Albrecht Fortenbacher George Frances" -"Constantine Frangos Timothy Freeman Korrinn Fu" -"Marc Gaetano Rudiger Gebauer Kathy Gerber" -"Patricia Gianni Holger Gollan Teresa Gomez-Diaz" -"Laureano Gonzalez-Vega Stephen Gortler Johannes Grabmeier" -"Matt Grayson James Griesmer Vladimir Grinberg" -"Oswald Gschnitzer Jocelyn Guidry" -"Steve Hague Vilya Harvey Satoshi Hamaguchi" -"Martin Hassner Waldek Hebisch Ralf Hemmecke" -"Henderson Antoine Hersen" -"Pietro Iglio" -"Richard Jenks" -"Kai Kaminski Grant Keady Tony Kennedy" -"Paul Kosinski Klaus Kusche Bernhard Kutzler" -"Larry Lambe Frederic Lehobey Michel Levaud" -"Howard Levy Rudiger Loos Michael Lucks" -"Richard Luczak" -"Camm Maguire Bob McElrath Michael McGettrick" -"Ian Meikle David Mentre Victor S. Miller" -"Gerard Milmeister Mohammed Mobarak H. Michael Moeller" -"Michael Monagan Marc Moreno-Maza Scott Morrison" -"Mark Murray" -"William Naylor C. Andrew Neff John Nelder" -"Godfrey Nolan Arthur Norman Jinzhong Niu" -"Michael O'Connor Kostas Oikonomou" -"Julian A. Padget Bill Page Susan Pelzel" -"Michel Petitot Didier Pinchon Jose Alfredo Portes" -"Claude Quitte" -"Norman Ramsey Michael Richardson Renaud Rioboo" -"Jean Rivlin Nicolas Robidoux Simon Robinson" -"Michael Rothstein Martin Rubey" -"Philip Santas Alfred Scheerhorn William Schelter" -"Gerhard Schneider Martin Schoenert Marshall Schor" -"Frithjof Schulze Fritz Schwarz Nick Simicich" -"William Sit Elena Smirnova Jonathan Steinbach" -"Christine Sundaresan Robert Sutor Moss E. Sweedler" -"Eugene Surowitz" -"James Thatcher Balbir Thomas Mike Thomas" -"Dylan Thurston Barry Trager Themos T. Tsikas" -"Gregory Vanuxem" -"Bernhard Wall Stephen Watt Jaap Weel" -"Juergen Weiss M. Weller Mark Wegman" -"James Wen Thorsten Werther Michael Wester" -"John M. Wiley Berhard Will Clifton J. Williamson" -"Stephen Wilson Shmuel Winograd Robert Wisbauer" -"Sandra Wityak Waldemar Wiwianka Knut Wolf" -"Clifford Yapp David Yun" -"Richard Zippel Evelyn Zoernack Bruno Zuercher" -"Dan Zwillinger" -)) diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp index c2008754..1f8b84b0 100644 --- a/src/interp/spad.lisp +++ b/src/interp/spad.lisp @@ -75,7 +75,6 @@ (defvar |$kernelProtect| NIL "") (defvar |$HiFiAccess| nil "if true maintain history file") (defvar |$mapReturnTypes| nil) -(defvar /TRACENAMES NIL) (defvar INPUTSTREAM t "bogus initialization for now") @@ -300,13 +299,6 @@ (if (zerop y) (truncate 1 Y) (multiple-value-call #'cons (TRUNCATE X Y)))) -(defmacro APPEND2 (x y) `(append ,x ,y)) - -(defmacro |float| (x &optional (y 0.0d0)) `(float ,x ,y)) - -(defun |makeSF| (mantissa exponent) - (|float| (/ mantissa (expt 2 (- exponent))))) - (define-function 'list1 #'list) (define-function '|not| #'NOT) diff --git a/src/interp/sys-globals.boot b/src/interp/sys-globals.boot index 77644a6b..4fcc113c 100644 --- a/src/interp/sys-globals.boot +++ b/src/interp/sys-globals.boot @@ -407,6 +407,7 @@ _/WSNAME := "NOBOOT" _/EDITFILE := nil ++ +LINE := nil CHR := nil TOK := nil @@ -418,3 +419,6 @@ _*ANCESTORS_-HASH_* := nil ++ _*BUILD_-VERSION_* := nil _*YEARWEEK_* := nil + +++ +_/TRACENAMES := nil diff --git a/src/interp/sys-macros.lisp b/src/interp/sys-macros.lisp index 85f5434f..3f4ac262 100644 --- a/src/interp/sys-macros.lisp +++ b/src/interp/sys-macros.lisp @@ -61,6 +61,12 @@ ;; -*- BigFloat Constructors -*- ;; +(defmacro |float| (x &optional (y 0.0d0)) + `(float ,x ,y)) + +(defun |makeSF| (mantissa exponent) + (|float| (/ mantissa (expt 2 (- exponent))))) + (defmacro MAKE-BF (MT EP) `(CONS |$BFtag| (CONS ,MT ,EP))) @@ -152,6 +158,10 @@ (defmacro KADDR (ARG) `(IFCAR (IFCDR (IFCDR ,arg)))) + +(defmacro APPEND2 (x y) + `(append ,x ,y)) + (eval-when #+:common-lisp (:compile-toplevel :load-toplevel :execute) #-:common-lisp (compile load eval) diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot index fddd93ca..b0142f43 100644 --- a/src/interp/wi2.boot +++ b/src/interp/wi2.boot @@ -565,7 +565,7 @@ compFormWithModemap1(form,m,e,modemap,Rep2Dollar?) == -- try to deal with new-style Unions where we know the conditions op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and (c:=get(z,'condition,e)) and - c is [['case,=z,c1]] and + c is [["case",=z,c1]] and (c1 is ['_:,=(CADR argl),=m] or EQ(c1,CADR argl) ) => -- first is a full tag, as placed by getInverseEnvironment -- second is what getSuccessEnvironment will place there |