diff -Nru mathpiper-0.81f+svn4469+dfsg2/debian/changelog mathpiper-0.81f+svn4469+dfsg3/debian/changelog --- mathpiper-0.81f+svn4469+dfsg2/debian/changelog 2011-12-16 14:19:22.000000000 +0000 +++ mathpiper-0.81f+svn4469+dfsg3/debian/changelog 2012-03-02 23:21:13.000000000 +0000 @@ -1,3 +1,11 @@ +mathpiper (0.81f+svn4469+dfsg3-1) unstable; urgency=low + + * Add Lisp scripts from mpreduce, needed to execute Reduce + algorithms. + * Do not compile Javadoc, which is discarded anyway. + + -- Giovanni Mascellani Sat, 03 Mar 2012 00:21:04 +0100 + mathpiper (0.81f+svn4469+dfsg2-1) unstable; urgency=low * Add mpreduce code. diff -Nru mathpiper-0.81f+svn4469+dfsg2/debian/copyright mathpiper-0.81f+svn4469+dfsg3/debian/copyright --- mathpiper-0.81f+svn4469+dfsg2/debian/copyright 2011-12-16 14:19:22.000000000 +0000 +++ mathpiper-0.81f+svn4469+dfsg3/debian/copyright 2012-03-02 23:21:13.000000000 +0000 @@ -13,6 +13,20 @@ src/org/mathpiper/ui/gui/MultiSplitPane.java Copyright: © 2004, Sun Microsystems, Inc., 4150 Network Circle, Santa Clara, California 95054, U.S.A. License: LGPL-2.1+ + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + . + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + . + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + . On Debian systems, the LGPL-2.1 license text can be found in: /usr/share/common-licenses/LGPL-2.1 @@ -31,10 +45,32 @@ along with this program. If not, see . Files: src/org/mathpiper/mpreduce/* + lib/build_scripts/* + src/packages/* Copyright: © 1998 - 2011, Codemist Ltd. © 1998 - 2011, A. C. Norman © 2002, Vijay Chauhan © 2011, Ted Kosan + © 1987 - 1996, The RAND Corporation + © 1987 - 2005, Anthony C. Hearn + © 2008 - 2010, Thomas Sturm + © 1996, Neil Langmead + © 1988, David Harper + © 1990 - 1997, Zuse-Institut Berlin (ZIB) + © 1997, Wolfram Koepf + © 1997, Harald Boeing + © 1987, James W Eastwood + © 1987 - 1995, Stanley L. Kameny + © 1988 - 1990, Institute of Nuclear Physics, Moscow State University + © 1990 - 1992, Mathias Warns + © 1990 - 1996, A. Kryukov + © 1989 - 2010, Rainer M. Schoepf + © 1999 - 2009, Andreas Dolzmann + © 2003 - 2009, Lorenz Gilch + © 2002 - 2009, A. Seidl + © J.A. van Hulzen + © Alexey Yu. Zharkov + © Yuri A. Blinkov License: BSD Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are @@ -60,6 +96,11 @@ TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Comment: Portions attributed to the RAND Corporation do not carry an + explicit license notice. Anyway, they come from the Reduce project, + which is now wholly available under the reported license (see + http://www.reduce-algebra.com/license.htm). I believe it is safe to + consider such code snippets under the same license. Files: src/org/mathpiper/builtin/javareflection/JavaField.java src/org/mathpiper/builtin/javareflection/JavaMethod.java @@ -129,5 +170,19 @@ License: GPL-2+ License: GPL-2+ + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or any later version. + . + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + . + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + . On Debian systems, the GPL-2 license text can be found in: /usr/share/common-licenses/GPL-2 diff -Nru mathpiper-0.81f+svn4469+dfsg2/debian/get_orig_source.sh mathpiper-0.81f+svn4469+dfsg3/debian/get_orig_source.sh --- mathpiper-0.81f+svn4469+dfsg2/debian/get_orig_source.sh 2011-12-16 14:19:22.000000000 +0000 +++ mathpiper-0.81f+svn4469+dfsg3/debian/get_orig_source.sh 2012-03-02 23:21:13.000000000 +0000 @@ -14,9 +14,15 @@ if [ "x$REVISION" == "x" ] ; then svn export "http://mathpiper.googlecode.com/svn/trunk/src/library_apps/mathpiper" "$DESTDIR" svn export "http://mathpiper.googlecode.com/svn/trunk/src/library_apps/mpreduce/src/java/org/mathpiper/mpreduce" "$DESTDIR/src/org/mathpiper/mpreduce" + svn export "http://mathpiper.googlecode.com/svn/trunk/src/library_apps/mpreduce/src/packages" "$DESTDIR/src/packages" + mkdir "$DESTDIR/lib" + svn export "http://mathpiper.googlecode.com/svn/trunk/src/library_apps/mpreduce/lib/build_scripts" "$DESTDIR/lib/build_scripts" else svn export -r "$REVISION" "http://mathpiper.googlecode.com/svn/trunk/src/library_apps/mathpiper" "$DESTDIR" svn export -r "$REVISION" "http://mathpiper.googlecode.com/svn/trunk/src/library_apps/mpreduce/src/java/org/mathpiper/mpreduce" "$DESTDIR/src/org/mathpiper/mpreduce" + svn export -r "$REVISION" "http://mathpiper.googlecode.com/svn/trunk/src/library_apps/mpreduce/src/packages" "$DESTDIR/src/packages" + mkdir "$DESTDIR/lib" + svn export -r "$REVISION" "http://mathpiper.googlecode.com/svn/trunk/src/library_apps/mpreduce/lib/build_scripts" "$DESTDIR/lib/build_scripts" fi else # Uncompress the previous tarball @@ -35,6 +41,12 @@ rm -vf "$DESTDIR/src/org/mathpiper/test/matheclipse/ParseRubiFiles.java" rm -vf "$DESTDIR/src/org/mathpiper/builtin/functions/optional/ViewGeoGebra.java" +# Remove other files with problematic licenses +rm -f "$DESTDIR/lib/build_scripts/buildcsl.lsp" +rm -f "$DESTDIR/lib/build_scripts/ccomp.lsp" +rm -f "$DESTDIR/lib/build_scripts/mkbytes.red" +rm -f "$DESTDIR/lib/build_scripts/opcodes.red" + # Removes all upstream JARs, DLLs, SOs and JNILIBs for ext in jar dll so jnilib ; do find "$DESTDIR" -iname '*'."$ext" -print0 | xargs -0 rm -vf diff -Nru mathpiper-0.81f+svn4469+dfsg2/debian/README.source mathpiper-0.81f+svn4469+dfsg3/debian/README.source --- mathpiper-0.81f+svn4469+dfsg2/debian/README.source 2011-12-16 14:19:22.000000000 +0000 +++ mathpiper-0.81f+svn4469+dfsg3/debian/README.source 2012-03-02 23:21:13.000000000 +0000 @@ -8,8 +8,11 @@ * Deleting the misc/ directory, which are not necessary for the Debian package; - * Deleteing a few embedded copies of other pieces of software, - documented below. + * Deleting a few embedded copies of other pieces of software, + documented below; + + * Deleting a few script files distributed under the non-DFSG-free + license "CCL Public License". QUILT diff -Nru mathpiper-0.81f+svn4469+dfsg2/debian/rules mathpiper-0.81f+svn4469+dfsg3/debian/rules --- mathpiper-0.81f+svn4469+dfsg2/debian/rules 2011-12-16 14:19:22.000000000 +0000 +++ mathpiper-0.81f+svn4469+dfsg3/debian/rules 2012-03-02 23:21:13.000000000 +0000 @@ -15,4 +15,12 @@ true override_dh_auto_clean: - true + rm -f reduceimg.log default.img + +override_jh_build: + jh_build -N + + # Compile the Lisp scripts and put them into the JAR + CLASSPATH=$$CLASSPATH:./mathpiper.jar java -Xmx300M -Xms300M -Xss8M org.mathpiper.mpreduce.Jlisp -w -v -z -o default.img lib/build_scripts/buildreduce.lsp -D@srcdir=lib/build_scripts -- reduceimg.log + jar uf mathpiper.jar default.img + diff -Nru mathpiper-0.81f+svn4469+dfsg2/lib/build_scripts/buildreduce.lsp mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/buildreduce.lsp --- mathpiper-0.81f+svn4469+dfsg2/lib/build_scripts/buildreduce.lsp 1970-01-01 00:00:00.000000000 +0000 +++ mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/buildreduce.lsp 2011-05-29 07:16:22.000000000 +0000 @@ -0,0 +1,1647 @@ +% "buildreduce.lsp" +% +% Build a CSL REDUCE. +% +% Depending on how this file is used it will EITHER create a bootstrap +% version of REDUCE or a full and optimised one. +% +% The behaviour is determined by whether the version of CSL used to +% run it has a full complement of functions in the modules u01.c to u60.c. +% +% +% bootstrapreduce -z buildreduce.lsp -D@srcdir= +% +% Builds a system "bootstrapreduce.img" that does not depend on any +% custom C code. The main use of this slow system is for profiling +% REDUCE and then compiling the hot-spots into C. Once that has been +% done this image is logically unnecessary. +% +% +% reduce -z buildreduce.lsp -D@srcdir= +% +% Here the files u01.c to u60.c and u01.lsp to u60.lsp must already +% have been created, and that the reduce executable has them compiled in. +% The REDUCE source files that are compiled *MUST* be the same as those used +% to create this C code. + +% Author: Anthony C. Hearn, Stanley L. Kameny and Arthur Norman + +(verbos 3) + +(window!-heading "basic CSL") + +(setq !*savedef (and (not (memq 'embedded lispsystem!*)) + (zerop (cdr (assoc 'c!-code lispsystem!*))))) +(make!-special '!*native_code) +(setq !*native_code nil) + +(cond ((and (null !*savedef) (null (memq 'embedded lispsystem!*))) (progn + + (de c!:install (name env c!-version !&optional c1) + (cond + (c1 (check!-c!-code name env c!-version c1)) + (t (progn + (put name 'c!-version c!-version) + (cond (env (prog (v n) + (setq v (mkvect (sub1 (length env)))) + (setq n 0) + top (cond + ((null env) (progn + (put name 'funarg v) + (return (symbol!-set!-env name v))))) + (putv v n (car env)) + (setq n (add1 n)) + (setq env (cdr env)) + (go top)))) + name)))) + + (rdf "$srcdir/../../src/../cslbuild/generated-c/u01.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u02.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u03.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u04.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u05.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u06.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u07.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u08.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u09.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u10.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u11.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u12.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u13.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u14.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u15.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u16.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u17.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u18.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u19.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u20.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u21.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u22.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u23.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u24.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u25.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u26.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u27.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u28.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u29.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u30.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u31.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u32.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u33.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u34.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u35.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u36.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u37.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u38.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u39.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u40.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u41.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u42.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u43.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u44.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u45.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u46.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u47.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u48.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u49.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u50.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u51.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u52.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u53.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u54.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u55.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u56.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u57.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u58.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u59.lsp") + (rdf "$srcdir/../../src/../cslbuild/generated-c/u60.lsp") + ))) + +(rdf "$srcdir/fastgets.lsp") +(rdf "$srcdir/compat.lsp") +(rdf "$srcdir/extras.lsp") +(rdf "$srcdir/compiler.lsp") + +(compile!-all) + +(setq !*comp t) % It's faster if we compile the boot file. + +% Tidy up be deleting any modules that are left over in this image + +(dolist (a (library!-members)) (delete!-module a)) + +% Build fasl files for the compatibility code and the two +% versions of the compiler. + +(faslout 'cslcompat) +(rdf "$srcdir/fastgets.lsp") +(rdf "$srcdir/compat.lsp") +(rdf "$srcdir/extras.lsp") +(faslend) + +(faslout 'compiler) +(rdf "$srcdir/compiler.lsp") +(faslend) + +(setq !*comp t) + +(de concat (u v) + (compress (cons '!" (append (explode2 u) + (nconc (explode2 v) (list '!")))))) + +(global '(oldchan!*)) + +(setq prolog_file 'cslprolo) + +(setq rend_file 'cslrend) + +(setq !*argnochk t) + +(setq !*int nil) % Prevents input buffer being saved. + +(setq !*msg nil) + +(window!-heading "bootstrap RLISP") + +% This is dervived fron the Standard LISP BOOT File. +% Author: Anthony C. Hearn. +% Copyright (c) 1991 RAND. All Rights Reserved. + +(fluid '(fname!* !*blockp !*lower !*mode)) + +(global '(oldchan!*)) + +(global '(!*raise crchar!* cursym!* nxtsym!* ttype!* !$eol!$)) + +(put '!; 'switch!* '(nil !*semicol!*)) + +(put '!( 'switch!* '(nil !*lpar!*)) + +(put '!) 'switch!* '(nil !*rpar!*)) + +(put '!, 'switch!* '(nil !*comma!*)) + +(put '!. 'switch!* '(nil cons)) + +(put '!: 'switch!* '(((!= nil setq)) !*colon!*)) + +(put '!*comma!* 'infix 1) + +(put 'setq 'infix 2) + +(put 'cons 'infix 3) + +(flag '(!*comma!*) 'nary) + +(flag '(!*colon!* !*semicol!* end then else) 'delim) + +(put 'begin 'stat 'blockstat) + +(put 'if 'stat 'ifstat) + +(put 'symbolic 'stat 'procstat) + +(de begin2 nil + (prog nil + (setq cursym!* '!*semicol!*) +a (cond + ((eq cursym!* 'end) (progn (rds oldchan!*) (return nil))) + (t (prin2 (errorset '(eval (form (xread nil))) t t)) )) + (go a))) + +(de form (u) u) + +(de xread (u) (progn (scan) (xread1 u))) + +(de xread1 (u) + (prog (v w x y z z2) +a (setq z cursym!*) +a1 (cond + ((or (null (atom z)) (numberp z)) (setq y nil)) + ((flagp z 'delim) (go end1)) + ((eq z '!*lpar!*) (go lparen)) + ((eq z '!*rpar!*) (go end1)) + ((setq y (get z 'infix)) (go infx)) + ((setq y (get z 'stat)) (go stat))) +a3 (setq w (cons z w)) +next (setq z (scan)) + (go a1) +lparen(setq y nil) + (cond + ((eq (scan) '!*rpar!*) + (and w (setq w (cons (list (car w)) (cdr w)))) ) + ((eqcar (setq z (xread1 'paren)) '!*comma!*) + (setq w (cons (cons (car w) (cdr z)) (cdr w)))) + (t (go a3))) + (go next) +infx (setq z2 (mkvar (car w) z)) +un1 (setq w (cdr w)) + (cond + ((null w) (go un2)) + (t (setq z2 (cons (car w) (list z2)))) ) + (go un1) +un2 (setq v (cons z2 v)) +preced(cond ((null x) (go pr4)) ((lessp y (car (car x))) (go pr2))) +pr1 (setq x (cons (cons y z) x)) + (go next) +pr2 (setq v + (cons + (cond + ((and (eqcar (car v) (cdar x)) (flagp (cdar x) 'nary)) + (cons (cdar x) (cons (cadr v) (cdar v)))) + (t (cons (cdar x) (list (cadr v) (car v)))) ) + (cdr (cdr v)))) + (setq x (cdr x)) + (go preced) +stat (setq w (cons (eval (list y)) w)) + (setq y nil) + (go a) +end1 (cond + ((and (and (null v) (null w)) (null x)) (return nil)) + (t (setq y 0))) + (go infx) +pr4 (cond ((null (equal y 0)) (go pr1)) (t (return (car v)))) )) + +(de eqcar (u v) (and (null (atom u)) (eq (car u) v))) + +(de mksetq (u v) (list 'setq u v)) + +(de mkvar (u v) u) + +(de rread nil + (prog (x) + (setq x (token)) + (return + (cond + ((and (equal ttype!* 3) (eq x '!()) (rrdls)) + (t x)))) ) + +(de rrdls nil + (prog (x r) +a (setq x (rread)) + (cond + ((null (equal ttype!* 3)) (go b)) + ((eq x '!)) (return (reverse r))) % REVERSIP not yet defined. + ((null (eq x '!.)) (go b))) + (setq x (rread)) + (token) + (return (nconc (reverse r) x)) +b (setq r (cons x r)) + (go a))) + +(de token nil + (prog (x y) + (setq x crchar!*) +a (cond + ((seprp x) (go sepr)) + ((digit x) (go number)) + ((liter x) (go letter)) + ((eq x '!%) (go coment)) + ((eq x '!!) (go escape)) + ((eq x '!') (go quote)) + ((eq x '!") (go string))) + (setq ttype!* 3) + (cond ((delcp x) (go d))) + (setq nxtsym!* x) +a1 (setq crchar!* (readch)) + (go c) +escape(setq y (cons x y)) + (setq x (readch)) +letter(setq ttype!* 0) +let1 (setq y (cons x y)) + (cond + ((or (digit (setq x (readch))) (liter x)) (go let1)) + ((eq x '!!) (go escape))) + (setq nxtsym!* (intern (compress (reverse y)))) +b (setq crchar!* x) +c (return nxtsym!*) +number(setq ttype!* 2) +num1 (setq y (cons x y)) + (cond ((digit (setq x (readch))) (go num1))) + (setq nxtsym!* (compress (reverse y))) + (go b) +quote (setq crchar!* (readch)) + (setq nxtsym!* (list 'quote (rread))) + (setq ttype!* 4) + (go c) +string(prog (raise !*lower) + (setq raise !*raise) + (setq !*raise nil) + strinx(setq y (cons x y)) + (cond ((null (eq (setq x (readch)) '!")) (go strinx))) + (setq y (cons x y)) + (setq nxtsym!* (mkstrng (compress (reverse y)))) + (setq !*raise raise)) + (setq ttype!* 1) + (go a1) +coment(cond ((null (eq (readch) !$eol!$)) (go coment))) +sepr (setq x (readch)) + (go a) +d (setq nxtsym!* x) + (setq crchar!* '! ) + (go c))) + +(setq crchar!* '! ) + +(de delcp (u) (or (eq u '!;) (eq u '!$))) + +(de mkstrng (u) u) + +(de seprp (u) (or (eq u blank) (eq u tab) (eq u !$eol!$))) + +(de scan nil + (prog (x y) + (cond ((null (eq cursym!* '!*semicol!*)) (go b))) +a (setq nxtsym!* (token)) +b (cond + ((or (null (atom nxtsym!*)) (numberp nxtsym!*)) (go l)) + ((and (setq x (get nxtsym!* 'newnam)) (setq nxtsym!* x)) + (go b)) + ((eq nxtsym!* 'comment) (go comm)) + ((and + (eq nxtsym!* '!') + (setq cursym!* (list 'quote (rread)))) + (go l1)) + ((null (setq x (get nxtsym!* 'switch!*))) (go l)) + ((eq (cadr x) '!*semicol!*) + (return (setq cursym!* (cadr x)))) ) +sw1 (setq nxtsym!* (token)) + (cond + ((or + (null (car x)) + (null (setq y (assoc nxtsym!* (car x)))) ) + (return (setq cursym!* (cadr x)))) ) + (setq x (cdr y)) + (go sw1) +comm (cond ((eq (readch) '!;) (setq crchar!* '! )) (t (go comm))) + (go a) +l (setq cursym!* + (cond + ((null (eqcar nxtsym!* 'string)) nxtsym!*) + (t (cons 'quote (cdr nxtsym!*)))) ) +l1 (setq nxtsym!* (token)) + (return cursym!*))) + +(de ifstat nil + (prog (condx condit) +a (setq condx (xread t)) + (setq condit (nconc condit (list (list condx (xread t)))) ) + (cond + ((null (eq cursym!* 'else)) (go b)) + ((eq (scan) 'if) (go a)) + (t (setq condit + (nconc condit (list (list t (xread1 t)))) ))) +b (return (cons 'cond condit)))) + +(de procstat nil + (prog (x y) + (cond ((eq cursym!* 'symbolic) (scan))) + (cond + ((eq cursym!* '!*semicol!*) + (return (null (setq !*mode 'symbolic)))) ) + (setq fname!* (scan)) + (cond ((atom (setq x (xread1 nil))) (setq x (list x)))) + (setq y (xread nil)) + (cond ((flagp (car x) 'lose) (return nil))) + (putd (car x) 'expr (list 'lambda (cdr x) y)) + (setq fname!* nil) + (return (list 'quote (car x)))) ) + +(de blockstat nil + (prog (x hold varlis !*blockp) +a0 (setq !*blockp t) + (scan) + (cond + ((null (or (eq cursym!* 'integer) (eq cursym!* 'scalar))) + (go a))) + (setq x (xread nil)) + (setq varlis + (nconc + (cond ((eqcar x '!*comma!*) (cdr x)) (t (list x))) + varlis)) + (go a0) +a (setq hold (nconc hold (list (xread1 nil)))) + (setq x cursym!*) + (scan) + (cond ((not (eq x 'end)) (go a))) + (return (mkprog varlis hold)))) + +(de mkprog (u v) (cons 'prog (cons u v))) + +(de gostat nil + (prog (x) (scan) (setq x (scan)) (scan) (return (list 'go x)))) + +(put 'go 'stat 'gostat) + +(de rlis nil + (prog (x) + (setq x cursym!*) + (return (list x (list 'quote (list (xread t))))))) + +(de endstat nil (prog (x) (setq x cursym!*) (scan) (return (list x)))) + +% Now we have just enough to be able to start to express ourselves in +% (a subset of) rlisp. + +(begin2) + +!@reduce := concat(!@srcdir, "/../../src"); + +rds(xxx := open("$reduce/packages/support/build.red",'input)); + +(close xxx) + +(load!-package!-sources prolog_file 'support) + +(load!-package!-sources 'rlisp 'rlisp) + +(load!-package!-sources 'smacros 'support) + +(load!-package!-sources rend_file 'support) + +(load!-package!-sources 'poly 'poly) + +(load!-package!-sources 'alg 'alg) + +(load!-package!-sources 'arith 'arith) % Needed by roots, specfn*, (psl). + +(load!-package!-sources 'entry 'support) + +(load!-package!-sources 'remake 'support) + +(setq !*comp nil) + + + +(begin) + +symbolic; + +!#if (and (not (memq 'embedded lispsystem!*)) (not !*savedef)) + +faslout 'user; + +% +% The "user" module is only useful when building a full system, since +% in the bootstrap the files u01.lsp to u60.lsp will probably not exist +% and it is CERTAIN that they are not useful. +% + +if modulep 'cslcompat then load!-module 'cslcompat; + + +symbolic procedure c!:install(name, env, c!-version, !&optional, c1); + begin + scalar v, n; + if c1 then return check!-c!-code(name, env, c!-version, c1); + put(name, 'c!-version, c!-version); + if null env then return name; + v := mkvect sub1 length env; + n := 0; + while env do << + putv(v, n, car env); + n := n + 1; + env := cdr env >>; +% I only instate the environment if there is nothing useful there at +% present. Actually this is even stronger. When a built-in function is +% set up it gets NIL in its environment cell by default. Things that are +% not defined at all have themselves there. + if symbol!-env name = nil then symbol!-set!-env(name, v); + put(name, 'funarg, v); + return name; + end; + +rdf "$srcdir/../../cslbuild/generated-c/u01.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u02.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u03.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u04.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u05.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u06.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u07.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u08.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u09.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u10.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u11.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u12.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u13.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u14.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u15.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u16.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u17.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u18.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u19.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u20.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u21.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u22.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u23.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u24.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u25.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u26.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u27.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u28.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u29.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u30.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u31.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u32.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u33.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u34.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u35.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u36.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u37.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u38.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u39.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u40.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u41.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u42.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u43.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u44.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u45.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u46.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u47.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u48.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u49.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u50.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u51.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u52.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u53.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u54.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u55.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u56.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u57.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u58.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u59.lsp"$ +rdf "$srcdir/../../cslbuild/generated-c/u60.lsp"$ + +if modulep 'smacros then load!-module 'smacros; + +faslend; +!#endif + +faslout 'remake; + +!#if (and (not (memq 'embedded lispsystem!*)) (not !*savedef)) + +load!-module "user"; + +!#endif + +!@reduce := concat(!@srcdir, "/../../src"); + +in "$reduce/packages/support/remake.red"$ + +global '(reduce_base_modules reduce_extra_modules reduce_test_cases); + +symbolic procedure get_configuration_data(); +% Read data from a configuration file that lists the modules that must +% be processed. NOTE that this and the next few funtions will ONLY +% work properly if REDUCE had been started up with the correct +% working directory. This is (just about) acceptable because these are +% system maintainance functions rather than generally flexible things +% for arbitrary use. + begin + scalar i, w, e; +% Configuration information is held in a file called something like +% "package.map". + if boundp 'microreduce and symbol!-value 'microreduce then + i := "$srcdir/../../src/packages/micropackage.map" + else if boundp 'minireduce and symbol!-value 'minireduce then + i := "$srcdir/../../src/packages/minipackage.map" + else i := "$srcdir/../../src/packages/package.map"; + i := open(i, 'input); + i := rds i; + e := !*echo; + !*echo := nil; + w := read(); + !*echo := e; + i := rds i; + close i; + reduce_base_modules := + for each x in w conc + if member('core, cddr x) and + member('csl, cddr x) then list car x else nil; + reduce_extra_modules := + for each x in w conc + if not member('core, cddr x) and + member('csl, cddr x) then list car x else nil; + reduce_test_cases := + for each x in w conc + if member('test, cddr x) and + member('csl, cddr x) then list car x else nil; + for each x in w do + if member('csl, cddr x) then put(car x, 'folder, cadr x); + % princ "reduce_base_modules: "; print reduce_base_modules; + % princ "reduce_extra_modules: "; print reduce_extra_modules; + % princ "reduce_test_cases: "; print reduce_test_cases; + return; + end; + +symbolic procedure build_reduce_modules names; + begin + scalar w; +!#if !*savedef + !*savedef := t; +!#else + !*savedef := nil; +!#endif + make!-special '!*native_code; + !*native_code := nil; + get_configuration_data(); + + + window!-heading list!-to!-string explodec car names; +!#if !*savedef +% When building the bootstrap version I want to record what switches +% get declared... + if not getd 'original!-switch then << + w := getd 'switch; + putd('original!-switch, car w, cdr w); + putd('switch, 'expr, + '(lambda (x) + (dolist (y x) (princ "+++ Declaring a switch: ") (print y)) + (original!-switch x))) >>; +!#endif + package!-remake car names; + if null (names := cdr names) then << + printc "Recompilation complete"; + window!-heading "Recompilation complete" >>; +!#if (or !*savedef (memq 'embedded lispsystem!*)) + if null names then restart!-csl 'begin + else restart!-csl('(remake build_reduce_modules), names) +!#else + if null names then restart!-csl '(user begin) + else restart!-csl('(remake build_reduce_modules), names) +!#endif + end; + +symbolic procedure test_a_package names; + begin + scalar packge, logname, logtmp, logfile, start_time, start_gctime, gt; + scalar redef, quitfn, oll, rr; + princ "TESTING: "; print car names; + window!-heading list!-to!-string explodec car names; + !*backtrace := nil; + !*errcont := t; + !*extraecho := t; % Ensure standard environment for the test... + !*int := nil; % ... so that results are predictable. + packge := car names; + verbos nil; +% load!-latest!-patches(); +% Normally logs from testing go in testlogs/name.rlg, however you may +% may sometimes want to put them somewhere else. If you do then launch reduce +% along the lines +% reduce -D@log="mylogs" ... +% and ensure that /mylogs exists. + if boundp '!@log and stringp symbol!-value '!@log then + logname := symbol!-value '!@log + else logname := "testlogs"; + logname := concat(logname, "/"); + logtmp := concat(logname, concat(car names, ".tmp")); + logname := concat(logname, concat(car names,".rlg")); + logfile := open(logtmp, 'output); + get_configuration_data(); + begin + scalar !*terminal!-io!*, !*standard!-output!*, !*error!-output!*, + !*trace!-output!*, !*debug!-io!*, !*query!-io!*, !*errcont, + outputhandler!*; + !*terminal!-io!* := !*standard!-output!* := !*error!-output!* := logfile; + !*trace!-output!* := !*debug!-io!* := !*query!-io!* := logfile; + oll := linelength 80; + princ date(); princ " run on "; printc cdr assoc('name, lispsystem!*); + load!-package packge; + if get(packge,'folder) then packge := get(packge,'folder); + packge := concat("$srcdir/../../src/packages/", + concat(packge, + concat("/", + concat(car names,".tst")))); + redef := !*redefmsg; + !*redefmsg := nil; + quitfn := getd 'quit; +% At least at one stage at least one test file ends in "quit;" rather than +% "end;" and the normal effect would be that this leads it to cancel +% all execution instantly. To avoid that I will undefine the function +% "quit", but restore it after the test. I reset !*redefmsg to avoid getting +% messages about this. I redefined quit to something (specifically "posn") +% that does not need an argument and that is "harmless". + remd 'quit; + putd('quit, 'expr, 'posn); + start_time := time(); + start_gctime := gctime(); + !*mode := 'algebraic; + !*extraecho := t; % Ensure standard environment for the test... + !*int := nil; % ... so that results are predictable. + !*errcont := t; +% resource!-limit is a special feature in CSL so that potentially wild +% code can be run with it being stopped harshly if it gets stuck. +% The first argument is an expression to evaluate. The next 4 are +% a time limit, in seconds +% a "cons" limit, in megaconses +% a limit on the number of thousands of I/O bytes that can be +% performed, with both reading and printing counted +% a limit on the number of Lisp-level errors that can be raised. +% note that that can be large if errorset is used to trap them. +% +% If a limit is specified as a negative value (typically -1) then that +% resource is not applied. +% The first 3 limits are applied in an APPROXIMATE way, and the first +% is seriously sensitive the the speed of the computer you are running +% on, so should be used with real care. At the end the return value +% is atomic if a limit expired, otherwise ncons of the regular value. +% A global variable *resources* should end up a list of 4 values +% showing the usage in each category. + +% The settings here are intended to be fairly conservative... +% Time: On an Intel Q6600 CPU the longest test runs in under 20 seconds, +% so allowing 3 minutes gives almost a factor of 10 slack. If +% many people are running slow(ish) machines still I can increase +% the limit. +% Space: The amount of space used ought to be pretty independent of +% the computer used. Measuring on 32 and 64-bit systems will +% give minor differences. But the limit given here seems to allow +% all the current tests to run with a factor of 2 headroom +% in case the test-scripts are updated. +% IO: The "crack" package has code in it that checkpoints its state +% to disc periodically, and tests that activate that use amazingly +% more IO than the others. The limit at 10 Mbytes suits the +% relevant current tests. If a broken package leads to a test +% script looping this then means that the resulting log file is no +% larger than (about) 10 Mbytes, which is ugly but managable. +% Errors: Some REDUCE packages make extensive use of errorset and +% predictable use of "error" (for lack of use of catch and throw, +% usually). So I do not constrain errors here. But if things were +% ever such that no errors were expected I could enforce that +% condition here. + + rr := resource!-limit(list('in_list1, mkquote packge, t), + 300, % allow 5 minutes per test + 200, % allow 200 megaconses + 10000,% allow ten megabytes of I/O + -1); % Do not limit Lisp-level errors at all + erfg!* := nil; + terpri(); + putd('quit, car quitfn, cdr quitfn); + !*redefmsg := redef; + terpri(); + prin2 "Time for test: "; + gt := time() - start_time; +% I ensure that the reported time is at least 1 millisecond. + if gt = 0 then gt := 1; + prin2 gt; + prin2 " ms"; + if (gt := gctime() - start_gctime) > 0 then << + prin2 ", plus GC time: "; + prin2 gt; + prin2 " ms" >>; + terpri(); +% Temp while I watch things + if atom rr then printc "+++++ Error: Resource limit exceeded"; + princ "@@@@@ Resources used: "; print !*resources!*; + linelength oll + end; + close logfile; + delete!-file logname; + rename!-file(logtmp, logname); + names := cdr names; + if null names then << + printc "Testing complete"; + window!-heading "Testing complete"; + restart!-csl t >> + else restart!-csl('(remake test_a_package), names) + end; + +symbolic procedure report_incomplete_tests names; + begin +% Displays information about what "complete_tests" would do + scalar packge, tfile, logname; + scalar date1, date2, date3; + get_configuration_data(); + for each packge in names do << + tfile := packge; + if get(packge,'folder) then tfile := get(packge,'folder); + tfile := concat("$srcdir/../../src/packages/", + concat(tfile, + concat("/", + concat(packge,".tst")))); + if boundp '!@log and stringp symbol!-value '!@log then + logname := symbol!-value '!@log + else logname := "testlogs"; + logname := concat(logname, concat("/", concat(packge,".rlg"))); + date1 := filedate "reduce.img"; + date2 := filedate tfile; + date3 := filedate logname; + if null date1 then date1 := date(); + if null date2 then date2 := date(); + if null date3 or + datelessp(date3, date1) or datelessp(date3, date2) then << + princ "NEED TO TEST: "; print packge >> >> + end; + +symbolic procedure complete_tests names; + begin +% Just like the previous testing code except that logs that are already up +% to date are not re-generated. + scalar packge, tfile, logname, logfile, logtmp, + start_time, start_gctime, gt, rr; + scalar date1, date2, date3, oll; + !*backtrace := nil; + !*errcont := t; + !*extraecho := t; % Ensure standard environment for the test... + !*int := nil; % ... so that results are predictable. + verbos nil; + get_configuraion_data(); +top: + tfile := packge := car names; + if get(tfile,'folder) then tfile := get(tfile,'folder); + tfile := concat("$srcdir/../../src/packages/", + concat(tfile, + concat("/", + concat(packge,".tst")))); + if boundp '!@log and stringp symbol!-value '!@log then + logname := symbol!-value '!@log + else logname := "testlogs"; + logname := concat(logname, "/"); + logtmp := concat(logname, concat(packge, ".tmp")); + logname := concat(logname, concat(packge, ".rlg")); + date1 := filedate "reduce.img"; + date2 := filedate tfile; + date3 := filedate logname; + if null date1 then date1 := date(); + if null date2 then date2 := date(); + if null date3 or + datelessp(date3, date1) or datelessp(date3, date2) then << + princ "TESTING: "; print packge; + window!-heading list!-to!-string explodec packge; + logfile := open(logtmp, 'output); + start_time := time(); + start_gctime := gctime(); + begin + scalar !*terminal!-io!*, !*standard!-output!*, !*error!-output!*, + !*trace!-output!*, !*debug!-io!*, !*query!-io!*, !*errcont, + outputhandler!*, redef, quitfn; + !*terminal!-io!* := !*standard!-output!* := !*error!-output!* := logfile; + !*trace!-output!* := !*debug!-io!* := !*query!-io!* := logfile; + oll := linelength 80; + princ date(); princ " run on "; + printc cdr assoc('name, lispsystem!*); + load!-package packge; + !*mode := 'algebraic; + !*extraecho := t; % Ensure standard environment for the test... + !*int := nil; % ... so that results are predictable. + redef := !*redefmsg; + !*redefmsg := nil; + quitfn := getd 'quit; + remd 'quit; + putd('quit, 'expr, 'posn); + !*errcont := t; + rr := resource!-limit(list('in_list1, mkquote tfile, t), + 300, % allow 5 minutes per test + 200, % allow 200 megaconses + 10000,% allow ten megabytes of I/O + -1); % Do not limit Lisp-level errors at all + erfg!* := nil; + terpri(); + putd('quit, car quitfn, cdr quitfn); + !*redefmsg := redef; + terpri(); + prin2 "Time for test: "; + gt := time() - start_time; + if gt = 0 then gt := 1; + prin2 gt; + prin2 " ms"; + if (gt := gctime() - start_gctime) > 0 then << + prin2 ", plus GC time: "; + prin2 gt; + prin2 " ms" >>; + if atom rr then printc "+++++ Error: Resource limit exceeded"; + princ "@@@@@ Resources used: "; print !*resources!*; + terpri(); + linelength oll + end; + close logfile; + delete!-file logname; + rename!-file(logtmp, logname) >> + else if cdr names then << + names := cdr names; + go to top >>; + names := cdr names; + if null names then restart!-csl t + else restart!-csl('(remake complete_tests), names) + end; + +symbolic procedure profile_compare_fn(p, q); + (float caddr p/float cadr p) < (float caddr q/float cadr q); + +% +% This function runs a test file and sorts out what the top 350 +% functions in it. It appends their names to "profile.dat". +% + +% I need to talk a little about the interaction between profiling and +% patching. Well firstly I arrange that whenever I run a profiling job +% I rebuild REDUCE with the latest paches. This may involve re-compiling +% the patches.red source. Thus when a test is run the current patches +% will be in place. Patched functions are first defined with funny names +% (including a hash based on their definition) and then copied into place +% when a package is loaded. However MAPSTORE and the CSL instrumentation +% attributes their cost to the hash-extended name even though the +% functions may have been called via the simple one. Thus in the face +% of patches one can expect the profile data to refer to some names that +% are long and curious looking. Throughout all this I assume that there will +% never be embarassing collisions in my hash functions. + +symbolic procedure profile_a_package names; + begin + scalar packge, oll, w, w1, w2, quitfn, !*errcont, rr; + princ "PROFILING: "; print car names; + !*backtrace := nil; + !*errcont := t; + !*int := nil; + packge := car names; + verbos nil; + load!-package packge; + get_configuration_data(); + if get(packge,'folder) then packge := get(packge,'folder); + packge := concat("$srcdir/../../src/packages/", + concat(packge, + concat("/", + concat(car names,".tst")))); + oll := linelength 80; + !*mode := 'algebraic; + window!-heading list!-to!-string explodec car names; + quitfn := getd 'quit; + remd 'quit; + putd('quit, 'expr, 'posn); + mapstore 4; % reset counts; + !*errcont := t; +% I try hard to arrange that even if the test fails I can continue and that +% input & output file selection is not messed up for me. + w := wrs nil; w1 := rds nil; + wrs w; rds w1; + rr := resource!-limit(list('errorset, + mkquote list('in_list1, mkquote packge, t), + nil, nil), + 300, % allow 5 minutes per test + 200, % allow 200 megaconses + 10000,% allow ten megabytes of I/O + -1); % Do not limit Lisp-level errors at all + wrs w; rds w1; + erfg!* := nil; + terpri(); + putd('quit, car quitfn, cdr quitfn); + w := sort(mapstore 2, function profile_compare_fn); + w1 := nil; + while w do << + w2 := get(caar w, '!*savedef); +% if eqcar(w2, 'lambda) then << +% princ "md60: "; print (caar w . cdr w2); +% princ "= "; print md60 (caar w . cdr w2) >>; + if eqcar(w2, 'lambda) then w1 := (caar w . md60 (caar w . cdr w2) . + cadar w . caddar w) . w1; + w := cdr w >>; + w := w1; + % I collect the top 350 functions as used by each test, not because all + % that many will be wanted but because I might as well record plenty + % of information here and discard unwanted parts later on. + for i := 1:349 do if w1 then w1 := cdr w1; + if w1 then rplacd(w1, nil); + % princ "MODULE "; prin car names; princ " suggests "; + % print for each z in w collect car z; + w1 := open("profile.dat", 'append); + w1 := wrs w1; + linelength 80; + if atom rr then printc "% +++++ Error: Resource limit exceeded"; + princ "% @@@@@ Resources used: "; print !*resources!*; + princ "("; prin car names; terpri(); + for each n in w do << + princ " ("; prin car n; princ " "; + if posn() > 30 then << terpri(); ttab 30 >>; + prin cadr n; + % I also display the counts just to help me debug & for interest. + princ " "; prin caddr n; princ " "; princ cdddr n; + printc ")" >>; + printc " )"; + terpri(); + close wrs w1; + linelength oll; + names := cdr names; + if null names then << + printc "Profiling complete"; + window!-heading "Profiling complete"; + restart!-csl t >> + else restart!-csl('(remake profile_a_package), names) + end; + +symbolic procedure trim_prefix(a, b); + begin + while a and b and car a = car b do << + a := cdr a; + b := cdr b >>; + if null a then return b + else return nil + end; + +fluid '(time_info); + +symbolic procedure read_file f1; + begin +% I take the view that I can afford to read the whole of a file into +% memory at the start of processing. This makes life easier for me +% and the REDUCE log files are small compared with current main memory sizes. + scalar r, w, w1, n, x; + scalar p1, p2, p3, p4, p5, p6, p7; +% To make comparisons between my CSL logs and some of the Hearn "reference +% logs", which are created using a different script, I will discard +% lines that match certain patterns! Note that if the reference logs change +% the particular tests I perform here could become out of date! Also if any +% legitimate test output happened to match one of the following strings +% I would lose out slightly. + p1 := explodec "REDUCE 3.8,"; + p2 := explodec "1: 1:"; + p3 := explodec "2: 2: 2:"; + p4 := explodec "3: 3: "; % a prefix to first real line of output. + p5 := explodec "4: 4: 4:"; + p6 := explodec "5: 5:"; + p7 := explodec "Quittin"; % nb left so that the "g" remains! + % this is so that the match is detected. + r := nil; + n := 0; + while not ((w := readline f1) = !$eof!$) do << + w1 := explodec w; + if x := trim_prefix(p4, w1) then + r := ((n := n + 1) . list!-to!-string x) . r + else if trim_prefix(p1, w1) or + trim_prefix(p2, w1) or + trim_prefix(p3, w1) or + trim_prefix(p5, w1) or + trim_prefix(p6, w1) or + trim_prefix(p7, w1) then nil + else r := ((n := n + 1) . w) . r >>; + w := r; +% The text scanned for here is expected to match that generated by the +% test script. I locate the last match in a file, extract the numbers +% and eventually write them to testlogs/times.log + n := explodec "Time for test:"; + while w and null (x := trim_prefix(n, explodec cdar w)) do w := cdr w; + if null w then << + time_info := nil; + return reversip r >>; + while eqcar(x, '! ) do x := cdr x; + w := n := nil; + while digit car x do << w := car x . w; x := cdr x >>; + while eqcar(x, '! ) do x := cdr x; + if x := trim_prefix(explodec "ms, plus GC time:", x) then << + while eqcar(x, '! ) do x := cdr x; + while digit car x do << n := car x . n; x := cdr x >> >>; + if null w then w := '(!0); + if null n then n := '(!0); + time_info := compress reverse w . compress reverse n; + return reversip r; + end; + +symbolic procedure roughly_equal(a, b); + begin +% a and b are strings repesenting lines of text. I want to test if they +% match subject to some floating point slop. + scalar wa, wb, adot, bdot; + if a = b then return t; + a := explodec a; + b := explodec b; +top: +% First deal with end of line matters. + if null a and null b then return t + else if null a or null b then return nil; +% next split off any bits of a and b up to a digit + wa := wb := nil; + while a and not digit car a do << + wa := car a . wa; + a := cdr a >>; + while b and not digit car b do << + wb := car b . wb; + b := cdr b >>; + if not (wa = wb) then return nil; +% now both a and b start with digits. I will seek a chunk of the +% form nnn.mmmE+xxx where Exxx is optional... +% Note that any leading sign on the float has been checked already! + wa := wb := nil; + adot := bdot := nil; + while a and digit car a do << + wa := car a . wa; + a := cdr a >>; + if eqcar(a, '!.) then << + adot := t; + wa := car a . wa; + a := cdr a >>; + while a and digit car a do << + wa := car a . wa; + a := cdr a >>; + if eqcar(a, '!e) or eqcar(a, '!E) then << + adot := t; + wa := car a . wa; + a := cdr a; + if eqcar(a, '!+) or eqcar(a, '!-) then << + wa := car a . wa; + a := cdr a >>; + while a and digit car a do << + wa := car a . wa; + a := cdr a >> >>; +% Now all the same to grab a float from b + while b and digit car b do << + wb := car b . wb; + b := cdr b >>; + if eqcar(b, '!.) then << + bdot := t; + wb := car b . wb; + b := cdr b >>; + while b and digit car b do << + wb := car b . wb; + b := cdr b >>; + if eqcar(b, '!e) or eqcar(b, '!E) then << + bdot := t; + wb := car b . wb; + b := cdr b; + if eqcar(b, '!+) or eqcar(b, '!-) then << + wb := car b . wb; + b := cdr b >>; + while b and digit car b do << + wb := car b . wb; + b := cdr b >> >>; +% Now one possibility is that I had an integer not a float, +% and in that case I want an exact match + if not adot or not bdot then << + if wa = wb then goto top + else return nil >>; + if wa = wb then goto top; % textual match on floating point values + wa := compress reversip wa; + wb := compress reversip wb; + if fixp wa then wa := float wa; + if fixp wb then wb := float wb; + if not (floatp wa and floatp wb) then return nil; % messed up somehow! + if wa = wb then goto top; +% now the crucial approximate floating point test - note that both numbers +% are positive, but that they may be extreme in range. +% As a cop-out I am going to insist that if values are either very very big +% or very very small that they match as text. + if wa > 1.0e100 or wb > 1.0e100 then return nil; + if wa < 1.0e-100 or wb < 1.0e-100 then return nil; + wa := (wa - wb)/(wa + wb); + if wa < 0 then wa := -wa; + if wa > 0.0001 then return nil; % pretty crude! + goto top + end; + +symbolic procedure in_sync(d1, n1, d2, n2); + begin + for i := 1:n1 do if d1 then << % skip n1 lines from d1 + d1 := cdr d1 >>; + for i := 1:n2 do if d2 then << % skip n2 lines from d2 + d2 := cdr d2 >>; +% If one is ended but the other is not then we do not have a match. If +% both are ended we do have one. + if null d1 then return null d2 + else if null d2 then return nil; +% Here I insist on 3 lines that agree before I count a match as +% having been re-established. + if not roughly_equal(cdar d1, cdar d2) then return nil; + d1 := cdr d1; d2 := cdr d2; + if null d1 then return null d2 + else if null d2 then return nil; + if not roughly_equal(cdar d1, cdar d2) then return nil; + d1 := cdr d1; d2 := cdr d2; + if null d1 then return null d2 + else if null d2 then return nil; + if not roughly_equal(cdar d1, cdar d2) then return nil; + d1 := cdr d1; d2 := cdr d2; + if null d1 then return null d2 + else if null d2 then return nil + else return t + end; + +fluid '(time_data time_ratio gc_time_ratio log_count); + +symbolic procedure prinright(x, w); + begin + scalar xx, xl; + xx := explodec x; + xl := length xx; + while w > xl do << princ " "; xl := xl + 1 >>; + princ x; + end; + +symbolic procedure file_compare(f1, f2, name); + begin + scalar i, j, d1, d2, t1, gt1, t2, gt2, time_info; + d1 := read_file f1; + if null time_info then t1 := gt1 := 0 + else << t1 := car time_info; gt1 := cdr time_info >>; + d2 := read_file f2; + if null time_info then t2 := gt2 := 0 + else << t2 := car time_info; gt2 := cdr time_info >>; + i := wrs time_data; + j := set!-print!-precision 3; + prin name; + ttab 17; + if zerop t1 then princ " ---" + else << prinright(t1, 8); +% Tag the time with an asterisk if it will not participate in the +% eventual overall timing report. + if t1<=200 then princ "*"; + ttab 30; prinright(gt1, 8) >>; + ttab 40; + if zerop t2 then princ " ---" + else << prinright(t2, 9); + if t2<=200 then princ "*"; + ttab 50; prinright(gt2, 8) >>; + ttab 60; + if zerop t1 or zerop t2 then princ " *** ***" + else begin + scalar r1, gr1, w; + r1 := float t1 / float t2; + gr1 := float (t1+gt1)/float (t2+gt2); +% I will only use tests where the time taken was over 200ms in my eventual +% composite summary of timings, since measurement accuracy can leave the +% really short tests pretty meaningless. + if t1 > 200 and t2 > 200 then << +% But I will go further than that and give less weight to any test whose time +% is under 1 second, so that the cut-off is gradual rather than abrupt. + w := min(t1, t2); +% This means that if w (the smaller time) = 200 then then +% the test does not contribute to the average, while if w>=1000 +% it contributes fully. + if w < 1000.0 then w := (w - 200.0)/800.0 + else w := 1.0; + time_ratio := time_ratio * expt(r1, w); + gc_time_ratio := gc_time_ratio * expt(gr1, w); + log_count := log_count + w >>; + princ r1; + ttab 70; + princ gr1; + end; + terpri(); + set!-print!-precision j; + wrs i; +% The next segment of code is a version of "diff" to report ways in which +% reference and recent log files match or diverge. +% I can not see a neat way to get a "structured" control structure +% here easily. Ah well, drop back to GOTO statements! +top: + if null d1 then << % end of one file + if d2 then terpri(); + i := 0; + while d2 and i < 20 do << + princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; + d2 := cdr d2; + i := i + 1 >>; + if d2 then printc "..."; + return >>; + if null d2 then << % end of other file + i := 0; + while d1 and i < 20 do << + princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; + d1 := cdr d1; + i := i + 1 >>; + if d1 then printc "..."; + return >>; +% The test "roughly_equal" compares allowing some tolerance on floating +% point values. This is because REDUCE uses platform libraries for +% floating point elementary functions and printing, so small differences +% are expected. This is perhaps uncomfortable, but is part of reality, and +% the test here makes comparison output much more useful in that the +% differences shown up are better limited towards "real" ones. + if roughly_equal(cdar d1, cdar d2) then << + d1 := cdr d1; + d2 := cdr d2; + go to top >>; +% I will first see if there are just a few blank lines inserted into +% one or other file. This special case is addressed here because it +% appears more common a possibility than I had expected. + if cdar d1 = "" and cdr d1 and roughly_equal(cdadr d1, cdar d2) then << + princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; + d1 := cdr d1; + go to top >> + else if cdar d1 = "" and cdr d1 and cdadr d1 = "" and cddr d1 and + roughly_equal(cdaddr d1, cdar d2) then << + princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; + d1 := cdr d1; + princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; + d1 := cdr d1; + go to top >> + else if cdar d2 = "" and cdr d2 and + roughly_equal(cdadr d2, cdar d1) then << + princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; + d2 := cdr d2; + go to top >> + else if cdar d2 = "" and cdr d2 and cdadr d2 = "" and cddr d2 and + roughly_equal(cdaddr d2, cdar d1) then << + princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; + d2 := cdr d2; + princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; + d2 := cdr d2; + go to top >>; + i := 1; +seek_rematch: + j := 0; +inner: + if in_sync(d1, i, d2, j) then << + terpri(); + for k := 1:i do << + princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; + d1 := cdr d1 >>; + for k := 1:j do << + princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; + d2 := cdr d2 >>; +% Should be in step again here. + if null d1 then return + else go to top >>; + j := j + 1; + i := i - 1; + if i >= 0 then go to inner; + i := j; +% I am prepared to seek 80 lines ahead on each side before I give up. +% The number 80 is pretty much arbitrary. + if i < 80 then goto seek_rematch; + terpri(); + i := 0; + while d2 and i < 20 do << + princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; + d2 := cdr d2; + i := i+1 >>; + if d2 then printc "..."; + i := 0; + while d1 and i < 20 do << + princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; + d1 := cdr d1; + i := i+1 >>; + if d1 then printc "..."; + printc "Comparison failed." + end; + +fluid '(which_module); + +symbolic procedure check_a_package; + begin + scalar oll, names, p1, logname, mylogname, mylog, reflogname, reflog, + time_data, time_ratio, gc_time_ratio, log_count; + get_configuration_data(); + if boundp 'which_module and symbol!-value 'which_module and + not (symbol!-value 'which_module = "") then << + names := compress explodec symbol!-value 'which_module; + if member(names, reduce_test_cases) then names := list names + else error(0, list("unknown module to check", which_module)) >> + else names := reduce_test_cases; +% I write a summary of timing information into csllogs/times.log + time_data := open("testlogs/times.log", 'output); + p1 := wrs time_data; + princ "MODULE"; + ttab 21; princ "Local"; ttab 32; princ "(GC)"; + ttab 40; princ "Reference"; ttab 52; princ "(GC)"; + ttab 55; princ "Ratio"; ttab 65; printc "inc GC"; + wrs p1; + terpri(); + oll := linelength 100; + printc "=== Comparison results ==="; + time_ratio := gc_time_ratio := 1.0; log_count := 0.0; + for each packge in names do << + terpri(); + princ "CHECKING: "; print packge; + if boundp '!@log and stringp symbol!-value '!@log then + logname := symbol!-value '!@log + else logname := "testlogs"; + mylogname := concat(logname, concat("/", concat(packge, ".rlg"))); + if get(packge,'folder) then p1 := get(packge,'folder) + else p1 := packge; + reflogname := concat("$srcdir/../../src/packages/", + concat(p1, + concat("/", + concat(packge,".rlg")))); + mylog := errorset(list('open, mkquote mylogname, ''input), nil, nil); + reflog := errorset(list('open, mkquote reflogname, ''input), nil, nil); + if errorp mylog then << + if not errorp reflog then close car reflog; + princ "No current log in "; print mylogname >> + else if errorp reflog then << + close car mylog; + princ "No reference log in "; print reflogname >> + else << + princ "LOGS: "; princ mylogname; princ " "; printc reflogname; + mylog := car mylog; reflog := car reflog; + file_compare(mylog, reflog, packge); + close mylog; + close reflog >> >>; + time_data := wrs time_data; + if not zerop log_count then << + time_ratio := expt(time_ratio, 1.0/log_count); + gc_time_ratio := expt(gc_time_ratio, 1.0/log_count); + terpri(); + p1 := set!-print!-precision 3; + princ "Over "; prin log_count; princ " tests the speed ratio was "; + print time_ratio; + princ " (or "; + prin gc_time_ratio; + printc " is garbage collection costs are included)"; + set!-print!-precision p1 >>; + close wrs time_data; + linelength oll; + end; + + +faslend; + +% faslout 'cslhelp; +% +% module cslhelp; +% +% global '(!*force); +% +% flag('(force),'switch); +% flag('(on),'eval); +% +% on force; +% +% symbolic procedure formhelp(u,vars,mode); +% list('help, 'list . for each x in cdr u collect mkquote x); +% +% if member('help, lispsystem!*) then << +% put('help, 'stat, 'rlis); +% flag('(help), 'go); +% put('help, 'formfn, 'formhelp) >>; +% +% off force; +% remflag('(on),'eval); +% +% endmodule; +% +% faslend; + + +load!-module 'remake; + +<< initreduce(); + date!* := "Bootstrap version"; + !@reduce := symbol!-value gensym(); + checkpoint('begin, "REDUCE") >>; + +!#if (and (not (memq 'embedded lispsystem!*)) (not !*savedef)) +load!-module 'user; +!#endif + +!@reduce := concat(!@srcdir, "/../../src"); + +get_configuration_data(); + +package!-remake2(prolog_file,'support); + +package!-remake2(rend_file,'support); + +package!-remake2('entry,'support); + +package!-remake2('smacros,'support); + +package!-remake2('remake,'support); + + +% The next lines have LOTS of hidden depth! They restart CSL repeatedly +% so that each of the modules that has to be processed gets dealt with in +% a fresh uncluttered environment. The list of modules is fetched from +% a configuration file which must have 3 s-expressions in it. The first +% is a list of basic modules that must be built to get a core version of +% REDUCE. The second list identifies modules that can be built one the core +% is ready for use, while the last list indicates which modules have +% associated test scripts. +% +% when the modules have been rebuild the system does a restart that +% kicks it back into REDUCE by calling begin(). This then continues +% reading from the stream that had been the standard input when this +% job started. Thus this script MUST be invoked as +% ./csl -obootstrapreduce.img -z buildreduce.lsp +% with the file buildreduce.lsp specified on the command line in the call. It +% will not work if you start csl manually and then do a (rdf ..) [say] +% on buildreduce.lsp. I told you that it was a little delicate. + +!#if !*savedef +% Some switches may be in the utter core and not introduced via the +% "switch" declaration... +for each y in oblist() do + if flagp(y, 'switch) then << + princ "+++ Declaring a switch: "; + print y >>; +!#endif + +get_configuration_data(); + +build_reduce_modules reduce_base_modules; + +% Now I want to do a cold-start so that I can create a sensible +% image for use in the subsequent build steps. This image should not +% contain ANYTHING extraneous. + +symbolic restart!-csl nil; + +(setq !*savedef (and (null (memq 'embedded lispsystem!*)) + (zerop (cdr (assoc 'c!-code lispsystem!*))))) +(make!-special '!*native_code) +(setq !*native_code nil) + +(setq !*backtrace t) + +(cond ((and (null !*savedef) + (null (memq 'embedded lispsystem!*))) + (load!-module 'user))) + +(load!-module 'cslcompat) + +(setq !*comp nil) + +(load!-module 'module) % Definition of load_package, etc. + +(load!-module 'cslprolo) % CSL specific code. + +(setq loaded!-packages!* '(cslcompat user cslprolo)) + +% NB I will re-load the "patches" module when REDUCE is started +% if there is a version newer than the one I load up here. Note that +% if there had not been a "patches.red" file I will not have a module to load +% here. +% +% (cond +% ((modulep 'patches) (load!-module 'patches))) + +(load!-package 'rlisp) + +(load!-package 'cslrend) + +(load!-package 'smacros) + +(load!-package 'poly) + +(load!-package 'arith) + +(load!-package 'alg) + +(load!-package 'mathpr) + +(cond + ((modulep 'tmprint) (load!-package 'tmprint))) + +(load!-package 'entry) + +% (write!-help!-module "$srcdir/../../src/util/reduce.inf" nil) +% +% (load!-module 'cslhelp) + +(setq version!* "Reduce (Free CSL version)") + +(setq date!* (date t)) + +(setq !*backtrace nil) + +(initreduce) + +(setq no_init_file nil) + +(setq !@csl (setq !@reduce (symbol!-value (gensym)))) + +% If the user compiles a new FASL module then I will let it +% generate native code by default. I build the bulk of REDUCE +% without that since I have statically-selected hot-spot compilation +% that gives me what I believe to be a better speed/space tradeoff. + +% Oh well, let's change that and disable it by dafault since at least on +% windows there are problems with windows vs cygwin file-names. + +(fluid '(!*native_code)) +(setq !*native_code nil) % Try T if you are VERY keen... + +%(checkpoint 'begin (bldmsg "%w, %w ..." version!* date!*)) +(checkpoint 'begin (bldmsg "")) + +(setq no_init_file t) + +(begin) + +% +% See the fairly length comments given a bit earlier about the +% delicacy of the next few lines! +% + +symbolic; + +load!-module 'remake; + +get_configuration_data(); + +build_reduce_modules reduce_extra_modules; + +symbolic; + +"**** **** REDUCE FULLY REBUILD **** ****"; + +% At this stage I have a complete workable REDUCE. If built using a +% basic CSL (I call it "bootstrapreduce" here) nothing has been compiled into C +% (everything is bytecoded), and it is big because it has retained all +% Lisp source code in the image file. If however I built using a version +% of CSL ("reduce") that did have things compiled into C then these will +% be exploited and the original Lisp source will be omitted from the +% image, leaving a production version. + +bye; + + diff -Nru mathpiper-0.81f+svn4469+dfsg2/lib/build_scripts/ccomp.red mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/ccomp.red --- mathpiper-0.81f+svn4469+dfsg2/lib/build_scripts/ccomp.red 1970-01-01 00:00:00.000000000 +0000 +++ mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/ccomp.red 2011-04-09 07:08:25.000000000 +0000 @@ -0,0 +1,3734 @@ +% "ccomp.red" Copyright 1991-2010, Codemist Ltd +% +% Compiler that turns Lisp code into C in a way that fits in +% with the conventions used with CSL/CCL +% +% A C Norman +% + +%% +%% Copyright (C) 2010, following the master REDUCE source files. * +%% * +%% Redistribution and use in source and binary forms, with or without * +%% modification, are permitted provided that the following conditions are * +%% met: * +%% * +%% * Redistributions of source code must retain the relevant * +%% copyright notice, this list of conditions and the following * +%% disclaimer. * +%% * Redistributions in binary form must reproduce the above * +%% copyright notice, this list of conditions and the following * +%% disclaimer in the documentation and/or other materials provided * +%% with the distribution. * +%% * +%% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * +%% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * +%% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS * +%% FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE * +%% COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, * +%% INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, * +%% BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS * +%% OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * +%% ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR * +%% TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF * +%% THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH * +%% DAMAGE. * +%% + + +symbolic; + +global '(!*fastvector !*unsafecar); +flag('(fastvector unsafecar), 'switch); + +% +% I start with some utility functions that provide something +% related to a FORMAT or PRINTF facility +% + +fluid '(C_file L_file O_file L_contents Setup_name File_name); + +symbolic macro procedure c!:printf(u,!&optional,env); +% inspired by the C printf function, but much less general. +% This macro is to provide the illusion that printf can take an +% arbitrary number of arguments. + list('c!:printf1, cadr u, 'list . cddr u); + +symbolic procedure c!:printf1(fmt, args); +% this is the inner works of print formatting. +% the special sequences that can occur in format strings are +% %s use princ (to print a name?) +% %d use princ (to print a number?) +% %a use prin +% %c as prin, but do not generate the sequence +% "*/" as part of the output (!) +% %t do a ttab() +% %< ensure at least 2 free chars on line +% %v print a variable.... magic for this compiler +% \n do a terpri() +% \q princ '!" to display quote marks + begin + scalar a, c; + fmt := explode2 fmt; + while fmt do << + c := car fmt; + fmt := cdr fmt; + if c = '!\ and (car fmt = '!n or car fmt = '!N) then << + terpri(); + fmt := cdr fmt >> + else if c = '!\ and (car fmt = '!q or car fmt = '!Q) then << + princ '!"; + fmt := cdr fmt >> + else if c = '!% then << + c := car fmt; + if null args then a := 'missing_arg + else a := car args; + if c = '!v or c = '!V then + if flagp(a, 'c!:live_across_call) then << + princ "stack["; + princ(-get(a, 'c!:location)); + princ "]" >> + else princ a + else if c = '!c or c = '!C then c!:safeprin a + else if c = '!a or c = '!A then prin a + else if c = '!t or c = '!T then ttab a + else if c = '!< then << + args := nil . args; % dummy so in effect no arg is used. + if posn() > 70 then terpri() >> + else princ a; + if args then args := cdr args; + fmt := cdr fmt >> + else princ c >> + end; + +% The following yukky code is for use in displaying C comments. I want to be +% able to annotate my code as in +% ... /* load the literal "something" */ +% where the literal is displayed. But if the literal were to be a string +% with the character sequence "*/" within it I would get into trouble... + +symbolic procedure c!:safeprin x; + begin + scalar a, b; + a := explode x; + while a do << + if eqcar(a, '!/) and b then princ " "; + princ car a; + b := eqcar(a, '!*); + a := cdr a >>; + end; + +symbolic procedure c!:valid_fndef(args, body); + if ('!&optional memq args) or ('!&rest memq args) then nil + else c!:valid_list body; + +symbolic procedure c!:valid_list x; + if null x then t + else if atom x then nil + else if not c!:valid_expr car x then nil + else c!:valid_list cdr x; + +symbolic procedure c!:valid_expr x; + if atom x then t + else if not atom car x then << + if not c!:valid_list cdr x then nil + else if not eqcar(car x, 'lambda) then nil + else if atom cdar x then nil + else c!:valid_fndef(cadar x, cddar x) >> + else if not idp car x then nil + else if eqcar(x, 'quote) then t + else begin + scalar h; + h := get(car x, 'c!:valid); + if null h then return c!:valid_list cdr x; + return funcall(h, cdr x) + end; + +% This establishes a default handler for each special form so that +% any that I forget to treat more directly will cause a tidy error +% if found in compiled code. + +symbolic procedure c!:cspecform(x, env); + error(0, list("special form", x)); + +symbolic procedure c!:valid_specform x; + nil; + +<< put('and, 'c!:code, function c!:cspecform); +!#if common!-lisp!-mode + put('block, 'c!:code, function c!:cspecform); +!#endif + put('catch, 'c!:code, function c!:cspecform); + put('compiler!-let, 'c!:code, function c!:cspecform); + put('cond, 'c!:code, function c!:cspecform); + put('declare, 'c!:code, function c!:cspecform); + put('de, 'c!:code, function c!:cspecform); +!#if common!-lisp!-mode + put('defun, 'c!:code, function c!:cspecform); +!#endif + put('eval!-when, 'c!:code, function c!:cspecform); + put('flet, 'c!:code, function c!:cspecform); + put('function, 'c!:code, function c!:cspecform); + put('go, 'c!:code, function c!:cspecform); + put('if, 'c!:code, function c!:cspecform); + put('labels, 'c!:code, function c!:cspecform); +!#if common!-lisp!-mode + put('let, 'c!:code, function c!:cspecform); +!#else + put('!~let, 'c!:code, function c!:cspecform); +!#endif + put('let!*, 'c!:code, function c!:cspecform); + put('list, 'c!:code, function c!:cspecform); + put('list!*, 'c!:code, function c!:cspecform); + put('macrolet, 'c!:code, function c!:cspecform); + put('multiple!-value!-call, 'c!:code, function c!:cspecform); + put('multiple!-value!-prog1, 'c!:code, function c!:cspecform); + put('or, 'c!:code, function c!:cspecform); + put('prog, 'c!:code, function c!:cspecform); + put('prog!*, 'c!:code, function c!:cspecform); + put('prog1, 'c!:code, function c!:cspecform); + put('prog2, 'c!:code, function c!:cspecform); + put('progn, 'c!:code, function c!:cspecform); + put('progv, 'c!:code, function c!:cspecform); + put('quote, 'c!:code, function c!:cspecform); + put('return, 'c!:code, function c!:cspecform); + put('return!-from, 'c!:code, function c!:cspecform); + put('setq, 'c!:code, function c!:cspecform); + put('tagbody, 'c!:code, function c!:cspecform); + put('the, 'c!:code, function c!:cspecform); + put('throw, 'c!:code, function c!:cspecform); + put('unless, 'c!:code, function c!:cspecform); + put('unwind!-protect, 'c!:code, function c!:cspecform); + put('when, 'c!:code, function c!:cspecform) ; + +% I comment out lines here when (a) the special form involved is +% supported by my compilation into C and (b) its syntax is such that +% I can analyse it as if it was an ordinary function. Eg (AND a b c) +% +% Cases like PROG are left in because the syntax (PROG (v1 v2) ...) needs +% special treatment. +% +% Cases like UNWIND-PROTECT are left in because at the time of writing this +% comment they are not supported. + + +% put('and, 'c!:valid, function c!:valid_specform); +!#if common!-lisp!-mode +% put('block, 'c!:valid, function c!:valid_specform); +!#endif + put('catch, 'c!:valid, function c!:valid_specform); + put('compiler!-let, 'c!:valid, function c!:valid_specform); + put('cond, 'c!:valid, function c!:valid_specform); + put('declare, 'c!:valid, function c!:valid_specform); + put('de, 'c!:valid, function c!:valid_specform); +!#if common!-lisp!-mode + put('defun, 'c!:valid, function c!:valid_specform); +!#endif + put('eval!-when, 'c!:valid, function c!:valid_specform); + put('flet, 'c!:valid, function c!:valid_specform); + put('function, 'c!:valid, function c!:valid_specform); +% put('go, 'c!:valid, function c!:valid_specform); +% put('if, 'c!:valid, function c!:valid_specform); + put('labels, 'c!:valid, function c!:valid_specform); +!#if common!-lisp!-mode + put('let, 'c!:valid, function c!:valid_specform); +!#else + put('!~let, 'c!:valid, function c!:valid_specform); +!#endif + put('let!*, 'c!:valid, function c!:valid_specform); +% put('list, 'c!:valid, function c!:valid_specform); +% put('list!*, 'c!:valid, function c!:valid_specform); + put('macrolet, 'c!:valid, function c!:valid_specform); + put('multiple!-value!-call, 'c!:valid, function c!:valid_specform); + put('multiple!-value!-prog1, 'c!:valid, function c!:valid_specform); +% put('or, 'c!:valid, function c!:valid_specform); + put('prog, 'c!:valid, function c!:valid_specform); + put('prog!*, 'c!:valid, function c!:valid_specform); +% put('prog1, 'c!:valid, function c!:valid_specform); +% put('prog2, 'c!:valid, function c!:valid_specform); +% put('progn, 'c!:valid, function c!:valid_specform); + put('progv, 'c!:valid, function c!:valid_specform); + put('quote, 'c!:valid, function c!:valid_specform); +% put('return, 'c!:valid, function c!:valid_specform); +% put('return!-from, 'c!:valid, function c!:valid_specform); +% put('setq, 'c!:valid, function c!:valid_specform); +% put('tagbody, 'c!:valid, function c!:valid_specform); + put('the, 'c!:valid, function c!:valid_specform); + put('throw, 'c!:valid, function c!:valid_specform); +% put('unless, 'c!:valid, function c!:valid_specform); + put('unwind!-protect, 'c!:valid, function c!:valid_specform); +% put('when, 'c!:valid, function c!:valid_specform) + >>; + +fluid '(c!:current_procedure c!:current_args c!:current_block c!:current_contents + c!:all_blocks c!:registers c!:stacklocs); + +fluid '(c!:available c!:used); + +c!:available := c!:used := nil; + +symbolic procedure c!:reset_gensyms(); + << remflag(c!:used, 'c!:live_across_call); + remflag(c!:used, 'c!:visited); + while c!:used do << + remprop(car c!:used, 'c!:contents); + remprop(car c!:used, 'c!:why); + remprop(car c!:used, 'c!:where_to); + remprop(car c!:used, 'c!:count); + remprop(car c!:used, 'c!:live); + remprop(car c!:used, 'c!:clash); + remprop(car c!:used, 'c!:chosen); + remprop(car c!:used, 'c!:location); + if plist car c!:used then begin + scalar o; o := wrs nil; + princ "+++++ "; prin car c!:used; princ " "; + prin plist car c!:used; terpri(); + wrs o end; + c!:available := car c!:used . c!:available; + c!:used := cdr c!:used >> >>; + +!#if common!-lisp!-mode + +fluid '(my_gensym_counter); +my_gensym_counter := 0; + +!#endif + +symbolic procedure c!:my_gensym(); + begin + scalar w; + if c!:available then << w := car c!:available; c!:available := cdr c!:available >> +!#if common!-lisp!-mode + else w := compress1 + ('!v . explodec (my_gensym_counter := my_gensym_counter + 1)); +!#else + else w := gensym1 "v"; +!#endif + c!:used := w . c!:used; + if plist w then << princ "????? "; prin w; princ " => "; prin plist w; terpri() >>; + return w + end; + +symbolic procedure c!:newreg(); + begin + scalar r; + r := c!:my_gensym(); + c!:registers := r . c!:registers; + return r + end; + +symbolic procedure c!:startblock s; + << c!:current_block := s; + c!:current_contents := nil + >>; + +symbolic procedure c!:outop(a,b,c,d); + if c!:current_block then + c!:current_contents := list(a,b,c,d) . c!:current_contents; + +symbolic procedure c!:endblock(why, where_to); + if c!:current_block then << +% Note that the operations within a block are in reversed order. + put(c!:current_block, 'c!:contents, c!:current_contents); + put(c!:current_block, 'c!:why, why); + put(c!:current_block, 'c!:where_to, where_to); + c!:all_blocks := c!:current_block . c!:all_blocks; + c!:current_contents := nil; + c!:current_block := nil >>; + +% +% Now for a general driver for compilation +% + +symbolic procedure c!:cval_inner(x, env); + begin + scalar helper; +% NB use the "improve" function from the regular compiler here... + x := s!:improve x; +% atoms and embedded lambda expressions need their own treatment. + if atom x then return c!:catom(x, env) + else if eqcar(car x, 'lambda) then + return c!:clambda(cadar x, cddar x, cdr x, env) +% a c!:code property gives direct control over compilation + else if helper := get(car x, 'c!:code) then + return funcall(helper, x, env) +% compiler-macros take precedence over regular macros, so that I can +% make special expansions in the context of compilation. Only used if the +% expansion is non-nil + else if (helper := get(car x, 'c!:compile_macro)) and + (helper := funcall(helper, x)) then + return c!:cval(helper, env) +% regular Lisp macros get expanded + else if idp car x and (helper := macro!-function car x) then + return c!:cval(funcall(helper, x), env) +% anything not recognised as special will be turned into a +% function call, but there will still be special cases, such as +% calls to the current function, calls into the C-coded kernel, etc. + else return c!:ccall(car x, cdr x, env) + end; + +symbolic procedure c!:cval(x, env); + begin + scalar r; + r := c!:cval_inner(x, env); + if r and not member!*!*(r, c!:registers) then + error(0, list(r, "not a register", x)); + return r + end; + +symbolic procedure c!:clambda(bvl, body, args, env); +% This is for ((lambda bvl body) args) and it will need to deal with +% local declarations at the head of body. On this call body is a list of +% forms. + begin + scalar w, w1, fluids, env1, decs; + env1 := car env; + w := for each a in args collect c!:cval(a, env); + w1 := s!:find_local_decs(body, nil); + localdecs := car w1 . localdecs; + w1 := cdr w1; +% Tidy up so that body is a single expression. + if null w1 then body := nil + else if null cdr w1 then body := car w1 + else body := 'progn . w1; + for each x in bvl do + if not fluidp x and not globalp x and + c!:local_fluidp(x, localdecs) then << + make!-special x; + decs := x . decs >>; + for each v in bvl do << + if globalp v then begin scalar oo; + oo := wrs nil; + princ "+++++ "; prin v; + princ " converted from GLOBAL to FLUID"; terpri(); + wrs oo; + unglobal list v; + fluid list v end; + if fluidp v then << + fluids := (v . c!:newreg()) . fluids; + flag(list cdar fluids, 'c!:live_across_call); % silly if not + env1 := ('c!:dummy!:name . cdar fluids) . env1; + c!:outop('ldrglob, cdar fluids, v, c!:find_literal v); + c!:outop('strglob, car w, v, c!:find_literal v) >> + else << + env1 := (v . c!:newreg()) . env1; + c!:outop('movr, cdar env1, nil, car w) >>; + w := cdr w >>; + if fluids then c!:outop('fluidbind, nil, nil, fluids); + env := env1 . append(fluids, cdr env); + w := c!:cval(body, env); + for each v in fluids do + c!:outop('strglob, cdr v, car v, c!:find_literal car v); + unfluid decs; + localdecs := cdr localdecs; + return w + end; + +symbolic procedure c!:locally_bound(x, env); + atsoc(x, car env); + +flag('(nil t), 'c!:constant); + +fluid '(literal_vector); + +symbolic procedure c!:find_literal x; + begin + scalar n, w; + w := literal_vector; + n := 0; + while w and not (car w = x) do << + n := n + 1; + w := cdr w >>; + if null w then literal_vector := append(literal_vector, list x); + return n + end; + +symbolic procedure c!:catom(x, env); + begin + scalar v, w; + v := c!:newreg(); +% I may need to think harder here about things that are both locally +% bound AND fluid. But when I bind a fluid I put a dummy name onto env +% and use that as a place to save the old value of the fluid, so I believe +% I may be safe. Well not quite I guess. How about +% (prog (a) % a local variable +% (prog (a) (declare (special a)) % hah this one os fluid! +% reference "a" here... +% and related messes. So note that the outer binding means that a is +% locally bound but the inner binding means that a fluid binding must +% be used. + if idp x and (fluidp x or globalp x) then + c!:outop('ldrglob, v, x, c!:find_literal x) + else if idp x and (w := c!:locally_bound(x, env)) then + c!:outop('movr, v, nil, cdr w) + else if null x or x = 't or c!:small_number x then + c!:outop('movk1, v, nil, x) + else if not idp x or flagp(x, 'c!:constant) then + c!:outop('movk, v, x, c!:find_literal x) +% If a variable that is referenced is not locally bound then it is treated +% as being fluid/global without comment. + else c!:outop('ldrglob, v, x, c!:find_literal x); + return v + end; + +symbolic procedure c!:cjumpif(x, env, d1, d2); + begin + scalar helper, r; + x := s!:improve x; + if atom x and (not idp x or + (flagp(x, 'c!:constant) and not c!:locally_bound(x, env))) then + c!:endblock('goto, list (if x then d1 else d2)) + else if not atom x and (helper := get(car x, 'c!:ctest)) then + return funcall(helper, x, env, d1, d2) + else << + r := c!:cval(x, env); + c!:endblock(list('ifnull, r), list(d2, d1)) >> + end; + +fluid '(c!:current); + +symbolic procedure c!:ccall(fn, args, env); + c!:ccall1(fn, args, env); + +fluid '(c!:visited); + +symbolic procedure c!:has_calls(a, b); + begin + scalar c!:visited; + return c!:has_calls_1(a, b) + end; + +symbolic procedure c!:has_calls_1(a, b); +% true if there is a path from node a to node b that has a call instruction +% on the way. + if a = b or not atom a or memq(a, c!:visited) then nil + else begin + scalar has_call; + c!:visited := a . c!:visited; + for each z in get(a, 'c!:contents) do + if eqcar(z, 'call) then has_call := t; + if has_call then return + begin scalar c!:visited; + return c!:can_reach(a, b) end; + for each d in get(a, 'c!:where_to) do + if c!:has_calls_1(d, b) then has_call := t; + return has_call + end; + +symbolic procedure c!:can_reach(a, b); + if a = b then t + else if not atom a or memq(a, c!:visited) then nil + else << + c!:visited := a . c!:visited; + c!:any_can_reach(get(a, 'c!:where_to), b) >>; + +symbolic procedure c!:any_can_reach(l, b); + if null l then nil + else if c!:can_reach(car l, b) then t + else c!:any_can_reach(cdr l, b); + +symbolic procedure c!:pareval(args, env); + begin + scalar tasks, tasks1, merge, split, r; + tasks := for each a in args collect (c!:my_gensym() . c!:my_gensym()); + split := c!:my_gensym(); + c!:endblock('goto, list split); + for each a in args do begin + scalar s; +% I evaluate each arg as what is (at this stage) a separate task + s := car tasks; + tasks := cdr tasks; + c!:startblock car s; + r := c!:cval(a, env) . r; + c!:endblock('goto, list cdr s); +% If the task did no procedure calls (or only tail calls) then it can be +% executed sequentially with the other args without need for stacking +% anything. Otherwise it more care will be needed. Put the hard +% cases onto tasks1. +!#if common!-lisp!-mode + tasks1 := s . tasks1 +!#else +% The "t or" here is to try to FORCE left to right evaluation, even though +% doing so may hurt performance. It at present looks as if some parts +% of REDUCE have been coded making assumptions about this. + if t or c!:has_calls(car s, cdr s) then tasks1 := s . tasks1 + else merge := s . merge +!#endif + end; +%-- % if there are zero or one items in tasks1 then again it is easy - +%-- % otherwise I flag the problem with a notionally parallel construction. +%-- if tasks1 then << +%-- if null cdr tasks1 then merge := car tasks1 . merge +%-- else << +%-- c!:startblock split; +%-- printc "***** ParEval needed parallel block here..."; +%-- c!:endblock('par, for each v in tasks1 collect car v); +%-- split := c!:my_gensym(); +%-- for each v in tasks1 do << +%-- c!:startblock cdr v; +%-- c!:endblock('goto, list split) >> >> >>; + for each z in tasks1 do merge := z . merge; % do sequentially +%-- +%-- +% Finally string end-to-end all the bits of sequential code I have left over. + for each v in merge do << + c!:startblock split; + c!:endblock('goto, list car v); + split := cdr v >>; + c!:startblock split; + return reversip r + end; + +symbolic procedure c!:ccall1(fn, args, env); + begin + scalar tasks, merge, r, val; + fn := list(fn, cdr env); + val := c!:newreg(); + if null args then c!:outop('call, val, nil, fn) + else if null cdr args then + c!:outop('call, val, list c!:cval(car args, env), fn) + else << + r := c!:pareval(args, env); + c!:outop('call, val, r, fn) >>; + c!:outop('reloadenv, 'env, nil, nil); + return val + end; + +fluid '(restart_label reloadenv does_call c!:current_c_name); + +% Reminder: s!:find_local_decs(body, isprog) returns (L . B') where +% L is a list of local declarations and B' is the body with any +% initial DECLARE and string-comments removed. The body passed in and +% the result returned are both lists of forms. + + +symbolic procedure c!:local_fluidp1(v, decs); + decs and ((eqcar(car decs, 'special) and memq(v, cdar decs)) or + c!:local_fluidp1(v, cdr decs)); + +symbolic procedure c!:local_fluidp(v, decs); + decs and (c!:local_fluidp1(v, car decs) or + c!:local_fluidp(v, cdr decs)); + +% +% The "proper" recipe here arranges that functions that expect over 2 args use +% the "va_arg" mechanism to pick up ALL their args. This would be pretty +% heavy-handed, and at least on a lot of machines it does not seem to +% be necessary. I will duck it for a while more at least. BUT NOTE THAT THE +% CODE I GENERATE HERE IS AT LEAST OFFICIALLY INCORRECT. If at some stage I +% find a computer where the implementation of va_args is truly incompatible +% with that for known numbers of arguments I will need to adjust things +% here. Yuk. +% +% Just so I know, the code at presently generated tends to go +% +% Lisp_Object f(Lisp_Object env, int nargs, Lisp_Object a1, Lisp_Object a2, +% Lisp_Object a3, ...) +% { // use a1, a2 and a3 as arguments +% and note that it does put the "..." there! +% +% What it maybe ought to be is +% +% Lisp_Object f(Lisp_Object env, int nargs, ...) +% { Lisp_Object a1, a2, a3; +% va_list aa; +% va_start(aa, nargs); +% argcheck(nargs, 3, "f"); +% a1 = va_arg(aa, Lisp_Object); +% a2 = va_arg(aa, Lisp_Object); +% a3 = va_arg(aa, Lisp_Object); +% va_end(aa); +% +% Hmm that is not actually that hard to arrange! Remind me to do it some time! + +fluid '(proglabs blockstack localdecs); + +symbolic procedure c!:cfndef(c!:current_procedure, + c!:current_c_name, argsbody, checksum); + begin + scalar env, n, w, c!:current_args, c!:current_block, restart_label, + c!:current_contents, c!:all_blocks, entrypoint, exitpoint, args1, + c!:registers, c!:stacklocs, literal_vector, reloadenv, does_call, + blockstack, proglabs, args, body, localdecs; + args := car argsbody; + body := cdr argsbody; +% If there is a (DECLARE (SPECIAL ...)) extract it here, aned leave a body +% that is without it. + w := s!:find_local_decs(body, nil); + body := cdr w; + if atom body then body := nil + else if atom cdr body then body := car body + else body := 'progn . body; + localdecs := list car w; +% I expect localdecs to be a list a bit like +% ( ((special a b) (special c d) ...) ...) +% and hypothetically it could have entries that were not tagged as +% SPECIAL in it. +% +% The next line prints it to check. +% if localdecs then << princ "localdecs = "; print localdecs >>; % @@@ +% +% Normally comment out the next line... It just shows what I am having to +% compile and may be useful when debugging. +% print list(c!:current_procedure, c!:current_c_name, args, body); + c!:reset_gensyms(); + wrs C_file; + linelength 200; + c!:printf("\n\n/* Code for %a %<*/\n\n", c!:current_procedure); + + c!:find_literal c!:current_procedure; % For benefit of backtraces +% +% cope with fluid vars in an argument list by expanding the definition +% (de f (a B C d) body) B and C fluid +% into +% (de f (a x y c) (prog (B C) (setq B x) (setq C y) (return body))) +% so that the fluids get bound by PROG. +% + c!:current_args := args; + for each v in args do + if v = '!&optional or v = '!&rest then + error(0, "&optional and &rest not supported by this compiler (yet)") + else if globalp v then begin scalar oo; + oo := wrs nil; + princ "+++++ "; prin v; + princ " converted from GLOBAL to FLUID"; terpri(); + wrs oo; + unglobal list v; + fluid list v; + n := (v . c!:my_gensym()) . n end + else if fluidp v or c!:local_fluidp(v, localdecs) then + n := (v . c!:my_gensym()) . n; + if !*r2i then body := s!:r2i(c!:current_procedure, args, body); + restart_label := c!:my_gensym(); + body := list('c!:private_tagbody, restart_label, body); +% This bit sets up the PROG block for binding fluid arguments. + if n then << + body := list list('return, body); + args := subla(n, args); + for each v in n do + body := list('setq, car v, cdr v) . body; + body := 'prog . (for each v in reverse n collect car v) . body >>; + c!:printf "static Lisp_Object "; + if null args or length args >= 3 then c!:printf("MS_CDECL "); + c!:printf("%s(Lisp_Object env", c!:current_c_name); + if null args or length args >= 3 then c!:printf(", int nargs"); + n := t; + env := nil; + +% Hah - here is where I will change things to use va_args for >= 3 args. + for each x in args do begin + scalar aa; + c!:printf ","; + if n then << c!:printf "\n "; n := nil >> + else n := t; + aa := c!:my_gensym(); + env := (x . aa) . env; + c!:registers := aa . c!:registers; + args1 := aa . args1; + c!:printf(" Lisp_Object %s", aa) end; + if null args or length args >= 3 then c!:printf(", ..."); + c!:printf(")\n{\n"); + +% Now I would need to do va_arg calls to declare the args and init them... +% Except that I must do that within optimise_flowgraph after all possible +% declarations have been generated. + + c!:startblock (entrypoint := c!:my_gensym()); + exitpoint := c!:current_block; + c!:endblock('goto, list list c!:cval(body, env . nil)); + + c!:optimise_flowgraph(entrypoint, c!:all_blocks, env, + length args . c!:current_procedure, args1); + + c!:printf("}\n\n"); + wrs O_file; + + L_contents := (c!:current_procedure . literal_vector . checksum) . + L_contents; + return nil + end; + +% c!:ccompile1 directs the compilation of a single function, and bind all the +% major fluids used by the compilation process + +flag('(rds deflist flag fluid global + remprop remflag unfluid + unglobal dm carcheck C!-end), 'eval); + +flag('(rds), 'ignore); + +fluid '(!*backtrace); + +symbolic procedure c!:ccompilesupervisor; + begin + scalar u, w; +top:u := errorset('(read), t, !*backtrace); + if atom u then return; % failed, or maybe EOF + u := car u; + if u = !$eof!$ then return; % end of file + if atom u then go to top +% the apply('C!-end, nil) is here because C!-end has a "stat" +% property and so it will mis-parse if I just write "C!-end()". Yuk. + else if eqcar(u, 'C!-end) then return apply('C!-end, nil) + else if eqcar(u, 'rdf) then << +!#if common!-lisp!-mode + w := open(u := eval cadr u, !:direction, !:input, + !:if!-does!-not!-exist, nil); +!#else + w := open(u := eval cadr u, 'input); +!#endif + if w then << + terpri(); + princ "Reading file "; print u; + w := rds w; + c!:ccompilesupervisor(); + princ "End of file "; print u; + close rds w >> + else << princ "Failed to open file "; print u >> >> + else c!:ccmpout1 u; + go to top + end; + +global '(c!:char_mappings); + +c!:char_mappings := '( + (! . !A) (!! . !B) (!# . !C) (!$ . !D) + (!% . !E) (!^ . !F) (!& . !G) (!* . !H) + (!( . !I) (!) . !J) (!- . !K) (!+ . !L) + (!= . !M) (!\ . !N) (!| . !O) (!, . !P) + (!. . !Q) (!< . !R) (!> . !S) (!: . !T) + (!; . !U) (!/ . !V) (!? . !W) (!~ . !X) + (!` . !Y)); + +fluid '(c!:names_so_far); + +symbolic procedure c!:inv_name n; + begin + scalar r, w; +% The next bit ararnges that if there are several definitions of the +% same function in the same module that they get different C names. +% Specifically they will be called CC_f, CC1_f, CC2_c, CC3_f, ... + if (w := assoc(n, c!:names_so_far)) then w := cdr w + 1 + else w := 0; + c!:names_so_far := (n . w) . c!:names_so_far; + r := '(!C !C !"); + if not zerop w then r := append(reverse explodec w, r); + r := '!_ . r; +!#if common!-lisp!-mode + for each c in explode2 package!-name symbol!-package n do << + if c = '_ then r := '_ . r + else if alpha!-char!-p c or digit c then r := c . r + else if w := atsoc(c, c!:char_mappings) then r := cdr w . r + else r := '!Z . r >>; + r := '!_ . '!_ . r; +!#endif + for each c in explode2 n do << + if c = '_ then r := '_ . r +!#if common!-lisp!-mode + else if alpha!-char!-p c or digit c then r := c . r +!#else + else if liter c or digit c then r := c . r +!#endif + else if w := atsoc(c, c!:char_mappings) then r := cdr w . r + else r := '!Z . r >>; + r := '!" . r; +!#if common!-lisp!-mode + return compress1 reverse r +!#else + return compress reverse r +!#endif + end; + +fluid '(c!:defnames pending_functions); + +symbolic procedure c!:ccmpout1 u; + begin + scalar pending_functions; + pending_functions := list u; + while pending_functions do << + u := car pending_functions; + pending_functions := cdr pending_functions; + c!:ccmpout1a u >> + end; + +symbolic procedure c!:ccmpout1a u; + begin + scalar w, checksum; + if atom u then return nil + else if eqcar(u, 'progn) then << + for each v in cdr u do c!:ccmpout1a v; + return nil >> + else if eqcar(u, 'C!-end) then nil + else if flagp(car u, 'eval) or + (car u = 'setq and not atom caddr u and flagp(caaddr u, 'eval)) then + errorset(u, t, !*backtrace); + if eqcar(u, 'rdf) then begin +!#if common!-lisp!-mode + w := open(u := eval cadr u, !:direction, !:input, + !:if!-does!_not!-exist, nil); +!#else + w := open(u := eval cadr u, 'input); +!#endif + if w then << + princ "Reading file "; print u; + w := rds w; + c!:ccompilesupervisor(); + princ "End of file "; print u; + close rds w >> + else << princ "Failed to open file "; print u >> end +!#if common!-lisp!-mode + else if eqcar(u, 'defun) then return c!:ccmpout1a macroexpand u +!#endif + else if eqcar(u, 'de) then << + u := cdr u; + checksum := md60 u; +!#if common!-lisp!-mode + w := compress1 ('!" . append(explodec package!-name + symbol!-package car u, + '!@ . '!@ . append(explodec symbol!-name car u, + append(explodec "@@Builtin", '(!"))))); + w := intern w; + c!:defnames := list(car u, c!:inv_name car u, length cadr u, w, checksum) . c!:defnames; +!#else + c!:defnames := list(car u, c!:inv_name car u, length cadr u, checksum) . c!:defnames; +!#endif +% if posn() neq 0 then terpri(); + princ "Compiling "; prin caar c!:defnames; princ " ... "; + c!:cfndef(caar c!:defnames, cadar c!:defnames, cdr u, checksum); +!#if common!-lisp!-mode + L_contents := (w . car L_contents) . cdr L_contents; +!#endif + terpri() >> + end; + +fluid '(!*defn dfprint!* dfprintsave); + +!#if common!-lisp!-mode +symbolic procedure c!:concat(a, b); + compress1('!" . append(explode2 a, append(explode2 b, '(!")))); +!#else +symbolic procedure c!:concat(a, b); + compress('!" . append(explode2 a, append(explode2 b, '(!")))); +!#endif + +symbolic procedure c!:ccompilestart(name, setupname, dir, hdrnow); + begin + scalar o, d, w; + reset!-gensym 0; % Makes output more consistent +!#if common!-lisp!-mode + my_gensym_counter := 0; +!#endif + c!:registers := c!:available := c!:used := nil; +% File_name will be the undecorated name as a string when hdrnow is false, + File_name := list!-to!-string explodec name; + Setup_name := explodec setupname; +% I REALLY want the user to give me a module name that is a valid C +% identifier, but in REDUCE I find just one case where a name has an embedded +% "-", so I will just map that onto "_". When loading modules I will need to +% take care to be aware of this! Also if any idiot tried to have two modules +% called a-b and a_b they would now clash with one another. + Setup_name := subst('!_, '!-, Setup_name); + Setup_name := list!-to!-string Setup_name; + if dir then << + if 'win32 memq lispsystem!* then + name := c!:concat(dir, c!:concat("\", name)) + else name := c!:concat(dir, c!:concat("/", name)) >>; +princ "C file = "; print name; +!#if common!-lisp!-mode + C_file := open(c!:concat(name, ".c"), !:direction, !:output); +!#else + C_file := open(c!:concat(name, ".c"), 'output); +!#endif + L_file := c!:concat(name, ".lsp"); + L_contents := nil; + c!:names_so_far := nil; +% Here I turn a date into a form like "12-Oct-1993" as expected by the +% file signature mechanism that I use. This seems a pretty ugly process. + o := reverse explode date(); + for i := 1:5 do << d := car o . d; o := cdr o >>; + d := '!- . d; + o := cdddr cdddr cddddr o; + w := o; + o := cdddr o; + d := caddr o . cadr o . car o . d; +!#if common!-lisp!-mode + d := compress1('!" . cadr w . car w . '!- . d); +!#else + d := compress('!" . cadr w . car w . '!- . d); +!#endif + O_file := wrs C_file; + c!:defnames := nil; + if hdrnow then + c!:printf("\n/* Module: %s %tMachine generated C code %<*/\n\n", setupname, 25) + else c!:printf("\n/* %s.c %tMachine generated C code %<*/\n\n", name, 25); + c!:printf("/* Signature: 00000000 %s %<*/\n\n", d); + c!:printf "#include \n"; + c!:printf "#include \n"; + c!:printf "#include \n"; + c!:printf "#include \n"; + c!:printf "#include \n"; + c!:printf "#include \n"; + c!:printf "#ifndef _cplusplus\n"; + c!:printf "#include \n"; + c!:printf "#endif\n\n"; +% The stuff I put in the file here includes written-in copies of header +% files. The main "csl_headers" should be the same for all systems built +% based on the current sources, but the "config_header" is specific to a +% particular build. So if I am genarating C code that is JUST for use on the +% current platform I can write-in the config header here and now, but if +% there is any chance that I might save the generated C and compile it +% elsewhere I should leave "#include "config.h"" in there. + if hdrnow then print!-config!-header() + else c!:printf "#include \qconfig.h\q\n\n"; + print!-csl!-headers(); +% Now a useful prefix for when compiling as a DLL + if hdrnow then c!:print!-init(); + wrs O_file; + return nil + end; + +symbolic procedure c!:print!-init(); + << + c!:printf "\n"; + c!:printf "Lisp_Object *C_nilp;\n"; + c!:printf "Lisp_Object **C_stackp;\n"; + c!:printf "Lisp_Object * volatile * stacklimitp;\n"; + c!:printf "\n"; + c!:printf "void init(Lisp_Object *a, Lisp_Object **b, Lisp_Object * volatile *c)\n"; + c!:printf "{\n"; + c!:printf " C_nilp = a;\n"; + c!:printf " C_stackp = b;\n"; + c!:printf " stacklimitp = c;\n"; + c!:printf "}\n"; + c!:printf "\n"; + c!:printf "#define C_nil (*C_nilp)\n"; + c!:printf "#define C_stack (*C_stackp)\n"; + c!:printf "#define stacklimit (*stacklimitp)\n"; + c!:printf "\n" + >>; + +symbolic procedure C!-end; + C!-end1 t; + +procedure C!-end1 create_lfile; + begin + scalar checksum, c1, c2, c3; + wrs C_file; + if create_lfile then + c!:printf("\n\nsetup_type const %s_setup[] =\n{\n", Setup_name) + else c!:printf("\n\nsetup_type_1 const %s_setup[] =\n{\n", Setup_name); + c!:defnames := reverse c!:defnames; + while c!:defnames do begin + scalar name, nargs, f1, f2, cast, fn; +!#if common!-lisp!-mode + name := cadddr car c!:defnames; + checksum := cadddr cdar c!:defnames; +!#else + name := caar c!:defnames; + checksum := cadddr car c!:defnames; +!#endif + f1 := cadar c!:defnames; + nargs := caddar c!:defnames; + cast := "(n_args *)"; + if nargs = 1 then << + f2 := '!t!o!o_!m!a!n!y_1; cast := ""; fn := '!w!r!o!n!g_!n!o_1 >> + else if nargs = 2 then << + f2 := f1; f1 := '!t!o!o_!f!e!w_2; cast := ""; + fn := '!w!r!o!n!g_!n!o_2 >> + else << fn := f1; f1 := '!w!r!o!n!g_!n!o_!n!a; + f2 := '!w!r!o!n!g_!n!o_!n!b >>; + if create_lfile then c!:printf(" {\q%s\q,%t%s,%t%s,%t%s%s},\n", + name, 32, f1, 48, f2, 63, cast, fn) + else + begin + scalar c1, c2; + c1 := divide(checksum, expt(2, 31)); + c2 := cdr c1; + c1 := car c1; + c!:printf(" {\q%s\q, %t%s, %t%s, %t%s%s, %t%s, %t%s},\n", + name, 24, f1, 40, f2, 52, cast, fn, 64, c1, 76, c2) + end; + c!:defnames := cdr c!:defnames end; + c3 := checksum := md60 L_contents; + c1 := remainder(c3, 10000000); + c3 := c3 / 10000000; + c2 := remainder(c3, 10000000); + c3 := c3 / 10000000; + checksum := list!-to!-string append(explodec c3, + '! . append(explodec c2, '! . explodec c1)); + c!:printf(" {NULL, (one_args *)%a, (two_args *)%a, 0}\n};\n\n", + Setup_name, checksum); + c!:printf "%>; + terpri(); +!#if common!-lisp!-mode + princ ";;; End of generated Lisp code"; +!#else + princ "% End of generated Lisp code"; +!#endif + terpri(); terpri(); + L_contents := nil; + wrs O_file; + close L_file; + !*defn := nil; + dfprint!* := dfprintsave >> + else << + checksum := checksum . reverse L_contents; + L_contents := nil; + return checksum >> + end; + +put('C!-end, 'stat, 'endstat); + +symbolic procedure C!-compile u; + begin + terpri(); + princ "C!-COMPILE "; + prin u; princ ": IN files; or type in expressions"; terpri(); + princ "When all done, execute C!-END;"; terpri(); + verbos nil; + c!:ccompilestart(car u, car u, nil, nil); + dfprintsave := dfprint!*; + dfprint!* := 'c!:ccmpout1; + !*defn := t; + if getd 'begin then return nil; + c!:ccompilesupervisor(); + end; + +put('C!-compile, 'stat, 'rlis); + +% +% Global treatment of a flow-graph... +% + +symbolic procedure c!:print_opcode(s, depth); + begin + scalar op, r1, r2, r3, helper; + op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; + helper := get(op, 'c!:opcode_printer); + if helper then funcall(helper, op, r1, r2, r3, depth) + else << prin s; terpri() >> + end; + +symbolic procedure c!:print_exit_condition(why, where_to, depth); + begin + scalar helper, lab1, drop1, lab2, drop2, negate; +% An exit condition is one of +% goto (lab) +% goto ((return-register)) +% (ifnull v) (lab1 lab2) ) etc, where v is a register and +% (ifatom v) (lab1 lab2) ) lab1, lab2 are labels for true & false +% (ifeq v1 v2) (lab1 lab2) ) and various predicates are supported +% ((call fn) a1 a2) () tail-call to given function +% + if why = 'goto then << + where_to := car where_to; + if atom where_to then << + c!:printf(" goto %s;\n", where_to); + c!:display_flowgraph(where_to, depth, t) >> + else << c!:printf " "; c!:pgoto(where_to, depth) >>; + return nil >> + else if eqcar(car why, 'call) then return begin + scalar args, locs, g, w; + if w := get(cadar why, 'c!:direct_entrypoint) then << + for each a in cdr why do + if flagp(a, 'c!:live_across_call) then << + if null g then c!:printf " {\n"; + g := c!:my_gensym(); + c!:printf(" Lisp_Object %s = %v;\n", g, a); + args := g . args >> + else args := a . args; + if depth neq 0 then << + if g then c!:printf " "; + c!:printf(" popv(%s);\n", depth) >>; + if g then c!:printf " "; +!#if common!-lisp!-mode + c!:printf(" { Lisp_Object retVal = %s(", cdr w); +!#else + c!:printf(" return %s(", cdr w); +!#endif + args := reversip args; + if args then << + c!:printf("%v", car args); + for each a in cdr args do c!:printf(", %v", a) >>; + c!:printf(");\n"); +!#if common!-lisp!-mode + if g then c!:printf " "; + c!:printf(" errexit();\n"); + if g then c!:printf " "; + c!:printf(" return onevalue(retVal); }\n"); +!#endif + if g then c!:printf " }\n" >> + else if w := get(cadar why, 'c!:c_entrypoint) then << +% I think there may be an issue here with functions that can accept variable +% numbers of args. I seem to support just ONE C entrypoint which I will +% call in all circumstances... Yes there ARE such issues, and the one +% I recently fall across was "error" which in my implementation can take +% any number of arguments. So I have removed it from the list of things +% that can be called as direct C code... + for each a in cdr why do + if flagp(a, 'c!:live_across_call) then << + if null g then c!:printf " {\n"; + g := c!:my_gensym(); + c!:printf(" Lisp_Object %s = %v;\n", g, a); + args := g . args >> + else args := a . args; + if depth neq 0 then c!:printf(" popv(%s);\n", depth); + c!:printf(" return %s(nil", w); + if null args or length args >= 3 then c!:printf(", %s", length args); + for each a in reversip args do c!:printf(", %v", a); + c!:printf(");\n"); + if g then c!:printf " }\n" >> + else begin + scalar nargs; + nargs := length cdr why; + c!:printf " {\n"; + for each a in cdr why do + if flagp(a, 'c!:live_across_call) then << + g := c!:my_gensym(); + c!:printf(" Lisp_Object %s = %v;\n", g, a); + args := g . args >> + else args := a . args; + if depth neq 0 then c!:printf(" popv(%s);\n", depth); + c!:printf(" fn = elt(env, %s); %> + else if drop1 then negate := t; + helper := get(car why, 'c!:exit_helper); + if null helper then error(0, list("Bad exit condition", why)); + c!:printf(" if ("); + if negate then << + c!:printf("!("); + funcall(helper, cdr why, depth); + c!:printf(")") >> + else funcall(helper, cdr why, depth); + c!:printf(") "); + if not drop1 then << + c!:pgoto(car where_to, depth); + c!:printf(" else ") >>; + c!:pgoto(cadr where_to, depth); + if atom car where_to then c!:display_flowgraph(car where_to, depth, drop1); + if atom cadr where_to then c!:display_flowgraph(cadr where_to, depth, nil) + end; + +symbolic procedure c!:pmovr(op, r1, r2, r3, depth); + c!:printf(" %v = %v;\n", r1, r3); + +put('movr, 'c!:opcode_printer, function c!:pmovr); + +symbolic procedure c!:pmovk(op, r1, r2, r3, depth); + c!:printf(" %v = elt(env, %s); %>; + +put('fastget, 'c!:opcode_printer, function c!:pfastget); +flag('(fastget), 'c!:uses_nil); + +symbolic procedure c!:pfastflag(op, r1, r2, r3, depth); + << + c!:printf(" if (!symbolp(%v)) %v = nil;\n", r2, r1); + c!:printf(" else { %v = qfastgets(%v);\n", r1, r2); + c!:printf(" if (%v != nil) { %v = elt(%v, %s); %>; + +put('fastflag, 'c!:opcode_printer, function c!:pfastflag); +flag('(fastflag), 'c!:uses_nil); + +symbolic procedure c!:pcar(op, r1, r2, r3, depth); + begin + if not !*unsafecar then << + c!:printf(" if (!car_legal(%v)) ", r3); + c!:pgoto(c!:find_error_label(list('car, r3), r2, depth), depth) >>; + c!:printf(" %v = qcar(%v);\n", r1, r3) + end; + +put('car, 'c!:opcode_printer, function c!:pcar); + +symbolic procedure c!:pcdr(op, r1, r2, r3, depth); + begin + if not !*unsafecar then << + c!:printf(" if (!car_legal(%v)) ", r3); + c!:pgoto(c!:find_error_label(list('cdr, r3), r2, depth), depth) >>; + c!:printf(" %v = qcdr(%v);\n", r1, r3) + end; + +put('cdr, 'c!:opcode_printer, function c!:pcdr); + +symbolic procedure c!:pqcar(op, r1, r2, r3, depth); + c!:printf(" %v = qcar(%v);\n", r1, r3); + +put('qcar, 'c!:opcode_printer, function c!:pqcar); + +symbolic procedure c!:pqcdr(op, r1, r2, r3, depth); + c!:printf(" %v = qcdr(%v);\n", r1, r3); + +put('qcdr, 'c!:opcode_printer, function c!:pqcdr); + +symbolic procedure c!:patom(op, r1, r2, r3, depth); + c!:printf(" %v = (consp(%v) ? nil : lisp_true);\n", r1, r3); + +put('atom, 'c!:opcode_printer, function c!:patom); +flag('(atom), 'c!:uses_nil); + +symbolic procedure c!:pnumberp(op, r1, r2, r3, depth); + c!:printf(" %v = (is_number(%v) ? lisp_true : nil);\n", r1, r3); + +put('numberp, 'c!:opcode_printer, function c!:pnumberp); +flag('(numberp), 'c!:uses_nil); + +symbolic procedure c!:pfixp(op, r1, r2, r3, depth); + c!:printf(" %v = integerp(%v);\n", r1, r3); + +put('fixp, 'c!:opcode_printer, function c!:pfixp); +flag('(fixp), 'c!:uses_nil); + +symbolic procedure c!:piminusp(op, r1, r2, r3, depth); + c!:printf(" %v = ((intptr_t)(%v) < 0 ? lisp_true : nil);\n", r1, r3); + +put('iminusp, 'c!:opcode_printer, function c!:piminusp); +flag('(iminusp), 'c!:uses_nil); + +symbolic procedure c!:pilessp(op, r1, r2, r3, depth); + c!:printf(" %v = ((intptr_t)%v < (intptr_t)%v) ? lisp_true : nil;\n", + r1, r2, r3); + +put('ilessp, 'c!:opcode_printer, function c!:pilessp); +flag('(ilessp), 'c!:uses_nil); + +symbolic procedure c!:pigreaterp(op, r1, r2, r3, depth); + c!:printf(" %v = ((intptr_t)%v > (intptr_t)%v) ? lisp_true : nil;\n", + r1, r2, r3); + +put('igreaterp, 'c!:opcode_printer, function c!:pigreaterp); +flag('(igreaterp), 'c!:uses_nil); + +% The "int32_t" here is deliberate, and ensures that if the intereg-mode +% arithmetic strays outside 32-bits that truncation is done at that +% level even on 64-bit architectures. + +symbolic procedure c!:piminus(op, r1, r2, r3, depth); + c!:printf(" %v = (Lisp_Object)(2-((int32_t)(%v)));\n", r1, r3); + +put('iminus, 'c!:opcode_printer, function c!:piminus); + +symbolic procedure c!:piadd1(op, r1, r2, r3, depth); + c!:printf(" %v = (Lisp_Object)((int32_t)(%v) + 0x10);\n", r1, r3); + +put('iadd1, 'c!:opcode_printer, function c!:piadd1); + +symbolic procedure c!:pisub1(op, r1, r2, r3, depth); + c!:printf(" %v = (Lisp_Object)((int32_t)(%v) - 0x10);\n", r1, r3); + +put('isub1, 'c!:opcode_printer, function c!:pisub1); + +symbolic procedure c!:piplus2(op, r1, r2, r3, depth); + c!:printf(" %v = (Lisp_Object)(int32_t)((int32_t)%v + (int32_t)%v - TAG_FIXNUM);\n", + r1, r2, r3); + +put('iplus2, 'c!:opcode_printer, function c!:piplus2); + +symbolic procedure c!:pidifference(op, r1, r2, r3, depth); + c!:printf(" %v = (Lisp_Object)(int32_t)((int32_t)%v - (int32_t)%v + TAG_FIXNUM);\n", + r1, r2, r3); + +put('idifference, 'c!:opcode_printer, function c!:pidifference); + +symbolic procedure c!:pitimes2(op, r1, r2, r3, depth); + c!:printf(" %v = fixnum_of_int((int32_t)(int_of_fixnum(%v) * int_of_fixnum(%v)));\n", + r1, r2, r3); + +put('itimes2, 'c!:opcode_printer, function c!:pitimes2); + +symbolic procedure c!:pmodular_plus(op, r1, r2, r3, depth); + << + c!:printf(" { int32_t w = int_of_fixnum(%v) + int_of_fixnum(%v);\n", + r2, r3); + c!:printf(" if (w >= current_modulus) w -= current_modulus;\n"); + c!:printf(" %v = fixnum_of_int(w);\n", r1); + c!:printf(" }\n") + >>; + +put('modular!-plus, 'c!:opcode_printer, function c!:pmodular_plus); + +symbolic procedure c!:pmodular_difference(op, r1, r2, r3, depth); + << + c!:printf(" { int32_t w = int_of_fixnum(%v) - int_of_fixnum(%v);\n", + r2, r3); + c!:printf(" if (w < 0) w += current_modulus;\n"); + c!:printf(" %v = fixnum_of_int(w);\n", r1); + c!:printf(" }\n") + >>; + +put('modular!-difference, 'c!:opcode_printer, function c!:pmodular_difference); + +symbolic procedure c!:pmodular_minus(op, r1, r2, r3, depth); + << + c!:printf(" { int32_t w = int_of_fixnum(%v);\n", r3); + c!:printf(" if (w != 0) w = current_modulus - w;\n"); + c!:printf(" %v = fixnum_of_int(w);\n", r1); + c!:printf(" }\n") + >>; + +put('modular!-minus, 'c!:opcode_printer, function c!:pmodular_minus); + +!#if (not common!-lisp!-mode) + +symbolic procedure c!:passoc(op, r1, r2, r3, depth); + c!:printf(" %v = Lassoc(nil, %v, %v);\n", r1, r2, r3); + +put('assoc, 'c!:opcode_printer, function c!:passoc); +flag('(assoc), 'c!:uses_nil); + +!#endif + +symbolic procedure c!:patsoc(op, r1, r2, r3, depth); + c!:printf(" %v = Latsoc(nil, %v, %v);\n", r1, r2, r3); + +put('atsoc, 'c!:opcode_printer, function c!:patsoc); +flag('(atsoc), 'c!:uses_nil); + +!#if (not common!-lisp!-mode) + +symbolic procedure c!:pmember(op, r1, r2, r3, depth); + c!:printf(" %v = Lmember(nil, %v, %v);\n", r1, r2, r3); + +put('member, 'c!:opcode_printer, function c!:pmember); +flag('(member), 'c!:uses_nil); + +!#endif + +symbolic procedure c!:pmemq(op, r1, r2, r3, depth); + c!:printf(" %v = Lmemq(nil, %v, %v);\n", r1, r2, r3); + +put('memq, 'c!:opcode_printer, function c!:pmemq); +flag('(memq), 'c!:uses_nil); + +!#if common!-lisp!-mode + +symbolic procedure c!:pget(op, r1, r2, r3, depth); + c!:printf(" %v = get(%v, %v, nil);\n", r1, r2, r3); + +flag('(get), 'c!:uses_nil); +!#else + +symbolic procedure c!:pget(op, r1, r2, r3, depth); + c!:printf(" %v = get(%v, %v);\n", r1, r2, r3); + +!#endif + +put('get, 'c!:opcode_printer, function c!:pget); + +symbolic procedure c!:pqgetv(op, r1, r2, r3, depth); + << c!:printf(" %v = *(Lisp_Object *)((char *)%v + (CELL-TAG_VECTOR) +", + r1, r2); + c!:printf(" ((int32_t)%v/(16/CELL)));\n", r3) >>; + +put('qgetv, 'c!:opcode_printer, function c!:pqgetv); + +symbolic procedure c!:pqputv(op, r1, r2, r3, depth); + << + c!:printf(" *(Lisp_Object *)((char *)%v + (CELL-TAG_VECTOR) +", r2); + c!:printf(" ((int32_t)%v/(16/CELL))) = %v;\n", r3, r1) >>; + +put('qputv, 'c!:opcode_printer, function c!:pqputv); + +symbolic procedure c!:peq(op, r1, r2, r3, depth); + c!:printf(" %v = (%v == %v ? lisp_true : nil);\n", r1, r2, r3); + +put('eq, 'c!:opcode_printer, function c!:peq); +flag('(eq), 'c!:uses_nil); + +!#if common!-lisp!-mode +symbolic procedure c!:pequal(op, r1, r2, r3, depth); + c!:printf(" %v = (cl_equal(%v, %v) ? lisp_true : nil);\n", + r1, r2, r3, r2, r3); +!#else +symbolic procedure c!:pequal(op, r1, r2, r3, depth); + c!:printf(" %v = (equal(%v, %v) ? lisp_true : nil);\n", + r1, r2, r3, r2, r3); +!#endif + +put('equal, 'c!:opcode_printer, function c!:pequal); +flag('(equal), 'c!:uses_nil); + +symbolic procedure c!:pfluidbind(op, r1, r2, r3, depth); + nil; + +put('fluidbind, 'c!:opcode_printer, function c!:pfluidbind); + +symbolic procedure c!:pcall(op, r1, r2, r3, depth); + begin +% r3 is (name ) + scalar w, boolfn; + if w := get(car r3, 'c!:direct_entrypoint) then << + c!:printf(" %v = %s(", r1, cdr w); + if r2 then << + c!:printf("%v", car r2); + for each a in cdr r2 do c!:printf(", %v", a) >>; + c!:printf(");\n") >> + else if w := get(car r3, 'c!:direct_predicate) then << + boolfn := t; + c!:printf(" %v = (Lisp_Object)%s(", r1, cdr w); + if r2 then << + c!:printf("%v", car r2); + for each a in cdr r2 do c!:printf(", %v", a) >>; + c!:printf(");\n") >> + else if car r3 = c!:current_procedure then << +% Things could go sour here if a function tried to call itself but with the +% wrong number of args. And this happens at one place in the REDUCE source +% code (I hope it will be fixed soon!). I will patch things up here by +% discarding any excess args or padding with NIL if not enough had been +% written. + r2 := c!:fix_nargs(r2, c!:current_args); + c!:printf(" %v = %s(env", r1, c!:current_c_name); + if null r2 or length r2 >= 3 then c!:printf(", %s", length r2); + for each a in r2 do c!:printf(", %v", a); + c!:printf(");\n") >> + else if w := get(car r3, 'c!:c_entrypoint) then << + c!:printf(" %v = %s(nil", r1, w); + if null r2 or length r2 >= 3 then c!:printf(", %s", length r2); + for each a in r2 do c!:printf(", %v", a); + c!:printf(");\n") >> + else begin + scalar nargs; + nargs := length r2; + c!:printf(" fn = elt(env, %s); %> >>; + if boolfn then c!:printf(" %v = %v ? lisp_true : nil;\n", r1, r1); + end; + +symbolic procedure c!:fix_nargs(r2, act); + if null act then nil + else if null r2 then nil . c!:fix_nargs(nil, cdr act) + else car r2 . c!:fix_nargs(cdr r2, cdr act); + +put('call, 'c!:opcode_printer, function c!:pcall); + +symbolic procedure c!:pgoto(lab, depth); + begin + if atom lab then return c!:printf("goto %s;\n", lab); + lab := get(car lab, 'c!:chosen); + if zerop depth then c!:printf("return onevalue(%v);\n", lab) + else if flagp(lab, 'c!:live_across_call) then + c!:printf("{ Lisp_Object res = %v; popv(%s); return onevalue(res); }\n", lab, depth) + else c!:printf("{ popv(%s); return onevalue(%v); }\n", depth, lab) + end; + +symbolic procedure c!:pifnull(s, depth); + c!:printf("%v == nil", car s); + +put('ifnull, 'c!:exit_helper, function c!:pifnull); + +symbolic procedure c!:pifatom(s, depth); + c!:printf("!consp(%v)", car s); + +put('ifatom, 'c!:exit_helper, function c!:pifatom); + +symbolic procedure c!:pifsymbol(s, depth); + c!:printf("symbolp(%v)", car s); + +put('ifsymbol, 'c!:exit_helper, function c!:pifsymbol); + +symbolic procedure c!:pifnumber(s, depth); + c!:printf("is_number(%v)", car s); + +put('ifnumber, 'c!:exit_helper, function c!:pifnumber); + +symbolic procedure c!:pifizerop(s, depth); + c!:printf("(%v) == 1", car s); + +put('ifizerop, 'c!:exit_helper, function c!:pifizerop); + +symbolic procedure c!:pifeq(s, depth); + c!:printf("%v == %v", car s, cadr s); + +put('ifeq, 'c!:exit_helper, function c!:pifeq); + +!#if common!-lisp!-mode +symbolic procedure c!:pifequal(s, depth); + c!:printf("cl_equal(%v, %v)", + car s, cadr s, car s, cadr s); +!#else +symbolic procedure c!:pifequal(s, depth); + c!:printf("equal(%v, %v)", + car s, cadr s, car s, cadr s); +!#endif + +put('ifequal, 'c!:exit_helper, function c!:pifequal); + +symbolic procedure c!:pifilessp(s, depth); + c!:printf("((int32_t)(%v)) < ((int32_t)(%v))", car s, cadr s); + +put('ifilessp, 'c!:exit_helper, function c!:pifilessp); + +symbolic procedure c!:pifigreaterp(s, depth); + c!:printf("((int32_t)(%v)) > ((int32_t)(%v))", car s, cadr s); + +put('ifigreaterp, 'c!:exit_helper, function c!:pifigreaterp); + +symbolic procedure c!:display_flowgraph(s, depth, dropping_through); + if not atom s then << + c!:printf " "; + c!:pgoto(s, depth) >> + else if not flagp(s, 'c!:visited) then begin + scalar why, where_to; + flag(list s, 'c!:visited); + if not dropping_through or not (get(s, 'c!:count) = 1) then + c!:printf("\n%s:\n", s); + for each k in reverse get(s, 'c!:contents) do c!:print_opcode(k, depth); + why := get(s, 'c!:why); + where_to := get(s, 'c!:where_to); + if why = 'goto and (not atom car where_to or + (not flagp(car where_to, 'c!:visited) and + get(car where_to, 'c!:count) = 1)) then + c!:display_flowgraph(car where_to, depth, t) + else c!:print_exit_condition(why, where_to, depth); + end; + +fluid '(c!:startpoint); + +symbolic procedure c!:branch_chain(s, count); + begin + scalar contents, why, where_to, n; +% do nothing to blocks already visted or return blocks. + if not atom s then return s + else if flagp(s, 'c!:visited) then << + n := get(s, 'c!:count); + if null n then n := 1 else n := n + 1; + put(s, 'c!:count, n); + return s >>; + flag(list s, 'c!:visited); + contents := get(s, 'c!:contents); + why := get(s, 'c!:why); + where_to := for each z in get(s, 'c!:where_to) collect + c!:branch_chain(z, count); +% Turn movr a,b; return a; into return b; + while contents and eqcar(car contents, 'movr) and + why = 'goto and not atom car where_to and + caar where_to = cadr car contents do << + where_to := list list cadddr car contents; + contents := cdr contents >>; + put(s, 'c!:contents, contents); + put(s, 'c!:where_to, where_to); +% discard empty blocks + if null contents and why = 'goto then << + remflag(list s, 'c!:visited); + return car where_to >>; + if count then << + n := get(s, 'c!:count); + if null n then n := 1 + else n := n + 1; + put(s, 'c!:count, n) >>; + return s + end; + +symbolic procedure c!:one_operand op; + << flag(list op, 'c!:set_r1); + flag(list op, 'c!:read_r3); + put(op, 'c!:code, function c!:builtin_one) >>; + +symbolic procedure c!:two_operands op; + << flag(list op, 'c!:set_r1); + flag(list op, 'c!:read_r2); + flag(list op, 'c!:read_r3); + put(op, 'c!:code, function c!:builtin_two) >>; + +for each n in '(car cdr qcar qcdr null not atom numberp fixp iminusp + iminus iadd1 isub1 modular!-minus) do c!:one_operand n; +!#if common!-lisp!-mode +for each n in '(eq equal atsoc memq iplus2 idifference + itimes2 ilessp igreaterp qgetv get + modular!-plus modular!-difference + ) do c!:two_operands n; +!#else +for each n in '(eq equal atsoc memq iplus2 idifference + assoc member + itimes2 ilessp igreaterp qgetv get + modular!-plus modular!-difference + ) do c!:two_operands n; +!#endif + + +flag('(movr movk movk1 ldrglob call reloadenv fastget fastflag), 'c!:set_r1); +flag('(strglob qputv), 'c!:read_r1); +flag('(qputv fastget fastflag), 'c!:read_r2); +flag('(movr qputv), 'c!:read_r3); +flag('(ldrglob strglob nilglob movk call), 'c!:read_env); +% special opcodes: +% call fluidbind + +fluid '(fn_used nil_used nilbase_used); + +symbolic procedure c!:live_variable_analysis c!:all_blocks; + begin + scalar changed, z; + repeat << + changed := nil; + for each b in c!:all_blocks do + begin + scalar w, live; + for each x in get(b, 'c!:where_to) do + if atom x then live := union(live, get(x, 'c!:live)) + else live := union(live, x); + w := get(b, 'c!:why); + if not atom w then << + if eqcar(w, 'ifnull) or eqcar(w, 'ifequal) then nil_used := t; + live := union(live, cdr w); + if eqcar(car w, 'call) and + (flagp(cadar w, 'c!:direct_predicate) or + (flagp(cadar w, 'c!:c_entrypoint) and + not flagp(cadar w, 'c!:direct_entrypoint))) then + nil_used := t; + if eqcar(car w, 'call) and + not (cadar w = c!:current_procedure) and + not get(cadar w, 'c!:direct_entrypoint) and + not get(cadar w, 'c!:c_entrypoint) then << + fn_used := t; live := union('(env), live) >> >>; + for each s in get(b, 'c!:contents) do + begin % backwards over contents + scalar op, r1, r2, r3; + op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; + if op = 'movk1 then << + if r3 = nil then nil_used := t + else if r3 = 't then nilbase_used := t >> + else if atom op and flagp(op, 'c!:uses_nil) then nil_used := t; + if flagp(op, 'c!:set_r1) then +!#if common!-lisp!-mode + if memq(r1, live) then live := remove(r1, live) +!#else + if memq(r1, live) then live := delete(r1, live) +!#endif + else if op = 'call then nil % Always needed + else op := 'nop; + if flagp(op, 'c!:read_r1) then live := union(live, list r1); + if flagp(op, 'c!:read_r2) then live := union(live, list r2); + if flagp(op, 'c!:read_r3) then live := union(live, list r3); + if op = 'call then << + if not flagp(car r3, 'c!:no_errors) or + flagp(car r3, 'c!:c_entrypoint) or + get(car r3, 'c!:direct_predicate) then nil_used := t; + does_call := t; + if not eqcar(r3, c!:current_procedure) and + not get(car r3, 'c!:direct_entrypoint) and + not get(car r3, 'c!:c_entrypoint) then fn_used := t; + if not flagp(car r3, 'c!:no_errors) then + flag(live, 'c!:live_across_call); + live := union(live, r2) >>; + if flagp(op, 'c!:read_env) then live := union(live, '(env)) + end; +!#if common!-lisp!-mode + live := append(live, nil); % because CL sort is destructive! +!#endif + live := sort(live, function orderp); + if not (live = get(b, 'c!:live)) then << + put(b, 'c!:live, live); + changed := t >> + end + >> until not changed; + z := c!:registers; + c!:registers := c!:stacklocs := nil; + for each r in z do + if flagp(r, 'c!:live_across_call) then c!:stacklocs := r . c!:stacklocs + else c!:registers := r . c!:registers + end; + +symbolic procedure c!:insert1(a, b); + if memq(a, b) then b + else a . b; + +symbolic procedure c!:clash(a, b); + if flagp(a, 'c!:live_across_call) = flagp(b, 'c!:live_across_call) then << + put(a, 'c!:clash, c!:insert1(b, get(a, 'c!:clash))); + put(b, 'c!:clash, c!:insert1(a, get(b, 'c!:clash))) >>; + +symbolic procedure c!:build_clash_matrix c!:all_blocks; + begin + for each b in c!:all_blocks do + begin + scalar live, w; + for each x in get(b, 'c!:where_to) do + if atom x then live := union(live, get(x, 'c!:live)) + else live := union(live, x); + w := get(b, 'c!:why); + if not atom w then << + live := union(live, cdr w); + if eqcar(car w, 'call) and + not get(cadar w, 'c!:direct_entrypoint) and + not get(cadar w, 'c!:c_entrypoint) then + live := union('(env), live) >>; + for each s in get(b, 'c!:contents) do + begin + scalar op, r1, r2, r3; + op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; + if flagp(op, 'c!:set_r1) then + if memq(r1, live) then << +!#if common!-lisp!-mode + live := remove(r1, live); +!#else + live := delete(r1, live); +!#endif + if op = 'reloadenv then reloadenv := t; + for each v in live do c!:clash(r1, v) >> + else if op = 'call then nil + else << + op := 'nop; + rplacd(s, car s . cdr s); % Leaves original instrn visible + rplaca(s, op) >>; + if flagp(op, 'c!:read_r1) then live := union(live, list r1); + if flagp(op, 'c!:read_r2) then live := union(live, list r2); + if flagp(op, 'c!:read_r3) then live := union(live, list r3); +% Maybe CALL should be a little more selective about need for "env"? + if op = 'call then live := union(live, r2); + if flagp(op, 'c!:read_env) then live := union(live, '(env)) + end + end; +% The next few lines are for debugging... +%%- c!:printf "Scratch registers:\n"; +%%- for each r in c!:registers do +%%- c!:printf("%s clashes: %s\n", r, get(r, 'c!:clash)); +%%- c!:printf "Stack items:\n"; +%%- for each r in c!:stacklocs do +%%- c!:printf("%s clashes: %s\n", r, get(r, 'c!:clash)); + return nil + end; + +symbolic procedure c!:allocate_registers rl; + begin + scalar schedule, neighbours, allocation; + neighbours := 0; + while rl do begin + scalar w, x; + w := rl; + while w and length (x := get(car w, 'c!:clash)) > neighbours do + w := cdr w; + if w then << + schedule := car w . schedule; + rl := deleq(car w, rl); + for each r in x do put(r, 'c!:clash, deleq(car w, get(r, 'c!:clash))) >> + else neighbours := neighbours + 1 + end; + for each r in schedule do begin + scalar poss; + poss := allocation; + for each x in get(r, 'c!:clash) do + poss := deleq(get(x, 'c!:chosen), poss); + if null poss then << + poss := c!:my_gensym(); + allocation := append(allocation, list poss) >> + else poss := car poss; +% c!:printf("%>; + return cdr w + end; + +symbolic procedure c!:assign(u, v, c); + if flagp(u, 'fluid) then list('strglob, v, u, c!:find_literal u) . c + else list('movr, u, nil, v) . c; + +symbolic procedure c!:insert_tailcall b; + begin + scalar why, dest, contents, fcall, res, w; + why := get(b, 'c!:why); + dest := get(b, 'c!:where_to); + contents := get(b, 'c!:contents); + while contents and not eqcar(car contents, 'call) do << + w := car contents . w; + contents := cdr contents >>; + if null contents then return nil; + fcall := car contents; + contents := cdr contents; + res := cadr fcall; + while w do << + if eqcar(car w, 'reloadenv) then w := cdr w + else if eqcar(car w, 'movr) and cadddr car w = res then << + res := cadr car w; + w := cdr w >> + else res := w := nil >>; + if null res then return nil; + if c!:does_return(res, why, dest) then + if car cadddr fcall = c!:current_procedure then << + for each p in pair(c!:current_args, caddr fcall) do + contents := c!:assign(car p, cdr p, contents); + put(b, 'c!:contents, contents); + put(b, 'c!:why, 'goto); + put(b, 'c!:where_to, list restart_label) >> + else << + nil_used := t; + put(b, 'c!:contents, contents); + put(b, 'c!:why, list('call, car cadddr fcall) . caddr fcall); + put(b, 'c!:where_to, nil) >> + end; + +symbolic procedure c!:does_return(res, why, where_to); + if not (why = 'goto) then nil + else if not atom car where_to then res = caar where_to + else begin + scalar contents; + where_to := car where_to; + contents := reverse get(where_to, 'c!:contents); + why := get(where_to, 'c!:why); + where_to := get(where_to, 'c!:where_to); + while contents do + if eqcar(car contents, 'reloadenv) then contents := cdr contents + else if eqcar(car contents, 'movr) and cadddr car contents = res then << + res := cadr car contents; + contents := cdr contents >> + else res := contents := nil; + if null res then return nil + else return c!:does_return(res, why, where_to) + end; + +symbolic procedure c!:pushpop(op, v); +% for each x in v do c!:printf(" %s(%s);\n", op, x); + begin + scalar n, w; + if null v then return nil; + n := length v; + while n > 0 do << + w := n; + if w > 6 then w := 6; + n := n-w; + if w = 1 then c!:printf(" %s(%s);\n", op, car v) + else << + c!:printf(" %s%d(%s", op, w, car v); + v := cdr v; + for i := 2:w do << + c!:printf(",%s", car v); + v := cdr v >>; + c!:printf(");\n") >> >> + end; + +symbolic procedure c!:optimise_flowgraph(c!:startpoint, c!:all_blocks, + env, argch, args); + begin + scalar w, n, locs, stacks, c!:error_labels, fn_used, nil_used, nilbase_used; +!#if common!-lisp!-mode + nilbase_used := t; % For onevalue(xxx) at least +!#endif + for each b in c!:all_blocks do c!:insert_tailcall b; + c!:startpoint := c!:branch_chain(c!:startpoint, nil); + remflag(c!:all_blocks, 'c!:visited); + c!:live_variable_analysis c!:all_blocks; + c!:build_clash_matrix c!:all_blocks; + if c!:error_labels and env then reloadenv := t; + for each u in env do + for each v in env do c!:clash(cdr u, cdr v); % keep all args distinct + locs := c!:allocate_registers c!:registers; + stacks := c!:allocate_registers c!:stacklocs; + flag(stacks, 'c!:live_across_call); + c!:remove_nops c!:all_blocks; + c!:startpoint := c!:branch_chain(c!:startpoint, nil); % after tailcall insertion + remflag(c!:all_blocks, 'c!:visited); + c!:startpoint := c!:branch_chain(c!:startpoint, t); % ... AGAIN to tidy up + remflag(c!:all_blocks, 'c!:visited); + if does_call then nil_used := t; + if nil_used then c!:printf " Lisp_Object nil = C_nil;\n" + else if nilbase_used then c!:printf " nil_as_base\n"; + if locs then << + c!:printf(" Lisp_Object %s", car locs); + for each v in cdr locs do c!:printf(", %s", v); + c!:printf ";\n" >>; + if fn_used then c!:printf " Lisp_Object fn;\n"; + if nil_used then + c!:printf(" CSL_IGNORE(nil);\n") + else if nilbase_used then << + c!:printf("#ifndef NILSEG_EXTERNS\n"); + c!:printf(" CSL_IGNORE(nil);\n"); + c!:printf("#endif\n") >>; + if car argch = 0 or car argch >= 3 then + c!:printf(" argcheck(nargs, %s, \q%s\q);\n", car argch, cdr argch); + c!:printf("#ifdef DEBUG\n"); + c!:printf(" if (check_env(env)) return aerror(\qenv for %s\q);\n", + cdr argch); + c!:printf("#endif\n"); +% I will not do a stack check if I have a leaf procedure, and I hope +% that this policy will speed up code a bit. + if does_call then << + c!:printf " if (stack >= stacklimit)\n"; + c!:printf " {\n"; +% This is slightly clumsy code to save all args on the stack across the +% call to reclaim(), but it is not executed often... + c!:pushpop('push, args); + c!:printf " env = reclaim(env, \qstack\q, GC_STACK, 0);\n"; + c!:pushpop('pop, reverse args); + c!:printf " nil = C_nil;\n"; + c!:printf " if (exception_pending()) return nil;\n"; + c!:printf " }\n" >>; + if reloadenv then c!:printf(" push(env);\n") + else c!:printf(" CSL_IGNORE(env);\n"); + n := 0; + if stacks then << + c!:printf "%>; + w := n; + while w >= 5 do << + c!:printf " push5(nil, nil, nil, nil, nil);\n"; + w := w - 5 >>; + if w neq 0 then << + if w = 1 then c!:printf " push(nil);\n" + else << + c!:printf(" push%s(nil", w); + for i := 2:w do c!:printf ", nil"; + c!:printf ");\n" >> >> >>; + if reloadenv then << + reloadenv := n; + n := n + 1 >>; + if env then c!:printf "%> >>; + remflag(c!:all_blocks, 'c!:visited); + end; + +symbolic procedure c!:print_error_return(why, env, depth); + begin + if reloadenv and env then + c!:printf(" env = stack[%s];\n", -reloadenv); + if null why then << +% One could imagine generating backtrace entries here... + for each v in env do + c!:printf(" qvalue(elt(env, %s)) = %v; %> + else if flagp(cadr why, 'c!:live_across_call) then << + c!:printf(" { Lisp_Object res = %v;\n", cadr why); + for each v in env do + c!:printf(" qvalue(elt(env, %s)) = %v;\n", + c!:find_literal car v, get(cdr v, 'c!:chosen)); + if depth neq 0 then c!:printf(" popv(%s);\n", depth); + c!:printf(" return error(1, %s, res); }\n", + if eqcar(why, 'car) then "err_bad_car" + else if eqcar(why, 'cdr) then "err_bad_cdr" + else error(0, list(why, "unknown_error"))) >> + else << + for each v in env do + c!:printf(" qvalue(elt(env, %s)) = %v;\n", + c!:find_literal car v, get(cdr v, 'c!:chosen)); + if depth neq 0 then c!:printf(" popv(%s);\n", depth); + c!:printf(" return error(1, %s, %v);\n", + (if eqcar(why, 'car) then "err_bad_car" + else if eqcar(why, 'cdr) then "err_bad_cdr" + else error(0, list(why, "unknown_error"))), + cadr why) >> + end; + + +% +% Now I have a series of separable sections each of which gives a special +% recipe that implements or optimises compilation of some specific Lisp +% form. +% + +symbolic procedure c!:cand(u, env); + begin + scalar w, r; + w := reverse cdr u; + if null w then return c!:cval(nil, env); + r := list(list('t, car w)); + w := cdr w; + for each z in w do + r := list(list('null, z), nil) . r; + r := 'cond . r; + return c!:cval(r, env) + end; +%-- scalar next, done, v, r; +%-- v := c!:newreg(); +%-- done := c!:my_gensym(); +%-- u := cdr u; +%-- while cdr u do << +%-- next := c!:my_gensym(); +%-- c!:outop('movr, v, nil, c!:cval(car u, env)); +%-- u := cdr u; +%-- c!:endblock(list('ifnull, v), list(done, next)); +%-- c!:startblock next >>; +%-- c!:outop('movr, v, nil, c!:cval(car u, env)); +%-- c!:endblock('goto, list done); +%-- c!:startblock done; +%-- return v +%-- end; + +put('and, 'c!:code, function c!:cand); + +!#if common!-lisp!-mode + +symbolic procedure c!:cblock(u, env); + begin + scalar progret, progexit, r; + progret := c!:newreg(); + progexit := c!:my_gensym(); + blockstack := (cadr u . progret . progexit) . blockstack; + u := cddr u; + for each a in u do r := c!:cval(a, env); + c!:outop('movr, progret, nil, r); + c!:endblock('goto, list progexit); + c!:startblock progexit; + blockstack := cdr blockstack; + return progret + end; + + +put('block, 'c!:code, function c!:cblock); + +!#endif + +symbolic procedure c!:ccatch(u, env); + error(0, "catch"); + +put('catch, 'c!:code, function c!:ccatch); + +symbolic procedure c!:ccompile_let(u, env); + error(0, "compiler-let"); + +put('compiler!-let, 'c!:code, function c!:ccompiler_let); + +symbolic procedure c!:ccond(u, env); + begin + scalar v, join; + v := c!:newreg(); + join := c!:my_gensym(); + for each c in cdr u do begin + scalar l1, l2; + l1 := c!:my_gensym(); l2 := c!:my_gensym(); + if atom cdr c then << + c!:outop('movr, v, nil, c!:cval(car c, env)); + c!:endblock(list('ifnull, v), list(l2, join)) >> + else << + c!:cjumpif(car c, env, l1, l2); + c!:startblock l1; % if the condition is true + c!:outop('movr, v, nil, c!:cval('progn . cdr c, env)); + c!:endblock('goto, list join) >>; + c!:startblock l2 end; + c!:outop('movk1, v, nil, nil); + c!:endblock('goto, list join); + c!:startblock join; + return v + end; + +put('cond, 'c!:code, function c!:ccond); + +symbolic procedure c!:valid_cond x; + if null x then t + else if not c!:valid_list car x then nil + else c!:valid_cond cdr x; + +put('cond, 'c!:valid, function c!:valid_cond); + +symbolic procedure c!:cdeclare(u, env); + error(0, "declare"); + +put('declare, 'c!:code, function c!:cdeclare); + +symbolic procedure c!:cde(u, env); + error(0, "de"); + +put('de, 'c!:code, function c!:cde); + +symbolic procedure c!:cdefun(u, env); + error(0, "defun"); + +put('!~defun, 'c!:code, function c!:cdefun); + +symbolic procedure c!:ceval_when(u, env); + error(0, "eval-when"); + +put('eval!-when, 'c!:code, function c!:ceval_when); + +symbolic procedure c!:cflet(u, env); + error(0, "flet"); + +put('flet, 'c!:code, function c!:cflet); + + +symbolic procedure c!:cfunction(u, env); + begin + scalar v; + u := cadr u; + if not atom u then << + if not eqcar(u, 'lambda) then + error(0, list("lambda expression needed", u)); + v := dated!-name 'lambda; + pending_functions := + ('de . v . cdr u) . pending_functions; + u := v >>; + v := c!:newreg(); + c!:outop('movk, v, u, c!:find_literal u); + return v; + end; + +symbolic procedure c!:valid_function x; + if atom x then nil + else if not null cdr x then nil + else if idp car x then t + else if atom car x then nil + else if not eqcar(car x, 'lambda) then nil + else if atom cdar x then nil + else c!:valid_fndef(cadar x, cddar x); + +put('function, 'c!:code, function c!:cfunction); +put('function, 'c!:valid, function c!:valid_function); + +symbolic procedure c!:cgo(u, env); + begin + scalar w, w1; + w1 := proglabs; + while null w and w1 do << + w := assoc!*!*(cadr u, car w1); + w1 := cdr w1 >>; + if null w then error(0, list(u, "label not set")); + c!:endblock('goto, list cadr w); + return nil % value should not be used + end; + +put('go, 'c!:code, function c!:cgo); +put('go, 'c!:valid, function c!:valid_quote); + +symbolic procedure c!:cif(u, env); + begin + scalar v, join, l1, l2, w; + v := c!:newreg(); + join := c!:my_gensym(); + l1 := c!:my_gensym(); + l2 := c!:my_gensym(); + c!:cjumpif(car (u := cdr u), env, l1, l2); + c!:startblock l1; + c!:outop('movr, v, nil, c!:cval(car (u := cdr u), env)); + c!:endblock('goto, list join); + c!:startblock l2; + u := cdr u; + if u then u := car u; % permit 2-arg version... + c!:outop('movr, v, nil, c!:cval(u, env)); + c!:endblock('goto, list join); + c!:startblock join; + return v + end; + +put('if, 'c!:code, function c!:cif); + +symbolic procedure c!:clabels(u, env); + error(0, "labels"); + +put('labels, 'c!:code, function c!:clabels); + +symbolic procedure c!:expand!-let(vl, b); + if null vl then 'progn . b + else if null cdr vl then c!:expand!-let!*(vl, b) + else begin scalar vars, vals; + for each v in vl do + if atom v then << vars := v . vars; vals := nil . vals >> + else if atom cdr v then << vars := car v . vars; vals := nil . vals >> + else << vars := car v . vars; vals := cadr v . vals >>; +% if there is any DECLARE it will be at the start of b and the code that +% deals with LAMBDA will cope with it. + return ('lambda . vars . b) . vals + end; + +symbolic procedure c!:clet(x, env); + c!:cval(c!:expand!-let(cadr x, cddr x), env); + +symbolic procedure c!:valid_let x; + if null x then t + else if not c!:valid_cond car x then nil + else c!:valid_list cdr x; + + +!#if common!-lisp!-mode +put('let, 'c!:code, function c!:clet); +put('let, 'c!:valid, function c!:valid_let); +!#else +put('!~let, 'c!:code, function c!:clet); +put('!~let, 'c!:valid, function c!:valid_let); +!#endif + +symbolic procedure c!:expand!-let!*(vl, b); + if null vl then 'progn . b + else begin scalar var, val; + var := car vl; + if not atom var then << + val := cdr var; + var := car var; + if not atom val then val := car val >>; + b := list list('return, c!:expand!-let!*(cdr vl, b)); + if val then b := list('setq, var, val) . b; + return 'prog . list var . b + end; + +symbolic procedure c!:clet!*(x, env); + c!:cval(c!:expand!-let!*(cadr x, cddr x), env); + +put('let!*, 'c!:code, function c!:clet!*); +put('let!*, 'c!:valid, function c!:valid_let); + +symbolic procedure c!:clist(u, env); + if null cdr u then c!:cval(nil, env) + else if null cddr u then c!:cval('ncons . cdr u, env) + else if eqcar(cadr u, 'cons) then + c!:cval(list('acons, cadr cadr u, caddr cadr u, 'list . cddr u), env) + else if null cdddr u then c!:cval('list2 . cdr u, env) + else if null cddddr u then c!:cval('list3 . cdr u, env) + else if null cdr cddddr u then c!:cval('list4 . cdr u, env) + else c!:cval(list('list3!*, cadr u, caddr u, + cadddr u, 'list . cddddr u), env); + +put('list, 'c!:code, function c!:clist); + +symbolic procedure c!:clist!*(u, env); + begin + scalar v; + u := reverse cdr u; + v := car u; + for each a in cdr u do + v := list('cons, a, v); + return c!:cval(v, env) + end; + +put('list!*, 'c!:code, function c!:clist!*); + +symbolic procedure c!:ccons(u, env); + begin + scalar a1, a2; + a1 := s!:improve cadr u; + a2 := s!:improve caddr u; + if a2 = nil or a2 = '(quote nil) or a2 = '(list) then + return c!:cval(list('ncons, a1), env); + if eqcar(a1, 'cons) then + return c!:cval(list('acons, cadr a1, caddr a1, a2), env); + if eqcar(a2, 'cons) then + return c!:cval(list('list2!*, a1, cadr a2, caddr a2), env); + if eqcar(a2, 'list) then + return c!:cval(list('cons, a1, + list('cons, cadr a2, 'list . cddr a2)), env); + return c!:ccall(car u, cdr u, env) + end; + +put('cons, 'c!:code, function c!:ccons); + +symbolic procedure c!:cget(u, env); + begin + scalar a1, a2, w, r, r1; + a1 := s!:improve cadr u; + a2 := s!:improve caddr u; + if eqcar(a2, 'quote) and idp(w := cadr a2) and + (w := symbol!-make!-fastget(w, nil)) then << + r := c!:newreg(); + c!:outop('fastget, r, c!:cval(a1, env), w . cadr a2); + return r >> + else return c!:ccall(car u, cdr u, env) + end; + +put('get, 'c!:code, function c!:cget); + +symbolic procedure c!:cflag(u, env); + begin + scalar a1, a2, w, r, r1; + a1 := s!:improve cadr u; + a2 := s!:improve caddr u; + if eqcar(a2, 'quote) and idp(w := cadr a2) and + (w := symbol!-make!-fastget(w, nil)) then << + r := c!:newreg(); + c!:outop('fastflag, r, c!:cval(a1, env), w . cadr a2); + return r >> + else return c!:ccall(car u, cdr u, env) + end; + +put('flagp, 'c!:code, function c!:cflag); + +symbolic procedure c!:cgetv(u, env); + if not !*fastvector then c!:ccall(car u, cdr u, env) + else c!:cval('qgetv . cdr u, env); + +put('getv, 'c!:code, function c!:cgetv); +!#if common!-lisp!-mode +put('svref, 'c!:code, function c!:cgetv); +!#endif + +symbolic procedure c!:cputv(u, env); + if not !*fastvector then c!:ccall(car u, cdr u, env) + else c!:cval('qputv . cdr u, env); + +put('putv, 'c!:code, function c!:cputv); + +symbolic procedure c!:cqputv(x, env); + begin + scalar rr; + rr := c!:pareval(cdr x, env); + c!:outop('qputv, caddr rr, car rr, cadr rr); + return caddr rr + end; + +put('qputv, 'c!:code, function c!:cqputv); + +symbolic procedure c!:cmacrolet(u, env); + error(0, "macrolet"); + +put('macrolet, 'c!:code, function c!:cmacrolet); + +symbolic procedure c!:cmultiple_value_call(u, env); + error(0, "multiple_value_call"); + +put('multiple!-value!-call, 'c!:code, function c!:cmultiple_value_call); + +symbolic procedure c!:cmultiple_value_prog1(u, env); + error(0, "multiple_value_prog1"); + +put('multiple!-value!-prog1, 'c!:code, function c!:cmultiple_value_prog1); + +symbolic procedure c!:cor(u, env); + begin + scalar next, done, v, r; + v := c!:newreg(); + done := c!:my_gensym(); + u := cdr u; + while cdr u do << + next := c!:my_gensym(); + c!:outop('movr, v, nil, c!:cval(car u, env)); + u := cdr u; + c!:endblock(list('ifnull, v), list(next, done)); + c!:startblock next >>; + c!:outop('movr, v, nil, c!:cval(car u, env)); + c!:endblock('goto, list done); + c!:startblock done; + return v + end; + +put('or, 'c!:code, function c!:cor); + +symbolic procedure c!:cprog(u, env); + begin + scalar w, w1, bvl, local_proglabs, progret, progexit, + fluids, env1, body, decs; + env1 := car env; + bvl := cadr u; + w := s!:find_local_decs(cddr u, t); + body := cdr w; + localdecs := car w . localdecs; +% Anything DECLAREd special that is not already fluid or global +% gets uprated now. decs ends up a list of things that had their status +% changed. + for each v in bvl do << + if not globalp v and not fluidp v and + c!:local_fluidp(v, localdecs) then << + make!-special v; + decs := v . decs >> >>; + for each v in bvl do << + if globalp v then begin scalar oo; + oo := wrs nil; + princ "+++++ "; prin v; + princ " converted from GLOBAL to FLUID"; terpri(); + wrs oo; + unglobal list v; + fluid list v end; +% Note I need to update local_decs + if fluidp v then << + fluids := (v . c!:newreg()) . fluids; + flag(list cdar fluids, 'c!:live_across_call); % silly if not + env1 := ('c!:dummy!:name . cdar fluids) . env1; + c!:outop('ldrglob, cdar fluids, v, c!:find_literal v); + c!:outop('nilglob, nil, v, c!:find_literal v) >> + else << + env1 := (v . c!:newreg()) . env1; + c!:outop('movk1, cdar env1, nil, nil) >> >>; + if fluids then c!:outop('fluidbind, nil, nil, fluids); + env := env1 . append(fluids, cdr env); + u := body; + progret := c!:newreg(); + progexit := c!:my_gensym(); + blockstack := (nil . progret . progexit) . blockstack; + for each a in u do if atom a then + if atsoc(a, local_proglabs) then << + if not null a then << + w := wrs nil; + princ "+++++ multiply defined label: "; prin a; terpri(); wrs w >> >> + else local_proglabs := list(a, c!:my_gensym()) . local_proglabs; + proglabs := local_proglabs . proglabs; + for each a in u do + if atom a then << + w := cdr(assoc!*!*(a, local_proglabs)); + if null cdr w then << + rplacd(w, t); + c!:endblock('goto, list car w); + c!:startblock car w >> >> + else c!:cval(a, env); + c!:outop('movk1, progret, nil, nil); + c!:endblock('goto, list progexit); + c!:startblock progexit; + for each v in fluids do + c!:outop('strglob, cdr v, car v, c!:find_literal car v); + blockstack := cdr blockstack; + proglabs := cdr proglabs; + unfluid decs; % reset effect of DECLARE + localdecs := cdr localdecs; + return progret + end; + +put('prog, 'c!:code, function c!:cprog); + +symbolic procedure c!:valid_prog x; + c!:valid_list cdr x; + +put('prog, 'c!:valid, function c!:valid_prog); + +symbolic procedure c!:cprog!*(u, env); + error(0, "prog*"); + +put('prog!*, 'c!:code, function c!:cprog!*); + +symbolic procedure c!:cprog1(u, env); + begin + scalar g; + g := c!:my_gensym(); + g := list('prog, list g, + list('setq, g, cadr u), + 'progn . cddr u, + list('return, g)); + return c!:cval(g, env) + end; + +put('prog1, 'c!:code, function c!:cprog1); + +symbolic procedure c!:cprog2(u, env); + begin + scalar g; + u := cdr u; + g := c!:my_gensym(); + g := list('prog, list g, + list('setq, g, cadr u), + 'progn . cddr u, + list('return, g)); + g := list('progn, car u, g); + return c!:cval(g, env) + end; + +put('prog2, 'c!:code, function c!:cprog2); + +symbolic procedure c!:cprogn(u, env); + begin + scalar r; + u := cdr u; + if u = nil then u := '(nil); + for each s in u do r := c!:cval(s, env); + return r + end; + +put('progn, 'c!:code, function c!:cprogn); + +symbolic procedure c!:cprogv(u, env); + error(0, "progv"); + +put('progv, 'c!:code, function c!:cprogv); + +symbolic procedure c!:cquote(u, env); + begin + scalar v; + u := cadr u; + v := c!:newreg(); + if null u or u = 't or c!:small_number u then + c!:outop('movk1, v, nil, u) + else c!:outop('movk, v, u, c!:find_literal u); + return v; + end; + +symbolic procedure c!:valid_quote x; + t; + +put('quote, 'c!:code, function c!:cquote); +put('quote, 'c!:valid, function c!:valid_quote); + +symbolic procedure c!:creturn(u, env); + begin + scalar w; + w := assoc!*!*(nil, blockstack); + if null w then error(0, "RETURN out of context"); + c!:outop('movr, cadr w, nil, c!:cval(cadr u, env)); + c!:endblock('goto, list cddr w); + return nil % value should not be used + end; + +put('return, 'c!:code, function c!:creturn); + +!#if common!-lisp!-mode + +symbolic procedure c!:creturn_from(u, env); + begin + scalar w; + w := assoc!*!*(cadr u, blockstack); + if null w then error(0, "RETURN-FROM out of context"); + c!:outop('movr, cadr w, nil, c!:cval(caddr u, env)); + c!:endblock('goto, list cddr w); + return nil % value should not be used + end; + +!#endif + +put('return!-from, 'c!:code, function c!:creturn_from); + +symbolic procedure c!:csetq(u, env); + begin + scalar v, w; + v := c!:cval(caddr u, env); + u := cadr u; + if not idp u then error(0, list(u, "bad variable in setq")) + else if (w := c!:locally_bound(u, env)) then + c!:outop('movr, cdr w, nil, v) + else if flagp(u, 'c!:constant) then + error(0, list(u, "attempt to use setq on a constant")) + else c!:outop('strglob, v, u, c!:find_literal u); + return v + end; + +put('setq, 'c!:code, function c!:csetq); +put('noisy!-setq, 'c!:code, function c!:csetq); + +!#if common!-lisp!-mode + +symbolic procedure c!:ctagbody(u, env); + begin + scalar w, bvl, local_proglabs, res; + u := cdr u; + for each a in u do if atom a then + if atsoc(a, local_proglabs) then << + if not null a then << + w := wrs nil; + princ "+++++ multiply defined label: "; prin a; terpri(); wrs w >> >> + else local_proglabs := list(a, c!:my_gensym()) . local_proglabs; + proglabs := local_proglabs . proglabs; + for each a in u do + if atom a then << + w := cdr(assoc!*!*(a, local_proglabs)); + if null cdr w then << + rplacd(w, t); + c!:endblock('goto, list car w); + c!:startblock car w >> >> + else res := c!:cval(a, env); + if null res then res := c!:cval(nil, env); + proglabs := cdr proglabs; + return res + end; + +put('tagbody, 'c!:code, function c!:ctagbody); + +!#endif + +symbolic procedure c!:cprivate_tagbody(u, env); +% This sets a label for use for tail-call to self. + begin + u := cdr u; + c!:endblock('goto, list car u); + c!:startblock car u; +% This seems to be the proper place to capture the internal names associated +% with argument-vars that must be reset if a tail-call is mapped into a loop. + c!:current_args := for each v in c!:current_args collect begin + scalar z; + z := assoc!*!*(v, car env); + return if z then cdr z else v end; + return c!:cval(cadr u, env) + end; + +put('c!:private_tagbody, 'c!:code, function c!:cprivate_tagbody); + +symbolic procedure c!:cthe(u, env); + c!:cval(caddr u, env); + +put('the, 'c!:code, function c!:cthe); + +symbolic procedure c!:cthrow(u, env); + error(0, "throw"); + +put('throw, 'c!:code, function c!:cthrow); + +symbolic procedure c!:cunless(u, env); + begin + scalar v, join, l1, l2; + v := c!:newreg(); + join := c!:my_gensym(); + l1 := c!:my_gensym(); + l2 := c!:my_gensym(); + c!:cjumpif(cadr u, env, l2, l1); + c!:startblock l1; + c!:outop('movr, v, nil, c!:cval('progn . cddr u, env)); + c!:endblock('goto, list join); + c!:startblock l2; + c!:outop('movk1, v, nil, nil); + c!:endblock('goto, list join); + c!:startblock join; + return v + end; + +put('unless, 'c!:code, function c!:cunless); + +symbolic procedure c!:cunwind_protect(u, env); + error(0, "unwind_protect"); + +put('unwind!-protect, 'c!:code, function c!:cunwind_protect); + +symbolic procedure c!:cwhen(u, env); + begin + scalar v, join, l1, l2; + v := c!:newreg(); + join := c!:my_gensym(); + l1 := c!:my_gensym(); + l2 := c!:my_gensym(); + c!:cjumpif(cadr u, env, l1, l2); + c!:startblock l1; + c!:outop('movr, v, nil, c!:cval('progn . cddr u, env)); + c!:endblock('goto, list join); + c!:startblock l2; + c!:outop('movk1, v, nil, nil); + c!:endblock('goto, list join); + c!:startblock join; + return v + end; + +put('when, 'c!:code, function c!:cwhen); + +% +% End of code to handle special forms - what comes from here on is +% more concerned with performance than with speed. +% + +!#if (not common!-lisp!-mode) + +% mapcar etc are compiled specially as a fudge to achieve an effect as +% if proper environment-capture was implemented for the functional +% argument (which I do not support at present). + +symbolic procedure c!:expand_map(fnargs); + begin + scalar carp, fn, fn1, args, var, avar, moveon, l1, r, s, closed; + fn := car fnargs; +% if the value of a mapping function is not needed I demote from mapcar to +% mapc or from maplist to map. +% if context > 1 then << +% if fn = 'mapcar then fn := 'mapc +% else if fn = 'maplist then fn := 'map >>; + if fn = 'mapc or fn = 'mapcar or fn = 'mapcan then carp := t; + fnargs := cdr fnargs; + if atom fnargs then error(0,"bad arguments to map function"); + fn1 := cadr fnargs; + while eqcar(fn1, 'function) or + (eqcar(fn1, 'quote) and eqcar(cadr fn1, 'lambda)) do << + fn1 := cadr fn1; + closed := t >>; +% if closed is false I will insert FUNCALL since I am invoking a function +% stored in a variable - NB this means that the word FUNCTION becomes +% essential when using mapping operators - this is because I have built +% a 2-Lisp rather than a 1-Lisp. + args := car fnargs; + l1 := c!:my_gensym(); + r := c!:my_gensym(); + s := c!:my_gensym(); + var := c!:my_gensym(); + avar := var; + if carp then avar := list('car, avar); + if closed then fn1 := list(fn1, avar) + else fn1 := list('apply1, fn1, avar); + moveon := list('setq, var, list('cdr, var)); + if fn = 'map or fn = 'mapc then fn := sublis( + list('l1 . l1, 'var . var, + 'fn . fn1, 'args . args, 'moveon . moveon), + '(prog (var) + (setq var args) + l1 (cond + ((not var) (return nil))) + fn + moveon + (go l1))) + else if fn = 'maplist or fn = 'mapcar then fn := sublis( + list('l1 . l1, 'var . var, + 'fn . fn1, 'args . args, 'moveon . moveon, 'r . r), + '(prog (var r) + (setq var args) + l1 (cond + ((not var) (return (reversip r)))) + (setq r (cons fn r)) + moveon + (go l1))) + else fn := sublis( + list('l1 . l1, 'l2 . c!:my_gensym(), 'var . var, + 'fn . fn1, 'args . args, 'moveon . moveon, + 'r . c!:my_gensym(), 's . c!:my_gensym()), + '(prog (var r s) + (setq var args) + (setq r (setq s (list nil))) + l1 (cond + ((not var) (return (cdr r)))) + (rplacd s fn) + l2 (cond + ((not (atom (cdr s))) (setq s (cdr s)) (go l2))) + moveon + (go l1))); + return fn + end; + + +put('map, 'c!:compile_macro, function c!:expand_map); +put('maplist, 'c!:compile_macro, function c!:expand_map); +put('mapc, 'c!:compile_macro, function c!:expand_map); +put('mapcar, 'c!:compile_macro, function c!:expand_map); +put('mapcon, 'c!:compile_macro, function c!:expand_map); +put('mapcan, 'c!:compile_macro, function c!:expand_map); + +!#endif + +% caaar to cddddr get expanded into compositions of +% car, cdr which are compiled in-line + +symbolic procedure c!:expand_carcdr(x); + begin + scalar name; + name := cdr reverse cdr explode2 car x; + x := cadr x; + for each v in name do + x := list(if v = 'a then 'car else 'cdr, x); + return x + end; + +<< put('caar, 'c!:compile_macro, function c!:expand_carcdr); + put('cadr, 'c!:compile_macro, function c!:expand_carcdr); + put('cdar, 'c!:compile_macro, function c!:expand_carcdr); + put('cddr, 'c!:compile_macro, function c!:expand_carcdr); + put('caaar, 'c!:compile_macro, function c!:expand_carcdr); + put('caadr, 'c!:compile_macro, function c!:expand_carcdr); + put('cadar, 'c!:compile_macro, function c!:expand_carcdr); + put('caddr, 'c!:compile_macro, function c!:expand_carcdr); + put('cdaar, 'c!:compile_macro, function c!:expand_carcdr); + put('cdadr, 'c!:compile_macro, function c!:expand_carcdr); + put('cddar, 'c!:compile_macro, function c!:expand_carcdr); + put('cdddr, 'c!:compile_macro, function c!:expand_carcdr); + put('caaaar, 'c!:compile_macro, function c!:expand_carcdr); + put('caaadr, 'c!:compile_macro, function c!:expand_carcdr); + put('caadar, 'c!:compile_macro, function c!:expand_carcdr); + put('caaddr, 'c!:compile_macro, function c!:expand_carcdr); + put('cadaar, 'c!:compile_macro, function c!:expand_carcdr); + put('cadadr, 'c!:compile_macro, function c!:expand_carcdr); + put('caddar, 'c!:compile_macro, function c!:expand_carcdr); + put('cadddr, 'c!:compile_macro, function c!:expand_carcdr); + put('cdaaar, 'c!:compile_macro, function c!:expand_carcdr); + put('cdaadr, 'c!:compile_macro, function c!:expand_carcdr); + put('cdadar, 'c!:compile_macro, function c!:expand_carcdr); + put('cdaddr, 'c!:compile_macro, function c!:expand_carcdr); + put('cddaar, 'c!:compile_macro, function c!:expand_carcdr); + put('cddadr, 'c!:compile_macro, function c!:expand_carcdr); + put('cdddar, 'c!:compile_macro, function c!:expand_carcdr); + put('cddddr, 'c!:compile_macro, function c!:expand_carcdr) >>; + +symbolic procedure c!:builtin_one(x, env); + begin + scalar r1, r2; + r1 := c!:cval(cadr x, env); + c!:outop(car x, r2:=c!:newreg(), cdr env, r1); + return r2 + end; + +symbolic procedure c!:builtin_two(x, env); + begin + scalar a1, a2, r, rr; + a1 := cadr x; + a2 := caddr x; + rr := c!:pareval(list(a1, a2), env); + c!:outop(car x, r:=c!:newreg(), car rr, cadr rr); + return r + end; + +symbolic procedure c!:narg(x, env); + c!:cval(expand(cdr x, get(car x, 'c!:binary_version)), env); + +for each n in + '((plus plus2) + (times times2) + (iplus iplus2) + (itimes itimes2)) do << + put(car n, 'c!:binary_version, cadr n); + put(car n, 'c!:code, function c!:narg) >>; + +!#if common!-lisp!-mode +for each n in + '((!+ plus2) + (!* times2)) do << + put(car n, 'c!:binary_version, cadr n); + put(car n, 'c!:code, function c!:narg) >>; +!#endif + +symbolic procedure c!:cplus2(u, env); + begin + scalar a, b; + a := s!:improve cadr u; + b := s!:improve caddr u; + return if numberp a and numberp b then c!:cval(a+b, env) + else if a = 0 then c!:cval(b, env) + else if a = 1 then c!:cval(list('add1, b), env) + else if b = 0 then c!:cval(a, env) + else if b = 1 then c!:cval(list('add1, a), env) + else if b = -1 then c!:cval(list('sub1, a), env) + else c!:ccall(car u, cdr u, env) + end; + +put('plus2, 'c!:code, function c!:cplus2); + +symbolic procedure c!:ciplus2(u, env); + begin + scalar a, b; + a := s!:improve cadr u; + b := s!:improve caddr u; + return if numberp a and numberp b then c!:cval(a+b, env) + else if a = 0 then c!:cval(b, env) + else if a = 1 then c!:cval(list('iadd1, b), env) + else if b = 0 then c!:cval(a, env) + else if b = 1 then c!:cval(list('iadd1, a), env) + else if b = -1 then c!:cval(list('isub1, a), env) + else c!:builtin_two(u, env) + end; + +put('iplus2, 'c!:code, function c!:ciplus2); + +symbolic procedure c!:cdifference(u, env); + begin + scalar a, b; + a := s!:improve cadr u; + b := s!:improve caddr u; + return if numberp a and numberp b then c!:cval(a-b, env) + else if a = 0 then c!:cval(list('minus, b), env) + else if b = 0 then c!:cval(a, env) + else if b = 1 then c!:cval(list('sub1, a), env) + else if b = -1 then c!:cval(list('add1, a), env) + else c!:ccall(car u, cdr u, env) + end; + +put('difference, 'c!:code, function c!:cdifference); + +symbolic procedure c!:cidifference(u, env); + begin + scalar a, b; + a := s!:improve cadr u; + b := s!:improve caddr u; + return if numberp a and numberp b then c!:cval(a-b, env) + else if a = 0 then c!:cval(list('iminus, b), env) + else if b = 0 then c!:cval(a, env) + else if b = 1 then c!:cval(list('isub1, a), env) + else if b = -1 then c!:cval(list('iadd1, a), env) + else c!:builtin_two(u, env) + end; + +put('idifference, 'c!:code, function c!:cidifference); + +symbolic procedure c!:ctimes2(u, env); + begin + scalar a, b; + a := s!:improve cadr u; + b := s!:improve caddr u; + return if numberp a and numberp b then c!:cval(a*b, env) + else if a = 0 or b = 0 then c!:cval(0, env) + else if a = 1 then c!:cval(b, env) + else if b = 1 then c!:cval(a, env) + else if a = -1 then c!:cval(list('minus, b), env) + else if b = -1 then c!:cval(list('minus, a), env) + else c!:ccall(car u, cdr u, env) + end; + +put('times2, 'c!:code, function c!:ctimes2); + +symbolic procedure c!:citimes2(u, env); + begin + scalar a, b; + a := s!:improve cadr u; + b := s!:improve caddr u; + return if numberp a and numberp b then c!:cval(a*b, env) + else if a = 0 or b = 0 then c!:cval(0, env) + else if a = 1 then c!:cval(b, env) + else if b = 1 then c!:cval(a, env) + else if a = -1 then c!:cval(list('iminus, b), env) + else if b = -1 then c!:cval(list('iminus, a), env) + else c!:builtin_two(u, env) + end; + +put('itimes2, 'c!:code, function c!:citimes2); + +symbolic procedure c!:cminus(u, env); + begin + scalar a, b; + a := s!:improve cadr u; + return if numberp a then c!:cval(-a, env) + else if eqcar(a, 'minus) then c!:cval(cadr a, env) + else c!:ccall(car u, cdr u, env) + end; + +put('minus, 'c!:code, function c!:cminus); + +symbolic procedure c!:ceq(x, env); + begin + scalar a1, a2, r, rr; + a1 := s!:improve cadr x; + a2 := s!:improve caddr x; + if a1 = nil then return c!:cval(list('null, a2), env) + else if a2 = nil then return c!:cval(list('null, a1), env); + rr := c!:pareval(list(a1, a2), env); + c!:outop('eq, r:=c!:newreg(), car rr, cadr rr); + return r + end; + +put('eq, 'c!:code, function c!:ceq); + +symbolic procedure c!:cequal(x, env); + begin + scalar a1, a2, r, rr; + a1 := s!:improve cadr x; + a2 := s!:improve caddr x; + if a1 = nil then return c!:cval(list('null, a2), env) + else if a2 = nil then return c!:cval(list('null, a1), env); + rr := c!:pareval(list(a1, a2), env); + c!:outop((if c!:eqvalid a1 or c!:eqvalid a2 then 'eq else 'equal), + r:=c!:newreg(), car rr, cadr rr); + return r + end; + +put('equal, 'c!:code, function c!:cequal); + + +% +% The next few cases are concerned with demoting functions that use +% equal tests into ones that use eq instead + +symbolic procedure c!:is_fixnum x; + fixp x and x >= -134217728 and x <= 134217727; + +symbolic procedure c!:certainlyatom x; + null x or x=t or c!:is_fixnum x or + (eqcar(x, 'quote) and (symbolp cadr x or c!:is_fixnum cadr x)); + +symbolic procedure c!:atomlist1 u; + atom u or + ((symbolp car u or c!:is_fixnum car u) and c!:atomlist1 cdr u); + +symbolic procedure c!:atomlist x; + null x or + (eqcar(x, 'quote) and c!:atomlist1 cadr x) or + (eqcar(x, 'list) and + (null cdr x or + (c!:certainlyatom cadr x and + c!:atomlist ('list . cddr x)))) or + (eqcar(x, 'cons) and + c!:certainlyatom cadr x and + c!:atomlist caddr x); + +symbolic procedure c!:atomcar x; + (eqcar(x, 'cons) or eqcar(x, 'list)) and + not null cdr x and + c!:certainlyatom cadr x; + +symbolic procedure c!:atomkeys1 u; + atom u or + (not atom car u and + (symbolp caar u or c!:is_fixnum caar u) and + c!:atomlist1 cdr u); + +symbolic procedure c!:atomkeys x; + null x or + (eqcar(x, 'quote) and c!:atomkeys1 cadr x) or + (eqcar(x, 'list) and + (null cdr x or + (c!:atomcar cadr x and + c!:atomkeys ('list . cddr x)))) or + (eqcar(x, 'cons) and + c!:atomcar cadr x and + c!:atomkeys caddr x); + +!#if (not common!-lisp!-mode) + +symbolic procedure c!:comsublis x; + if c!:atomkeys cadr x then 'subla . cdr x + else nil; + +put('sublis, 'c!:compile_macro, function c!:comsublis); + +symbolic procedure c!:comassoc x; + if c!:certainlyatom cadr x or c!:atomkeys caddr x then 'atsoc . cdr x + else nil; + +put('assoc, 'c!:compile_macro, function c!:comassoc); +put('assoc!*!*, 'c!:compile_macro, function c!:comassoc); + +symbolic procedure c!:commember x; + if c!:certainlyatom cadr x or c!:atomlist caddr x then 'memq . cdr x + else nil; + +put('member, 'c!:compile_macro, function c!:commember); + +symbolic procedure c!:comdelete x; + if c!:certainlyatom cadr x or c!:atomlist caddr x then 'deleq . cdr x + else nil; + +put('delete, 'c!:compile_macro, function c!:comdelete); + +!#endif + +symbolic procedure c!:ctestif(x, env, d1, d2); + begin + scalar l1, l2; + l1 := c!:my_gensym(); + l2 := c!:my_gensym(); + c!:jumpif(cadr x, l1, l2); + x := cddr x; + c!:startblock l1; + c!:jumpif(car x, d1, d2); + c!:startblock l2; + c!:jumpif(cadr x, d1, d2) + end; + +put('if, 'c!:ctest, function c!:ctestif); + +symbolic procedure c!:ctestnull(x, env, d1, d2); + c!:cjumpif(cadr x, env, d2, d1); + +put('null, 'c!:ctest, function c!:ctestnull); +put('not, 'c!:ctest, function c!:ctestnull); + +symbolic procedure c!:ctestatom(x, env, d1, d2); + begin + x := c!:cval(cadr x, env); + c!:endblock(list('ifatom, x), list(d1, d2)) + end; + +put('atom, 'c!:ctest, function c!:ctestatom); + +symbolic procedure c!:ctestconsp(x, env, d1, d2); + begin + x := c!:cval(cadr x, env); + c!:endblock(list('ifatom, x), list(d2, d1)) + end; + +put('consp, 'c!:ctest, function c!:ctestconsp); + +symbolic procedure c!:ctestsymbol(x, env, d1, d2); + begin + x := c!:cval(cadr x, env); + c!:endblock(list('ifsymbol, x), list(d1, d2)) + end; + +put('idp, 'c!:ctest, function c!:ctestsymbol); + +symbolic procedure c!:ctestnumberp(x, env, d1, d2); + begin + x := c!:cval(cadr x, env); + c!:endblock(list('ifnumber, x), list(d1, d2)) + end; + +put('numberp, 'c!:ctest, function c!:ctestnumberp); + +symbolic procedure c!:ctestizerop(x, env, d1, d2); + begin + x := c!:cval(cadr x, env); + c!:endblock(list('ifizerop, x), list(d1, d2)) + end; + +put('izerop, 'c!:ctest, function c!:ctestizerop); + +symbolic procedure c!:ctesteq(x, env, d1, d2); + begin + scalar a1, a2, r; + a1 := cadr x; + a2 := caddr x; + if a1 = nil then return c!:cjumpif(a2, env, d2, d1) + else if a2 = nil then return c!:cjumpif(a1, env, d2, d1); + r := c!:pareval(list(a1, a2), env); + c!:endblock('ifeq . r, list(d1, d2)) + end; + +put('eq, 'c!:ctest, function c!:ctesteq); + +symbolic procedure c!:ctesteqcar(x, env, d1, d2); + begin + scalar a1, a2, r, d3; + a1 := cadr x; + a2 := caddr x; + d3 := c!:my_gensym(); + r := c!:pareval(list(a1, a2), env); + c!:endblock(list('ifatom, car r), list(d2, d3)); + c!:startblock d3; + c!:outop('qcar, car r, nil, car r); + c!:endblock('ifeq . r, list(d1, d2)) + end; + +put('eqcar, 'c!:ctest, function c!:ctesteqcar); + +global '(least_fixnum greatest_fixnum); + +least_fixnum := -expt(2, 27); +greatest_fixnum := expt(2, 27) - 1; + +symbolic procedure c!:small_number x; + fixp x and x >= least_fixnum and x <= greatest_fixnum; + +symbolic procedure c!:eqvalid x; + if atom x then c!:small_number x + else if flagp(car x, 'c!:fixnum_fn) then t + else car x = 'quote and (idp cadr x or c!:small_number cadr x); + +flag('(iplus iplus2 idifference iminus itimes itimes2), 'c!:fixnum_fn); + +symbolic procedure c!:ctestequal(x, env, d1, d2); + begin + scalar a1, a2, r; + a1 := s!:improve cadr x; + a2 := s!:improve caddr x; + if a1 = nil then return c!:cjumpif(a2, env, d2, d1) + else if a2 = nil then return c!:cjumpif(a1, env, d2, d1); + r := c!:pareval(list(a1, a2), env); + c!:endblock((if c!:eqvalid a1 or c!:eqvalid a2 then 'ifeq else 'ifequal) . + r, list(d1, d2)) + end; + +put('equal, 'c!:ctest, function c!:ctestequal); + +symbolic procedure c!:ctestneq(x, env, d1, d2); + begin + scalar a1, a2, r; + a1 := s!:improve cadr x; + a2 := s!:improve caddr x; + if a1 = nil then return c!:cjumpif(a2, env, d1, d2) + else if a2 = nil then return c!:cjumpif(a1, env, d1, d2); + r := c!:pareval(list(a1, a2), env); + c!:endblock((if c!:eqvalid a1 or c!:eqvalid a2 then 'ifeq else 'ifequal) . + r, list(d2, d1)) + end; + +put('neq, 'c!:ctest, function c!:ctestneq); + +symbolic procedure c!:ctestilessp(x, env, d1, d2); + begin + scalar r; + r := c!:pareval(list(cadr x, caddr x), env); + c!:endblock('ifilessp . r, list(d1, d2)) + end; + +put('ilessp, 'c!:ctest, function c!:ctestilessp); + +symbolic procedure c!:ctestigreaterp(x, env, d1, d2); + begin + scalar r; + r := c!:pareval(list(cadr x, caddr x), env); + c!:endblock('ifigreaterp . r, list(d1, d2)) + end; + +put('igreaterp, 'c!:ctest, function c!:ctestigreaterp); + +symbolic procedure c!:ctestand(x, env, d1, d2); + begin + scalar next; + for each a in cdr x do << + next := c!:my_gensym(); + c!:cjumpif(a, env, next, d2); + c!:startblock next >>; + c!:endblock('goto, list d1) + end; + +put('and, 'c!:ctest, function c!:ctestand); + +symbolic procedure c!:ctestor(x, env, d1, d2); + begin + scalar next; + for each a in cdr x do << + next := c!:my_gensym(); + c!:cjumpif(a, env, d1, next); + c!:startblock next >>; + c!:endblock('goto, list d2) + end; + +put('or, 'c!:ctest, function c!:ctestor); + +% Here are some of the things that are built into the Lisp kernel +% and that I am happy to allow the compiler to generate direct calls to. +% But NOTE that if any of these were callable with eg either 1 or 2 args +% I would need DIFFERENT C entrypoints for each such case. To that effect +% I need to change this to have +% c!:c_entrypoint1, c!:c_entrypoint2 and c!:c_entrypointn +% rather than a single property name. + +fluid '(c!:c_entrypoint_list); + +null (c!:c_entrypoint_list := '( + (abs c!:c_entrypoint "Labsval") +% (acons c!:c_entrypoint "Lacons") +% (add1 c!:c_entrypoint "Ladd1") +% (apply c!:c_entrypoint "Lapply") + (apply0 c!:c_entrypoint "Lapply0") + (apply1 c!:c_entrypoint "Lapply1") + (apply2 c!:c_entrypoint "Lapply2") + (apply3 c!:c_entrypoint "Lapply3") +% (ash c!:c_entrypoint "Lash") + (ash1 c!:c_entrypoint "Lash1") + (atan c!:c_entrypoint "Latan") + (atom c!:c_entrypoint "Latom") + (atsoc c!:c_entrypoint "Latsoc") + (batchp c!:c_entrypoint "Lbatchp") + (boundp c!:c_entrypoint "Lboundp") + (bps!-putv c!:c_entrypoint "Lbpsputv") + (caaaar c!:c_entrypoint "Lcaaaar") + (caaadr c!:c_entrypoint "Lcaaadr") + (caaar c!:c_entrypoint "Lcaaar") + (caadar c!:c_entrypoint "Lcaadar") + (caaddr c!:c_entrypoint "Lcaaddr") + (caadr c!:c_entrypoint "Lcaadr") + (caar c!:c_entrypoint "Lcaar") + (cadaar c!:c_entrypoint "Lcadaar") + (cadadr c!:c_entrypoint "Lcadadr") + (cadar c!:c_entrypoint "Lcadar") + (caddar c!:c_entrypoint "Lcaddar") + (cadddr c!:c_entrypoint "Lcadddr") + (caddr c!:c_entrypoint "Lcaddr") + (cadr c!:c_entrypoint "Lcadr") + (car c!:c_entrypoint "Lcar") + (cdaaar c!:c_entrypoint "Lcdaaar") + (cdaadr c!:c_entrypoint "Lcdaadr") + (cdaar c!:c_entrypoint "Lcdaar") + (cdadar c!:c_entrypoint "Lcdadar") + (cdaddr c!:c_entrypoint "Lcdaddr") + (cdadr c!:c_entrypoint "Lcdadr") + (cdar c!:c_entrypoint "Lcdar") + (cddaar c!:c_entrypoint "Lcddaar") + (cddadr c!:c_entrypoint "Lcddadr") + (cddar c!:c_entrypoint "Lcddar") + (cdddar c!:c_entrypoint "Lcdddar") + (cddddr c!:c_entrypoint "Lcddddr") + (cdddr c!:c_entrypoint "Lcdddr") + (cddr c!:c_entrypoint "Lcddr") + (cdr c!:c_entrypoint "Lcdr") + (char!-code c!:c_entrypoint "Lchar_code") + (close c!:c_entrypoint "Lclose") + (codep c!:c_entrypoint "Lcodep") + (constantp c!:c_entrypoint "Lconstantp") +% (cons c!:c_entrypoint "Lcons") + (date c!:c_entrypoint "Ldate") + (deleq c!:c_entrypoint "Ldeleq") +% (difference c!:c_entrypoint "Ldifference2") + (digit c!:c_entrypoint "Ldigitp") + (eject c!:c_entrypoint "Leject") + (endp c!:c_entrypoint "Lendp") + (eq c!:c_entrypoint "Leq") + (eqcar c!:c_entrypoint "Leqcar") + (eql c!:c_entrypoint "Leql") + (eqn c!:c_entrypoint "Leqn") +% (error c!:c_entrypoint "Lerror") + (error1 c!:c_entrypoint "Lerror0") % !!! +% (errorset c!:c_entrypoint "Lerrorset") + (evenp c!:c_entrypoint "Levenp") + (evlis c!:c_entrypoint "Levlis") + (explode c!:c_entrypoint "Lexplode") + (explode2 c!:c_entrypoint "Lexplodec") + (explodec c!:c_entrypoint "Lexplodec") + (expt c!:c_entrypoint "Lexpt") + (fix c!:c_entrypoint "Ltruncate") + (fixp c!:c_entrypoint "Lfixp") + (flag c!:c_entrypoint "Lflag") + (flagp!*!* c!:c_entrypoint "Lflagp") + (flagp c!:c_entrypoint "Lflagp") + (flagpcar c!:c_entrypoint "Lflagpcar") + (float c!:c_entrypoint "Lfloat") + (floatp c!:c_entrypoint "Lfloatp") + (fluidp c!:c_entrypoint "Lsymbol_specialp") + (gcdn c!:c_entrypoint "Lgcd") + (gctime c!:c_entrypoint "Lgctime") + (gensym c!:c_entrypoint "Lgensym") + (gensym1 c!:c_entrypoint "Lgensym1") + (geq c!:c_entrypoint "Lgeq") + (get!* c!:c_entrypoint "Lget") +% (get c!:c_entrypoint "Lget") + (getenv c!:c_entrypoint "Lgetenv") + (getv c!:c_entrypoint "Lgetv") + (svref c!:c_entrypoint "Lgetv") + (globalp c!:c_entrypoint "Lsymbol_globalp") + (greaterp c!:c_entrypoint "Lgreaterp") + (iadd1 c!:c_entrypoint "Liadd1") + (idifference c!:c_entrypoint "Lidifference") + (idp c!:c_entrypoint "Lsymbolp") + (igreaterp c!:c_entrypoint "Ligreaterp") + (ilessp c!:c_entrypoint "Lilessp") + (iminus c!:c_entrypoint "Liminus") + (iminusp c!:c_entrypoint "Liminusp") + (indirect c!:c_entrypoint "Lindirect") + (integerp c!:c_entrypoint "Lintegerp") + (iplus2 c!:c_entrypoint "Liplus2") + (iquotient c!:c_entrypoint "Liquotient") + (iremainder c!:c_entrypoint "Liremainder") + (irightshift c!:c_entrypoint "Lirightshift") + (isub1 c!:c_entrypoint "Lisub1") + (itimes2 c!:c_entrypoint "Litimes2") +% (lcm c!:c_entrypoint "Llcm") + (length c!:c_entrypoint "Llength") + (lengthc c!:c_entrypoint "Llengthc") + (leq c!:c_entrypoint "Lleq") + (lessp c!:c_entrypoint "Llessp") + (linelength c!:c_entrypoint "Llinelength") +% (list2!* c!:c_entrypoint "Llist2star") +% (list2 c!:c_entrypoint "Llist2") +% (list3 c!:c_entrypoint "Llist3") + (load!-module c!:c_entrypoint "Lload_module") +% (lognot c!:c_entrypoint "Llognot") + (lposn c!:c_entrypoint "Llposn") + (macro!-function c!:c_entrypoint "Lmacro_function") + (macroexpand!-1 c!:c_entrypoint "Lmacroexpand_1") + (macroexpand c!:c_entrypoint "Lmacroexpand") + (make!-bps c!:c_entrypoint "Lget_bps") + (make!-global c!:c_entrypoint "Lmake_global") + (make!-simple!-string c!:c_entrypoint "Lsmkvect") + (make!-special c!:c_entrypoint "Lmake_special") + (mapstore c!:c_entrypoint "Lmapstore") + (max2 c!:c_entrypoint "Lmax2") + (memq c!:c_entrypoint "Lmemq") + (min2 c!:c_entrypoint "Lmin2") + (minus c!:c_entrypoint "Lminus") + (minusp c!:c_entrypoint "Lminusp") + (mkquote c!:c_entrypoint "Lmkquote") + (mkvect c!:c_entrypoint "Lmkvect") + (mod c!:c_entrypoint "Lmod") + (modular!-difference c!:c_entrypoint "Lmodular_difference") + (modular!-expt c!:c_entrypoint "Lmodular_expt") + (modular!-minus c!:c_entrypoint "Lmodular_minus") + (modular!-number c!:c_entrypoint "Lmodular_number") + (modular!-plus c!:c_entrypoint "Lmodular_plus") + (modular!-quotient c!:c_entrypoint "Lmodular_quotient") + (modular!-reciprocal c!:c_entrypoint "Lmodular_reciprocal") + (modular!-times c!:c_entrypoint "Lmodular_times") + (nconc c!:c_entrypoint "Lnconc") +% (ncons c!:c_entrypoint "Lncons") + (neq c!:c_entrypoint "Lneq") +% (next!-random!-number c!:c_entrypoint "Lnext_random") + (not c!:c_entrypoint "Lnull") + (null c!:c_entrypoint "Lnull") + (numberp c!:c_entrypoint "Lnumberp") + (oddp c!:c_entrypoint "Loddp") + (onep c!:c_entrypoint "Lonep") + (orderp c!:c_entrypoint "Lorderp") +% (ordp c!:c_entrypoint "Lorderp") + (pagelength c!:c_entrypoint "Lpagelength") + (pairp c!:c_entrypoint "Lconsp") + (plist c!:c_entrypoint "Lplist") +% (plus2 c!:c_entrypoint "Lplus2") + (plusp c!:c_entrypoint "Lplusp") + (posn c!:c_entrypoint "Lposn") + (put c!:c_entrypoint "Lputprop") + (putv!-char c!:c_entrypoint "Lsputv") + (putv c!:c_entrypoint "Lputv") + (qcaar c!:c_entrypoint "Lcaar") + (qcadr c!:c_entrypoint "Lcadr") + (qcar c!:c_entrypoint "Lcar") + (qcdar c!:c_entrypoint "Lcdar") + (qcddr c!:c_entrypoint "Lcddr") + (qcdr c!:c_entrypoint "Lcdr") + (qgetv c!:c_entrypoint "Lgetv") +% (quotient c!:c_entrypoint "Lquotient") +% (random c!:c_entrypoint "Lrandom") +% (rational c!:c_entrypoint "Lrational") + (rds c!:c_entrypoint "Lrds") + (reclaim c!:c_entrypoint "Lgc") +% (remainder c!:c_entrypoint "Lrem") + (remd c!:c_entrypoint "Lremd") + (remflag c!:c_entrypoint "Lremflag") + (remob c!:c_entrypoint "Lunintern") + (remprop c!:c_entrypoint "Lremprop") + (reverse c!:c_entrypoint "Lreverse") + (reversip c!:c_entrypoint "Lnreverse") + (rplaca c!:c_entrypoint "Lrplaca") + (rplacd c!:c_entrypoint "Lrplacd") + (schar c!:c_entrypoint "Lsgetv") + (seprp c!:c_entrypoint "Lwhitespace_char_p") + (set!-small!-modulus c!:c_entrypoint "Lset_small_modulus") + (set c!:c_entrypoint "Lset") + (smemq c!:c_entrypoint "Lsmemq") + (spaces c!:c_entrypoint "Lxtab") + (special!-char c!:c_entrypoint "Lspecial_char") + (special!-form!-p c!:c_entrypoint "Lspecial_form_p") + (spool c!:c_entrypoint "Lspool") + (stop c!:c_entrypoint "Lstop") + (stringp c!:c_entrypoint "Lstringp") +% (sub1 c!:c_entrypoint "Lsub1") + (subla c!:c_entrypoint "Lsubla") + (subst c!:c_entrypoint "Lsubst") + (symbol!-env c!:c_entrypoint "Lsymbol_env") + (symbol!-function c!:c_entrypoint "Lsymbol_function") + (symbol!-name c!:c_entrypoint "Lsymbol_name") + (symbol!-set!-definition c!:c_entrypoint "Lsymbol_set_definition") + (symbol!-set!-env c!:c_entrypoint "Lsymbol_set_env") + (symbol!-value c!:c_entrypoint "Lsymbol_value") + (system c!:c_entrypoint "Lsystem") + (terpri c!:c_entrypoint "Lterpri") + (threevectorp c!:c_entrypoint "Lthreevectorp") + (time c!:c_entrypoint "Ltime") +% (times2 c!:c_entrypoint "Ltimes2") + (ttab c!:c_entrypoint "Lttab") + (tyo c!:c_entrypoint "Ltyo") + (unmake!-global c!:c_entrypoint "Lunmake_global") + (unmake!-special c!:c_entrypoint "Lunmake_special") + (upbv c!:c_entrypoint "Lupbv") + (verbos c!:c_entrypoint "Lverbos") + (wrs c!:c_entrypoint "Lwrs") + (xcons c!:c_entrypoint "Lxcons") + (xtab c!:c_entrypoint "Lxtab") +% (orderp c!:c_entrypoint "Lorderp") being retired. + (zerop c!:c_entrypoint "Lzerop") + +% The following can be called without having to provide an environment +% or arg-count. The compiler should check the number of args being +% passed matches the expected number. + + (cons c!:direct_entrypoint (2 . "cons")) + (ncons c!:direct_entrypoint (1 . "ncons")) + (list2 c!:direct_entrypoint (2 . "list2")) + (list2!* c!:direct_entrypoint (3 . "list2star")) + (acons c!:direct_entrypoint (3 . "acons")) + (list3 c!:direct_entrypoint (3 . "list3")) + (list3!* c!:direct_entrypoint (4 . "list3star")) + (list4 c!:direct_entrypoint (4 . "list4")) + (plus2 c!:direct_entrypoint (2 . "plus2")) + (difference c!:direct_entrypoint (2 . "difference2")) + (add1 c!:direct_entrypoint (1 . "add1")) + (sub1 c!:direct_entrypoint (1 . "sub1")) + (lognot c!:direct_entrypoint (1 . "lognot")) + (ash c!:direct_entrypoint (2 . "ash")) + (quotient c!:direct_entrypoint (2 . "quot2")) + (remainder c!:direct_entrypoint (2 . "Cremainder")) + (times2 c!:direct_entrypoint (2 . "times2")) + (minus c!:direct_entrypoint (1 . "negate")) +% (rational c!:direct_entrypoint (1 . "rational")) + (lessp c!:direct_predicate (2 . "lessp2")) + (leq c!:direct_predicate (2 . "lesseq2")) + (greaterp c!:direct_predicate (2 . "greaterp2")) + (geq c!:direct_predicate (2 . "geq2")) + (zerop c!:direct_predicate (1 . "zerop")) + ))$ + +!#if common!-lisp!-mode +null (c!:c_entrypoint_list := append(c!:c_entrypoint_list, '( + (!1!+ c!:c_entrypoint "Ladd1") + (equal c!:c_entrypoint "Lcl_equal") + (!1!- c!:c_entrypoint "Lsub1") + (vectorp c!:c_entrypoint "Lvectorp"))))$ +!#endif + +!#if (not common!-lisp!-mode) +null (c!:c_entrypoint_list := append(c!:c_entrypoint_list, '( + (append c!:c_entrypoint "Lappend") + (assoc c!:c_entrypoint "Lassoc") + (compress c!:c_entrypoint "Lcompress") + (delete c!:c_entrypoint "Ldelete") + (divide c!:c_entrypoint "Ldivide") + (equal c!:c_entrypoint "Lequal") + (intern c!:c_entrypoint "Lintern") + (liter c!:c_entrypoint "Lalpha_char_p") + (member c!:c_entrypoint "Lmember") + (prin c!:c_entrypoint "Lprin") + (prin1 c!:c_entrypoint "Lprin") + (prin2 c!:c_entrypoint "Lprinc") + (princ c!:c_entrypoint "Lprinc") + (print c!:c_entrypoint "Lprint") + (printc c!:c_entrypoint "Lprintc") + (read c!:c_entrypoint "Lread") + (readch c!:c_entrypoint "Lreadch") + (sublis c!:c_entrypoint "Lsublis") + (vectorp c!:c_entrypoint "Lsimple_vectorp") + (get c!:direct_entrypoint (2 . "get")))))$ +!#endif + +for each x in c!:c_entrypoint_list do put(car x, cadr x, caddr x)$ + +flag( + '(atom atsoc codep constantp deleq digit endp eq eqcar evenp + eql fixp flagp flagpcar floatp get globalp iadd1 idifference idp + igreaterp ilessp iminus iminusp indirect integerp iplus2 irightshift + isub1 itimes2 liter memq minusp modular!-difference modular!-expt + modular!-minus modular!-number modular!-plus modular!-times not + null numberp onep pairp plusp qcaar qcadr qcar qcdar qcddr + qcdr remflag remprop reversip seprp special!-form!-p stringp + symbol!-env symbol!-name symbol!-value threevectorp vectorp zerop), + 'c!:no_errors); + +end; + +% End of ccomp.red + diff -Nru mathpiper-0.81f+svn4469+dfsg2/lib/build_scripts/checkall.red mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/checkall.red --- mathpiper-0.81f+svn4469+dfsg2/lib/build_scripts/checkall.red 1970-01-01 00:00:00.000000000 +0000 +++ mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/checkall.red 2011-04-09 07:08:25.000000000 +0000 @@ -0,0 +1,13 @@ +% +% This script is normally run as +% r38 ../util/checkall.red -D@srcdir=DIR -Dwhich_module=XXX +% where XXX is the name of a module that is to be checked. If XXX is left +% empty then the script will check all known modules. +% + +load!-module 'remake; + +lisp check_a_package(); + +end; + diff -Nru mathpiper-0.81f+svn4469+dfsg2/lib/build_scripts/checks.lsp mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/checks.lsp --- mathpiper-0.81f+svn4469+dfsg2/lib/build_scripts/checks.lsp 1970-01-01 00:00:00.000000000 +0000 +++ mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/checks.lsp 2011-04-09 07:08:25.000000000 +0000 @@ -0,0 +1,375 @@ +% Checks on basic arithmetic..." + +% This rather crude set of tests was used for initial and basic +% functionality-testing of arithmetic when CSL was adapted for use +% on 64-bit architectures. It may still be useful as a minimal part of +% a set of regression tests... + +(de tests (a b r) + (prog (w) + (setq w (list (plus a b) (plus b a))) + (setq w (list!* (difference a b) (difference b a) w)) + (setq w (list!* (times a b) (times b a) w)) + (setq w (list!* (quotient a b) (quotient b a) w)) + (setq w (list!* (remainder a b) (remainder b a) w)) + (setq w (list!* (greaterp a b) (greaterp b a) w)) + (setq w (list!* (lessp a b) (lessp b a) w)) + (setq w (list!* (equal a b) (equal b a) w)) +% (terpri) (print (list 'tests a b (list 'quote w))) + (cond ((not (equal r w)) + (terpri) + (printc "*** ERROR ***") + (princ "a = ") (print a) + (princ "b = ") (print b) + (showall r w) + (error 0 "messed up"))) + (return nil))) + +(de showall (r w) + (prog (z) + (princ "op") + (ttab 5) (princ "correct") + (ttab 40) (printc "computed") + (setq z '(!= != !< !< !> !> !% !% !/ !/ !* !* !- !- !+ !+)) +top (cond ((or (null r) (null w) (null z)) (return nil))) + (cond + ((equal (car r) (car w)) + (princ " ")) + (t (princ "? "))) + (princ (car z)) (ttab 5) + (prin (car r)) (ttab 40) (print (car w)) + (setq r (cdr r)) (setq w (cdr w)) (setq z (cdr z)) + (go top))) + +(tests 1 1 (quote (t t nil nil nil nil 0 0 1 1 1 1 0 0 2 2))) + +(tests 1 2 (quote (nil nil t nil nil t 1 0 0 2 2 2 -1 1 3 3))) + +(tests 1 10000 (quote (nil nil t nil nil t 1 0 0 10000 10000 10000 +-9999 9999 10001 10001))) + +(tests 1 1000000000 (quote (nil nil t nil nil t 1 0 0 1000000000 +1000000000 1000000000 -999999999 999999999 1000000001 1000000001)) +) + +(tests 1 100000000000000000000 (quote (nil nil t nil nil t 1 0 0 +100000000000000000000 100000000000000000000 100000000000000000000 +-99999999999999999999 99999999999999999999 100000000000000000001 +100000000000000000001))) + +(tests 1 100000000000000000000000000000000 (quote (nil nil t nil +nil t 1 0 0 100000000000000000000000000000000 +100000000000000000000000000000000 +100000000000000000000000000000000 +-99999999999999999999999999999999 99999999999999999999999999999999 +100000000000000000000000000000001 +100000000000000000000000000000001))) + +(tests 3 1 (quote (nil nil nil t t nil 0 1 3 0 3 3 2 -2 4 4))) + +(tests 3 2 (quote (nil nil nil t t nil 1 2 1 0 6 6 1 -1 5 5))) + +(tests 3 10000 (quote (nil nil t nil nil t 3 1 0 3333 30000 30000 +-9997 9997 10003 10003))) + +(tests 3 1000000000 (quote (nil nil t nil nil t 3 1 0 333333333 +3000000000 3000000000 -999999997 999999997 1000000003 1000000003)) +) + +(tests 3 100000000000000000000 (quote (nil nil t nil nil t 3 1 0 +33333333333333333333 300000000000000000000 300000000000000000000 +-99999999999999999997 99999999999999999997 100000000000000000003 +100000000000000000003))) + +(tests 3 100000000000000000000000000000000 (quote (nil nil t nil +nil t 3 1 0 33333333333333333333333333333333 +300000000000000000000000000000000 +300000000000000000000000000000000 +-99999999999999999999999999999997 99999999999999999999999999999997 +100000000000000000000000000000003 +100000000000000000000000000000003))) + +(tests 7777 1 (quote (nil nil nil t t nil 0 1 7777 0 7777 7777 7776 +-7776 7778 7778))) + +(tests 7777 2 (quote (nil nil nil t t nil 1 2 3888 0 15554 15554 +7775 -7775 7779 7779))) + +(tests 7777 10000 (quote (nil nil t nil nil t 7777 2223 0 1 +77770000 77770000 -2223 2223 17777 17777))) + +(tests 7777 1000000000 (quote (nil nil t nil nil t 7777 2232 0 +128584 7777000000000 7777000000000 -999992223 999992223 1000007777 +1000007777))) + +(tests 7777 100000000000000000000 (quote (nil nil t nil nil t 7777 +3334 0 12858428700012858 777700000000000000000000 +777700000000000000000000 -99999999999999992223 +99999999999999992223 100000000000000007777 100000000000000007777)) +) + +(tests 7777 100000000000000000000000000000000 (quote (nil nil t nil +nil t 7777 3334 0 12858428700012858428700012858 +777700000000000000000000000000000000 +777700000000000000000000000000000000 +-99999999999999999999999999992223 99999999999999999999999999992223 +100000000000000000000000000007777 +100000000000000000000000000007777))) + +(tests 3141592653882 1 (quote (nil nil nil t t nil 0 1 +3141592653882 0 3141592653882 3141592653882 3141592653881 +-3141592653881 3141592653883 3141592653883))) + +(tests 3141592653882 2 (quote (nil nil nil t t nil 0 2 +1570796326941 0 6283185307764 6283185307764 3141592653880 +-3141592653880 3141592653884 3141592653884))) + +(tests 3141592653882 10000 (quote (nil nil nil t t nil 3882 10000 +314159265 0 31415926538820000 31415926538820000 3141592643882 +-3141592643882 3141592663882 3141592663882))) + +(tests 3141592653882 1000000000 (quote (nil nil nil t t nil +592653882 1000000000 3141 0 3141592653882000000000 +3141592653882000000000 3140592653882 -3140592653882 3142592653882 +3142592653882))) + +(tests 3141592653882 100000000000000000000 (quote (nil nil t nil +nil t 3141592653882 1933393904584 0 31830988 +314159265388200000000000000000000 +314159265388200000000000000000000 -99999996858407346118 +99999996858407346118 100000003141592653882 100000003141592653882)) +) + +(tests 3141592653882 100000000000000000000000000000000 (quote (nil +nil t nil nil t 3141592653882 1024789465762 0 31830988615418393659 +314159265388200000000000000000000000000000000 +314159265388200000000000000000000000000000000 +-99999999999999999996858407346118 99999999999999999996858407346118 +100000000000000000003141592653882 +100000000000000000003141592653882))) + +(tests 7788882333333333300000000000000331 1 (quote (nil nil nil t t +nil 0 1 7788882333333333300000000000000331 0 +7788882333333333300000000000000331 +7788882333333333300000000000000331 +7788882333333333300000000000000330 +-7788882333333333300000000000000330 +7788882333333333300000000000000332 +7788882333333333300000000000000332))) + +(tests 7788882333333333300000000000000331 2 (quote (nil nil nil t t +nil 1 2 3894441166666666650000000000000165 0 +15577764666666666600000000000000662 +15577764666666666600000000000000662 +7788882333333333300000000000000329 +-7788882333333333300000000000000329 +7788882333333333300000000000000333 +7788882333333333300000000000000333))) + +(tests 7788882333333333300000000000000331 10000 (quote (nil nil nil +t t nil 331 10000 778888233333333330000000000000 0 +77888823333333333000000000000003310000 +77888823333333333000000000000003310000 +7788882333333333299999999999990331 +-7788882333333333299999999999990331 +7788882333333333300000000000010331 +7788882333333333300000000000010331))) + +(tests 7788882333333333300000000000000331 1000000000 (quote (nil +nil nil t t nil 331 1000000000 7788882333333333300000000 0 +7788882333333333300000000000000331000000000 +7788882333333333300000000000000331000000000 +7788882333333333299999999000000331 +-7788882333333333299999999000000331 +7788882333333333300000001000000331 +7788882333333333300000001000000331))) + +(tests 7788882333333333300000000000000331 100000000000000000000 ( +quote (nil nil nil t t nil 33300000000000000331 +100000000000000000000 77888823333333 0 +778888233333333330000000000000033100000000000000000000 +778888233333333330000000000000033100000000000000000000 +7788882333333233300000000000000331 +-7788882333333233300000000000000331 +7788882333333433300000000000000331 +7788882333333433300000000000000331))) + +(tests 7788882333333333300000000000000331 +100000000000000000000000000000000 (quote (nil nil nil t t nil +88882333333333300000000000000331 100000000000000000000000000000000 +77 0 +778888233333333330000000000000033100000000000000000000000000000000 +778888233333333330000000000000033100000000000000000000000000000000 +7688882333333333300000000000000331 +-7688882333333333300000000000000331 +7888882333333333300000000000000331 +7888882333333333300000000000000331))) + +(tests -1 1 (quote (nil nil t nil nil t 0 0 -1 -1 -1 -1 -2 2 0 0)) +) + +(tests -1 2 (quote (nil nil t nil nil t -1 0 0 -2 -2 -2 -3 3 1 1)) +) + +(tests -1 10000 (quote (nil nil t nil nil t -1 0 0 -10000 -10000 +-10000 -10001 10001 9999 9999))) + +(tests -1 1000000000 (quote (nil nil t nil nil t -1 0 0 +-1000000000 -1000000000 -1000000000 -1000000001 1000000001 +999999999 999999999))) + +(tests -1 100000000000000000000 (quote (nil nil t nil nil t -1 0 0 +-100000000000000000000 -100000000000000000000 +-100000000000000000000 -100000000000000000001 +100000000000000000001 99999999999999999999 99999999999999999999))) + +(tests -1 100000000000000000000000000000000 (quote (nil nil t nil +nil t -1 0 0 -100000000000000000000000000000000 +-100000000000000000000000000000000 +-100000000000000000000000000000000 +-100000000000000000000000000000001 +100000000000000000000000000000001 99999999999999999999999999999999 +99999999999999999999999999999999))) + +(tests -3 1 (quote (nil nil t nil nil t 0 1 -3 0 -3 -3 -4 4 -2 -2) +)) + +(tests -3 2 (quote (nil nil t nil nil t -1 2 -1 0 -6 -6 -5 5 -1 -1 +))) + +(tests -3 10000 (quote (nil nil t nil nil t -3 1 0 -3333 -30000 +-30000 -10003 10003 9997 9997))) + +(tests -3 1000000000 (quote (nil nil t nil nil t -3 1 0 -333333333 +-3000000000 -3000000000 -1000000003 1000000003 999999997 999999997 +))) + +(tests -3 100000000000000000000 (quote (nil nil t nil nil t -3 1 0 +-33333333333333333333 -300000000000000000000 +-300000000000000000000 -100000000000000000003 +100000000000000000003 99999999999999999997 99999999999999999997))) + +(tests -3 100000000000000000000000000000000 (quote (nil nil t nil +nil t -3 1 0 -33333333333333333333333333333333 +-300000000000000000000000000000000 +-300000000000000000000000000000000 +-100000000000000000000000000000003 +100000000000000000000000000000003 99999999999999999999999999999997 +99999999999999999999999999999997))) + +(tests -7777 1 (quote (nil nil t nil nil t 0 1 -7777 0 -7777 -7777 +-7778 7778 -7776 -7776))) + +(tests -7777 2 (quote (nil nil t nil nil t -1 2 -3888 0 -15554 +-15554 -7779 7779 -7775 -7775))) + +(tests -7777 10000 (quote (nil nil t nil nil t -7777 2223 0 -1 +-77770000 -77770000 -17777 17777 2223 2223))) + +(tests -7777 1000000000 (quote (nil nil t nil nil t -7777 2232 0 +-128584 -7777000000000 -7777000000000 -1000007777 1000007777 +999992223 999992223))) + +(tests -7777 100000000000000000000 (quote (nil nil t nil nil t +-7777 3334 0 -12858428700012858 -777700000000000000000000 +-777700000000000000000000 -100000000000000007777 +100000000000000007777 99999999999999992223 99999999999999992223))) + +(tests -7777 100000000000000000000000000000000 (quote (nil nil t +nil nil t -7777 3334 0 -12858428700012858428700012858 +-777700000000000000000000000000000000 +-777700000000000000000000000000000000 +-100000000000000000000000000007777 +100000000000000000000000000007777 99999999999999999999999999992223 +99999999999999999999999999992223))) + +(tests -3141592653882 1 (quote (nil nil t nil nil t 0 1 +-3141592653882 0 -3141592653882 -3141592653882 -3141592653883 +3141592653883 -3141592653881 -3141592653881))) + +(tests -3141592653882 2 (quote (nil nil t nil nil t 0 2 +-1570796326941 0 -6283185307764 -6283185307764 -3141592653884 +3141592653884 -3141592653880 -3141592653880))) + +(tests -3141592653882 10000 (quote (nil nil t nil nil t -3882 10000 +-314159265 0 -31415926538820000 -31415926538820000 -3141592663882 +3141592663882 -3141592643882 -3141592643882))) + +(tests -3141592653882 1000000000 (quote (nil nil t nil nil t +-592653882 1000000000 -3141 0 -3141592653882000000000 +-3141592653882000000000 -3142592653882 3142592653882 +-3140592653882 -3140592653882))) + +(tests -3141592653882 100000000000000000000 (quote (nil nil t nil +nil t -3141592653882 1933393904584 0 -31830988 +-314159265388200000000000000000000 +-314159265388200000000000000000000 -100000003141592653882 +100000003141592653882 99999996858407346118 99999996858407346118))) + +(tests -3141592653882 100000000000000000000000000000000 (quote ( +nil nil t nil nil t -3141592653882 1024789465762 0 +-31830988615418393659 +-314159265388200000000000000000000000000000000 +-314159265388200000000000000000000000000000000 +-100000000000000000003141592653882 +100000000000000000003141592653882 99999999999999999996858407346118 +99999999999999999996858407346118))) + +(tests -7788882333333333300000000000000331 1 (quote (nil nil t nil +nil t 0 1 -7788882333333333300000000000000331 0 +-7788882333333333300000000000000331 +-7788882333333333300000000000000331 +-7788882333333333300000000000000332 +7788882333333333300000000000000332 +-7788882333333333300000000000000330 +-7788882333333333300000000000000330))) + +(tests -7788882333333333300000000000000331 2 (quote (nil nil t nil +nil t -1 2 -3894441166666666650000000000000165 0 +-15577764666666666600000000000000662 +-15577764666666666600000000000000662 +-7788882333333333300000000000000333 +7788882333333333300000000000000333 +-7788882333333333300000000000000329 +-7788882333333333300000000000000329))) + +(tests -7788882333333333300000000000000331 10000 (quote (nil nil t +nil nil t -331 10000 -778888233333333330000000000000 0 +-77888823333333333000000000000003310000 +-77888823333333333000000000000003310000 +-7788882333333333300000000000010331 +7788882333333333300000000000010331 +-7788882333333333299999999999990331 +-7788882333333333299999999999990331))) + +(tests -7788882333333333300000000000000331 1000000000 (quote (nil +nil t nil nil t -331 1000000000 -7788882333333333300000000 0 +-7788882333333333300000000000000331000000000 +-7788882333333333300000000000000331000000000 +-7788882333333333300000001000000331 +7788882333333333300000001000000331 +-7788882333333333299999999000000331 +-7788882333333333299999999000000331))) + +(tests -7788882333333333300000000000000331 100000000000000000000 ( +quote (nil nil t nil nil t -33300000000000000331 +100000000000000000000 -77888823333333 0 +-778888233333333330000000000000033100000000000000000000 +-778888233333333330000000000000033100000000000000000000 +-7788882333333433300000000000000331 +7788882333333433300000000000000331 +-7788882333333233300000000000000331 +-7788882333333233300000000000000331))) + +(tests -7788882333333333300000000000000331 +100000000000000000000000000000000 (quote (nil nil t nil nil t +-88882333333333300000000000000331 +100000000000000000000000000000000 -77 0 +-778888233333333330000000000000033100000000000000000000000000000000 +-778888233333333330000000000000033100000000000000000000000000000000 +-7888882333333333300000000000000331 +7888882333333333300000000000000331 +-7688882333333333300000000000000331 +-7688882333333333300000000000000331))) + +(stop 0) diff -Nru mathpiper-0.81f+svn4469+dfsg2/lib/build_scripts/clash.red mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/clash.red --- mathpiper-0.81f+svn4469+dfsg2/lib/build_scripts/clash.red 1970-01-01 00:00:00.000000000 +0000 +++ mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/clash.red 2011-04-09 07:08:25.000000000 +0000 @@ -0,0 +1,23 @@ +% Identify clashes between function definitions... + +symbolic; + +% for each n in oblist() do put(n, 'load!-source, t); + +load!-source := t; + +for each m in library!-members() do load!-source m; + +linelength 100; + +for each n in oblist() do << + z := get(n, 'load!-source); + if not atom z and cdr z then << + prin n; ttab 30; princ " defined in "; + for each z1 in z do << + princ " "; princ z1>>; + terpri() >> >>; + + +quit; + diff -Nru mathpiper-0.81f+svn4469+dfsg2/lib/build_scripts/compat.lsp mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/compat.lsp --- mathpiper-0.81f+svn4469+dfsg2/lib/build_scripts/compat.lsp 1970-01-01 00:00:00.000000000 +0000 +++ mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/compat.lsp 2011-04-09 07:08:25.000000000 +0000 @@ -0,0 +1,500 @@ +% This file defines functions and variables needed to make REDUCE +% and the underlying CSL system compatible. it should +% be loaded as the first file whenever REDUCE services are required. + + + +% Redistribution and use in source and binary forms, with or without +% modification, are permitted provided that the following conditions +% are met: +% +% * Redistributions of source code must retain the relevant +% copyright notice, this list of conditions and the following +% disclaimer. +% * Redistributions in binary form must reproduce the above +% copyright notice, this list of conditions and the following +% disclaimer in the documentation and/or other materials provided +% with the distribution. +% +% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +% + +(setpchar "> ") + +(remflag '(geq leq neq logand logor logxor leftshift princ printc + evenp reversip seprp atsoc eqcar flagp!*!* flagpcar get!* + prin1 prin2 apply0 apply1 apply2 apply3 smemq spaces + subla gcdn lcmn printprompt pair putc) 'lose) + +(symbol!-make!-fastget 32) +(symbol!-make!-fastget 'noncom 0) % built into the kernel +(symbol!-make!-fastget 'lose 1) + +(flag '(raise lower echo comp plap pgwd pwrds savedef) 'switch) + +(make!-special '!*echo) +(setq !*echo nil) +(make!-special '!*raise) +(setq !*raise nil) +(make!-special '!*lower) +(setq !*lower t) +(make!-special '!*savedef) +% I only nil out !*savedef if it is not already present because of +% some bootstrapping delicacies when this file is re-loaded. +(if (not (boundp '!*savedef)) (setq !*savedef nil)) +(make!-special '!*comp) +(setq !*comp nil) +(make!-special '!*plap) +(setq !*plap nil) +(make!-special '!*pgwd) +(setq !*pgwd nil) +(make!-special '!*pwrds) +(setq !*pwrds t) + +% Until the following lines have been executed the +% bitwise operations listed here will not work. + +(progn + (symbol!-set!-env 'logand 1) + (symbol!-set!-env 'logxor 6) + (symbol!-set!-env 'logor 7) + (symbol!-set!-env 'logeqv 9)) + +(make!-special '!!fleps1) +(setq !!fleps1 1.0e-12) +(symbol!-set!-env 'safe!-fp!-plus '!!fleps1) + +(de rplacw (a b) (progn (rplaca a (car b)) (rplacd a (cdr b)))) + +(de expand (l fn) + (cond + ((null (cdr l)) (car l)) + (t (list fn (car l) (expand (cdr l) fn))))) + +(dm plus (a) + (cond ((null (cdr a)) 0) + (t (expand (cdr a) 'plus2)))) + +(dm times (a) + (cond ((null (cdr a)) 1) + (t (expand (cdr a) 'times2)))) + +(de mapcar (l fn) + (prog (r) + top (cond ((null l) (return (reversip r)))) + (setq r (cons (funcall fn (car l)) r)) + (setq l (cdr l)) + (go top))) + +(de maplist (l fn) + (prog (r) + top (cond ((null l) (return (reversip r)))) + (setq r (cons (funcall fn l) r)) + (setq l (cdr l)) + (go top))) + +(de mapcan (l fn) + (cond ((null l) nil) + (t (nconc (funcall fn (car l)) (mapcan (cdr l) fn))))) + +(de mapcon (l fn) + (cond ((null l) nil) + (t (nconc (funcall fn l) (mapcon (cdr l) fn))))) + +(de mapc (l fn) + (prog () + top (cond ((null l) (return nil))) + (funcall fn (car l)) + (setq l (cdr l)) + (go top))) + +(de map (l fn) + (prog () + top (cond ((null l) (return nil))) + (funcall fn l) + (setq l (cdr l)) + (go top))) + +(de copy (a) + (cond + ((atom a) a) + (t (cons (copy (car a)) (copy (cdr a)))))) + +(de sassoc (a l fn) + (cond + ((atom l) (funcall fn)) + ((equal a (caar l)) (car l)) + (t (sassoc a (cdr l) fn)))) + +(de rassoc (x l) % Not in Standard Lisp + (prog () +loop (cond ((atom l) (return nil)) + ((equal x (cdar l)) (return (car l))) + (t (setq l (cdr l)) (go loop))) )) + +(de lastcar (x) % Not in Standard Lisp + (cond + ((null x) nil) + ((null (cdr x)) (car x)) + (t (lastcar (cdr x))))) + + +% The system-coded primitive function INTERNAL-OPEN opens a file, and takes +% a second argument that shows what options are wanted. See "print.c" for an +% explanation of the bits. + +(de open (a b) + (cond + ((eq b 'input) (internal!-open a (plus 1 64))) + % if-does-not-exist error + ((eq b 'output) (internal!-open a (plus 2 20 32))) + % if-does-not-exist create, + % if-exists new-version + ((eq b 'append) (internal!-open a (plus 2 8 32))) + % if-exists append + (t (error "bad direction ~A in open" b)))) + +(de binopen (a b) + (cond + ((eq b 'input) (internal!-open a (plus 1 64 128))) + ((eq b 'output) (internal!-open a (plus 2 20 32 128))) + ((eq b 'append) (internal!-open a (plus 2 8 32 128))) + (t (error "bad direction ~A in binopen" b)))) + +(de pipe!-open (c d) + (cond + ((eq d 'input) (internal!-open c (plus 1 256))) + ((eq d 'output) (internal!-open c (plus 2 256))) + (t (error "bad direction ~A in pipe-open" d)))) + +(de putd (a type b) + (progn + (cond + ((eqcar b 'funarg) (setq b (cons 'lambda (cddr b))))) + (cond + ((flagp a 'lose) (progn + (terpri) (princ "+++ ") (prin a) + (printc " not defined (LOSE flag)") + nil)) + (t (progn + (cond + ((and !*redefmsg (getd a)) (progn + (terpri) (princ "+++ ") (prin a) (printc " redefined")))) + (cond + ((eq type 'expr) (symbol!-set!-definition a b)) + ((eq type 'subr) (symbol!-set!-definition a b)) + ((and (eq type 'macro) (eqcar b 'lambda)) + (eval (list!* 'dm a (cdr b)))) +% CSL does not really support user-defined special forms and so at some +% stage I will make "df" a macro that makes some attempt to simulate the +% desired behaviour using a macro. + ((and (eq type 'fexpr) (eqcar b 'lambda)) + (eval (list!* 'df a (cdr b)))) + (t (error "Bad type ~S in putd" type))) + a)))))) + +% A version of this in rlisp/rsupport.red tries to compile the +% odd sort of definition involved, but I will not! +(de putc (a b c) + (put a b c)) + +(de traceset1 (name) + (prog (w !*comp) + (setq w (getd name)) + (cond ((not (and (eqcar w 'expr) (eqcar (cdr w) 'lambda))) + (princ "+++++ ") (prin name) + (printc " should be interpreted for traceset to work") + (return nil))) + (putd name 'expr (subst 'noisy!-setq 'setq (cdr w))) + (trace (list name)))) + +(de untraceset1 (name) + (prog (w !*comp) + (setq w (getd name)) + (cond ((not (and (eqcar w 'expr) (eqcar (cdr w) 'lambda))) + (princ "+++++ ") (prin name) + (printc " should be interpreted for untraceset to work") + (return nil))) + (putd name 'expr (subst 'setq 'noisy!-setq (cdr w))) + (untrace (list name)))) + +(de traceset (l) + (mapc l (function traceset1))) + +(de untraceset (l) + (mapc l (function untraceset1))) + +(de deflist (a b) + (prog (r) +top (cond ((null a) (return (reversip r)))) + (put (caar a) b (cadar a)) + (setq r (cons (caar a) r)) + (setq a (cdr a)) + (go top))) + +(de global (l) + (prog nil + top (cond ((null l) (return nil))) + (make!-global (car l)) + (cond ((not (boundp (car l))) (set (car l) nil))) + (setq l (cdr l)) + (go top))) + +(de fluid (l) + (prog nil + top (cond ((null l) (return nil))) + (make!-special (car l)) + (cond ((not (boundp (car l))) (set (car l) nil))) + (setq l (cdr l)) + (go top))) + +(de unglobal (l) + (prog () + top (cond ((null l) (return nil))) + (unmake!-global (car l)) + (setq l (cdr l)) + (go top))) + +(de unfluid (l) + (prog () + top (cond ((null l) (return nil))) + (unmake!-special (car l)) + (setq l (cdr l)) + (go top))) + +(global '(ofl!*)) + +(de printprompt (u) nil) + +(global '(program!* ttype!* eof!*)) + +(global '(crbuf!*)) + +(global '(blank !$eol!$ tab !$eof!$ esc!*)) + +(fluid '(!*notailcall !*carcheckflag)) + +(fluid '(!*terminal!-io!* !*standard!-input!* !*standard!-output!* + !*error!-output!* !*trace!-output!* !*debug!-io!* !*query!-io!*)) + +(setq !*notailcall nil) +(setq !*carcheckflag t) + +(de carcheck (n) + (prog (old) + (cond ((zerop n) (setq n nil))) + (setq old !*carcheckflag) + (setq !*carcheckflag n) + (return old))) + +(progn +% The "special-char" numeric codes here are all very odd and are of no +% relevance beyond the initial build stages of this Lisp. In particular they +% have little or no resemblance to any widely used character code schemes. + (setq blank (compress (list '!! (special!-char 0)))) + (setq !$eol!$ (compress (list '!! (special!-char 1)))) + (setq tab (compress (list '!! (special!-char 3)))) + (setq esc!* (compress (list '!! (special!-char 9)))) + (setq !$eof!$ (special!-char 8)) + nil) + +(setq crbuf!* (list !$eol!$)) % may not be necessary + +% Since this should never get called I will just not define it here! + +%(de symerr (u v) +% (progn (terpri) +% (print (list 'symerr u v)) +% (error 'failure))) + +(global '(!*full!-oblist)) + +(setq !*full!-oblist nil) + +(de s!:oblist (v r) + (prog (n a) + (setq n (upbv v)) +top (cond ((minusp n) (return r))) + (setq a (getv v n)) + (cond + ((and (idp a) +% I list things that have a function value of some sort or that have +% a non-empty property-list. Symbols that have been mentioned but which do +% not have properties or values are missed out since they are dull and +% seeing them listed is probably not very helpful. People may disagree +% about that... if so it would be very easy to remove the tests here and +% end up listing everything. Eg some symbols exist and are used as property- +% names (via PUT and GET) but are not used for anything else... +% +% Well, the flag !*full!-oblist can be set to force inclusion of +% everything! + (or !*full!-oblist + (symbol!-function a) + (macro!-function a) + (special!-form!-p a) + (fluidp a) + (globalp a) + (not (null (plist a))))) + (setq r (cons a r)))) + (setq n (sub1 n)) + (go top))) + +(de s!:oblist1 (v r) + (cond + ((null v) r) + ((vectorp v) (s!:oblist v r)) +% This allows for segmented object-vectors + (t (s!:oblist (car v) (s!:oblist1 (cdr v) r))))) + +(de oblist () + (sort (s!:oblist1 (getv !*package!* 1) nil) + (function orderp))) + + +% Now a few things not needed by Standard Lisp but maybe helpful +% when using Lisp directly. + +(de s!:make!-psetq!-vars (u) + (if (null u) + nil + (if (null (cdr u)) + (error "odd number of items in psetq") + (cons (gensym) (s!:make!-psetq!-vars (cddr u)))))) + +(de s!:make!-psetq!-bindings (vars u) + (if (null u) + nil + (cons + (list (car vars) (cadr u)) + (s!:make!-psetq!-bindings (cdr vars) (cddr u))))) + +(de s!:make!-psetq!-assignments (vars u) + (if (null u) + nil + (cons + (list 'setq (car u) (car vars)) + (s!:make!-psetq!-assignments (cdr vars) (cddr u))))) + +(dm psetq (x) + (!~let ((vars (s!:make!-psetq!-vars (cdr x)))) + `(let!* ,(s!:make!-psetq!-bindings vars (cdr x)) + ,@(s!:make!-psetq!-assignments vars (cdr x))))) + +% (do ((v i s) ..) +% (end result ...) +% body) + +(de s!:do!-bindings (u) + (if (null u) + nil + (if (atom (car u)) + (cons (car u) (s!:do!-bindings (cdr u))) + (if (null (cdar u)) + (cons (list (caar u) nil) (s!:do!-bindings (cdr u))) + (cons (list (caar u) (cadar u)) (s!:do!-bindings (cdr u))))))) + +(de s!:do!-endtest (u) + (if (null u) + nil + (car u))) + +(de s!:do!-result (u) + (if (null u) + nil + (cdr u))) + +(de s!:do!-updates (u) + (if (null u) + nil + (!~let ((v (car u)) + (x (s!:do!-updates (cdr u)))) + (if (or (atom v) + (null (cdr v)) + (null (cddr v))) + x + (cons (car v) (cons (caddr v) x)))))) + + +(de s!:expand!-do (u letter setter) + (let!* ((bindings (s!:do!-bindings (car u))) + (result (s!:do!-result (cadr u))) + (updates (s!:do!-updates (car u))) + (body (cddr u)) + (endtest (s!:do!-endtest (cadr u))) + (upd (if updates (list (cons setter updates)) nil)) + (res (if (null result) + nil + (if (null (cdr result)) + (car result) + (cons 'progn result)))) + (x (if (null endtest) nil + `((if ,endtest (return ,res))))) + (g (gensym))) + (if bindings + `(,letter ,bindings + (prog nil + ,g ,@x + ,@body + ,@upd + (go ,g))) + `(prog nil + ,g ,@x + ,@body + ,@upd + (go ,g))))) + +(dm do (u) (s!:expand!-do (cdr u) '!~let 'psetq)) + +(dm do!* (u) (s!:expand!-do (cdr u) 'let!* 'setq)) + +(de s!:expand!-dolist (vir b) + (prog (l v var init res) + (setq var (car vir)) + (setq init (car (setq vir (cdr vir)))) + (setq res (cdr vir)) + (setq v (gensym)) + (setq l (gensym)) + (return `(prog (,v ,var) + (setq ,v ,init) + ,l (cond ((null ,v) (return (progn ,@res)))) + (setq ,var (car ,v)) + ,@b + (setq ,v (cdr ,v)) + (go ,l))))) + +(dm dolist (u) (s!:expand!-dolist (cadr u) (cddr u))) + +(de s!:expand!-dotimes (vnr b) + (prog (l v var count res) + (setq var (car vnr)) + (setq count (car (setq vnr (cdr vnr)))) + (setq res (cdr vnr)) + (setq v (gensym)) + (setq l (gensym)) + (return `(prog (,v ,var) + (setq ,v ,count) + (setq ,var 0) + ,l (cond ((not (lessp ,var ,v)) (return (progn ,@res)))) + ,@b + (setq ,var (add1 ,var)) + (go ,l))))) + +(dm dotimes (u) (s!:expand!-dotimes (cadr u) (cddr u))) + +(flag '(geq leq neq logand logor logxor leftshift princ printc + evenp reversip seprp atsoc eqcar flagp!*!* flagpcar get!* + prin1 prin2 apply0 apply1 apply2 apply3 smemq spaces + subla gcdn lcmn printprompt pair putc) 'lose) + +% end of compat.lsp + diff -Nru mathpiper-0.81f+svn4469+dfsg2/lib/build_scripts/compiler.lsp mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/compiler.lsp --- mathpiper-0.81f+svn4469+dfsg2/lib/build_scripts/compiler.lsp 1970-01-01 00:00:00.000000000 +0000 +++ mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/compiler.lsp 2011-04-09 07:08:25.000000000 +0000 @@ -0,0 +1,4993 @@ + +% RLISP to LISP converter. A C Norman 2004 + + +%% +%% Copyright (C) 2010, following the master REDUCE source files. * +%% * +%% Redistribution and use in source and binary forms, with or without * +%% modification, are permitted provided that the following conditions are * +%% met: * +%% * +%% * Redistributions of source code must retain the relevant * +%% copyright notice, this list of conditions and the following * +%% disclaimer. * +%% * Redistributions in binary form must reproduce the above * +%% copyright notice, this list of conditions and the following * +%% disclaimer in the documentation and/or other materials provided * +%% with the distribution. * +%% * +%% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * +%% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * +%% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS * +%% FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE * +%% COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, * +%% INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, * +%% BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS * +%% OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * +%% ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR * +%% TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF * +%% THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH * +%% DAMAGE. * +%% + + +(global (quote (s!:opcodelist))) + + + +(setq s!:opcodelist (quote (LOADLOC LOADLOC0 LOADLOC1 LOADLOC2 LOADLOC3 +LOADLOC4 LOADLOC5 LOADLOC6 LOADLOC7 LOADLOC8 LOADLOC9 LOADLOC10 LOADLOC11 +LOC0LOC1 LOC1LOC2 LOC2LOC3 LOC1LOC0 LOC2LOC1 LOC3LOC2 VNIL LOADLIT LOADLIT1 +LOADLIT2 LOADLIT3 LOADLIT4 LOADLIT5 LOADLIT6 LOADLIT7 LOADFREE LOADFREE1 +LOADFREE2 LOADFREE3 LOADFREE4 STORELOC STORELOC0 STORELOC1 STORELOC2 +STORELOC3 STORELOC4 STORELOC5 STORELOC6 STORELOC7 STOREFREE STOREFREE1 +STOREFREE2 STOREFREE3 LOADLEX STORELEX CLOSURE CARLOC0 CARLOC1 CARLOC2 +CARLOC3 CARLOC4 CARLOC5 CARLOC6 CARLOC7 CARLOC8 CARLOC9 CARLOC10 CARLOC11 +CDRLOC0 CDRLOC1 CDRLOC2 CDRLOC3 CDRLOC4 CDRLOC5 CAARLOC0 CAARLOC1 CAARLOC2 +CAARLOC3 CALL0 CALL1 CALL2 CALL2R CALL3 CALLN CALL0_0 CALL0_1 CALL0_2 CALL0_3 +CALL1_0 CALL1_1 CALL1_2 CALL1_3 CALL1_4 CALL1_5 CALL2_0 CALL2_1 CALL2_2 +CALL2_3 CALL2_4 BUILTIN0 BUILTIN1 BUILTIN2 BUILTIN2R BUILTIN3 APPLY1 APPLY2 +APPLY3 APPLY4 JCALL JCALLN JUMP JUMP_B JUMP_L JUMP_BL JUMPNIL JUMPNIL_B +JUMPNIL_L JUMPNIL_BL JUMPT JUMPT_B JUMPT_L JUMPT_BL JUMPATOM JUMPATOM_B +JUMPATOM_L JUMPATOM_BL JUMPNATOM JUMPNATOM_B JUMPNATOM_L JUMPNATOM_BL JUMPEQ +JUMPEQ_B JUMPEQ_L JUMPEQ_BL JUMPNE JUMPNE_B JUMPNE_L JUMPNE_BL JUMPEQUAL +JUMPEQUAL_B JUMPEQUAL_L JUMPEQUAL_BL JUMPNEQUAL JUMPNEQUAL_B JUMPNEQUAL_L +JUMPNEQUAL_BL JUMPL0NIL JUMPL0T JUMPL1NIL JUMPL1T JUMPL2NIL JUMPL2T JUMPL3NIL +JUMPL3T JUMPL4NIL JUMPL4T JUMPST0NIL JUMPST0T JUMPST1NIL JUMPST1T JUMPST2NIL +JUMPST2T JUMPL0ATOM JUMPL0NATOM JUMPL1ATOM JUMPL1NATOM JUMPL2ATOM +JUMPL2NATOM JUMPL3ATOM JUMPL3NATOM JUMPFREE1NIL JUMPFREE1T JUMPFREE2NIL +JUMPFREE2T JUMPFREE3NIL JUMPFREE3T JUMPFREE4NIL JUMPFREE4T JUMPFREENIL +JUMPFREET JUMPLIT1EQ JUMPLIT1NE JUMPLIT2EQ JUMPLIT2NE JUMPLIT3EQ JUMPLIT3NE +JUMPLIT4EQ JUMPLIT4NE JUMPLITEQ JUMPLITNE JUMPB1NIL JUMPB1T JUMPB2NIL JUMPB2T +JUMPFLAGP JUMPNFLAGP JUMPEQCAR JUMPNEQCAR CATCH CATCH_B CATCH_L CATCH_BL +UNCATCH THROW PROTECT UNPROTECT PVBIND PVRESTORE FREEBIND FREERSTR EXIT +NILEXIT LOC0EXIT LOC1EXIT LOC2EXIT PUSH PUSHNIL PUSHNIL2 PUSHNIL3 PUSHNILS +POP LOSE LOSE2 LOSE3 LOSES SWOP EQ EQCAR EQUAL NUMBERP CAR CDR CAAR CADR CDAR +CDDR CONS NCONS XCONS ACONS LENGTH LIST2 LIST2STAR LIST3 PLUS2 ADD1 +DIFFERENCE SUB1 TIMES2 GREATERP LESSP FLAGP GET LITGET GETV QGETV QGETVN +BIGSTACK BIGCALL ICASE FASTGET SPARE1 SPARE2))) + +(prog (n) (setq n 0) (prog (var1001) (setq var1001 s!:opcodelist) lab1000 ( +cond ((null var1001) (return nil))) (prog (v) (setq v (car var1001)) (progn ( +put v (quote s!:opcode) n) (setq n (plus n 1)))) (setq var1001 (cdr var1001)) +(go lab1000)) (return (list n (quote opcodes) (quote allocated)))) + +(setq s!:opcodelist nil) + +(fluid (quote (s!:env_alist))) + +(de s!:vecof (l) (prog (w) (setq w (assoc l s!:env_alist)) (cond (w (return ( +cdr w)))) (setq w (s!:vecof1 l)) (setq s!:env_alist (cons (cons l w) +s!:env_alist)) (return w))) + +(de s!:vecof1 (l) (prog (v n) (setq v (mkvect (sub1 (length l)))) (setq n 0) +(prog (var1003) (setq var1003 l) lab1002 (cond ((null var1003) (return nil))) +(prog (x) (setq x (car var1003)) (progn (putv v n x) (setq n (plus n 1)))) ( +setq var1003 (cdr var1003)) (go lab1002)) (return v))) + +(progn (put (quote batchp) (quote s!:builtin0) 0) (put (quote date) (quote +s!:builtin0) 1) (put (quote eject) (quote s!:builtin0) 2) (put (quote error1) +(quote s!:builtin0) 3) (put (quote gctime) (quote s!:builtin0) 4) (put ( +quote lposn) (quote s!:builtin0) 6) (put (quote posn) (quote s!:builtin0) 8) +(put (quote read) (quote s!:builtin0) 9) (put (quote readch) (quote +s!:builtin0) 10) (put (quote terpri) (quote s!:builtin0) 11) (put (quote time +) (quote s!:builtin0) 12) (put (quote tyi) (quote s!:builtin0) 13) (put ( +quote load!-spid) (quote s!:builtin0) 14) (put (quote abs) (quote s!:builtin1 +) 0) (put (quote add1) (quote s!:builtin1) 1) (put (quote atan) (quote +s!:builtin1) 2) (put (quote apply0) (quote s!:builtin1) 3) (put (quote atom) +(quote s!:builtin1) 4) (put (quote boundp) (quote s!:builtin1) 5) (put (quote +char!-code) (quote s!:builtin1) 6) (put (quote close) (quote s!:builtin1) 7) +(put (quote codep) (quote s!:builtin1) 8) (put (quote compress) (quote +s!:builtin1) 9) (put (quote constantp) (quote s!:builtin1) 10) (put (quote +digit) (quote s!:builtin1) 11) (put (quote endp) (quote s!:builtin1) 12) (put +(quote eval) (quote s!:builtin1) 13) (put (quote evenp) (quote s!:builtin1) +14) (put (quote evlis) (quote s!:builtin1) 15) (put (quote explode) (quote +s!:builtin1) 16) (put (quote explode2lc) (quote s!:builtin1) 17) (put (quote +explode2) (quote s!:builtin1) 18) (put (quote explodec) (quote s!:builtin1) +18) (put (quote fixp) (quote s!:builtin1) 19) (put (quote float) (quote +s!:builtin1) 20) (put (quote floatp) (quote s!:builtin1) 21) (put (quote +symbol!-specialp) (quote s!:builtin1) 22) (put (quote gc) (quote s!:builtin1) +23) (put (quote gensym1) (quote s!:builtin1) 24) (put (quote getenv) (quote +s!:builtin1) 25) (put (quote symbol!-globalp) (quote s!:builtin1) 26) (put ( +quote iadd1) (quote s!:builtin1) 27) (put (quote symbolp) (quote s!:builtin1) +28) (put (quote iminus) (quote s!:builtin1) 29) (put (quote iminusp) (quote +s!:builtin1) 30) (put (quote indirect) (quote s!:builtin1) 31) (put (quote +integerp) (quote s!:builtin1) 32) (put (quote intern) (quote s!:builtin1) 33) +(put (quote isub1) (quote s!:builtin1) 34) (put (quote length) (quote +s!:builtin1) 35) (put (quote lengthc) (quote s!:builtin1) 36) (put (quote +linelength) (quote s!:builtin1) 37) (put (quote liter) (quote s!:builtin1) 38 +) (put (quote load!-module) (quote s!:builtin1) 39) (put (quote lognot) ( +quote s!:builtin1) 40) (put (quote macroexpand) (quote s!:builtin1) 41) (put +(quote macroexpand!-1) (quote s!:builtin1) 42) (put (quote macro!-function) ( +quote s!:builtin1) 43) (put (quote make!-bps) (quote s!:builtin1) 44) (put ( +quote make!-global) (quote s!:builtin1) 45) (put (quote make!-simple!-string) +(quote s!:builtin1) 46) (put (quote make!-special) (quote s!:builtin1) 47) ( +put (quote minus) (quote s!:builtin1) 48) (put (quote minusp) (quote +s!:builtin1) 49) (put (quote mkvect) (quote s!:builtin1) 50) (put (quote +modular!-minus) (quote s!:builtin1) 51) (put (quote modular!-number) (quote +s!:builtin1) 52) (put (quote modular!-reciprocal) (quote s!:builtin1) 53) ( +put (quote null) (quote s!:builtin1) 54) (put (quote oddp) (quote s!:builtin1 +) 55) (put (quote onep) (quote s!:builtin1) 56) (put (quote pagelength) ( +quote s!:builtin1) 57) (put (quote pairp) (quote s!:builtin1) 58) (put (quote +plist) (quote s!:builtin1) 59) (put (quote plusp) (quote s!:builtin1) 60) ( +put (quote prin) (quote s!:builtin1) 61) (put (quote princ) (quote +s!:builtin1) 62) (put (quote print) (quote s!:builtin1) 63) (put (quote +printc) (quote s!:builtin1) 64) (put (quote rds) (quote s!:builtin1) 68) (put +(quote remd) (quote s!:builtin1) 69) (put (quote reverse) (quote s!:builtin1 +) 70) (put (quote reversip) (quote s!:builtin1) 71) (put (quote seprp) (quote +s!:builtin1) 72) (put (quote set!-small!-modulus) (quote s!:builtin1) 73) ( +put (quote spaces) (quote s!:builtin1) 74) (put (quote xtab) (quote +s!:builtin1) 74) (put (quote special!-char) (quote s!:builtin1) 75) (put ( +quote special!-form!-p) (quote s!:builtin1) 76) (put (quote spool) (quote +s!:builtin1) 77) (put (quote stop) (quote s!:builtin1) 78) (put (quote +stringp) (quote s!:builtin1) 79) (put (quote sub1) (quote s!:builtin1) 80) ( +put (quote symbol!-env) (quote s!:builtin1) 81) (put (quote symbol!-function) +(quote s!:builtin1) 82) (put (quote symbol!-name) (quote s!:builtin1) 83) ( +put (quote symbol!-value) (quote s!:builtin1) 84) (put (quote system) (quote +s!:builtin1) 85) (put (quote fix) (quote s!:builtin1) 86) (put (quote ttab) ( +quote s!:builtin1) 87) (put (quote tyo) (quote s!:builtin1) 88) (put (quote +remob) (quote s!:builtin1) 89) (put (quote unmake!-global) (quote s!:builtin1 +) 90) (put (quote unmake!-special) (quote s!:builtin1) 91) (put (quote upbv) +(quote s!:builtin1) 92) (put (quote vectorp) (quote s!:builtin1) 93) (put ( +quote verbos) (quote s!:builtin1) 94) (put (quote wrs) (quote s!:builtin1) 95 +) (put (quote zerop) (quote s!:builtin1) 96) (put (quote car) (quote +s!:builtin1) 97) (put (quote cdr) (quote s!:builtin1) 98) (put (quote caar) ( +quote s!:builtin1) 99) (put (quote cadr) (quote s!:builtin1) 100) (put (quote +cdar) (quote s!:builtin1) 101) (put (quote cddr) (quote s!:builtin1) 102) ( +put (quote qcar) (quote s!:builtin1) 103) (put (quote qcdr) (quote +s!:builtin1) 104) (put (quote qcaar) (quote s!:builtin1) 105) (put (quote +qcadr) (quote s!:builtin1) 106) (put (quote qcdar) (quote s!:builtin1) 107) ( +put (quote qcddr) (quote s!:builtin1) 108) (put (quote ncons) (quote +s!:builtin1) 109) (put (quote numberp) (quote s!:builtin1) 110) (put (quote +is!-spid) (quote s!:builtin1) 111) (put (quote spid!-to!-nil) (quote +s!:builtin1) 112) (put (quote append) (quote s!:builtin2) 0) (put (quote ash) +(quote s!:builtin2) 1) (put (quote assoc) (quote s!:builtin2) 2) (put (quote +assoc!*!*) (quote s!:builtin2) 2) (put (quote atsoc) (quote s!:builtin2) 3) +(put (quote deleq) (quote s!:builtin2) 4) (put (quote delete) (quote +s!:builtin2) 5) (put (quote divide) (quote s!:builtin2) 6) (put (quote eqcar) +(quote s!:builtin2) 7) (put (quote eql) (quote s!:builtin2) 8) (put (quote +eqn) (quote s!:builtin2) 9) (put (quote expt) (quote s!:builtin2) 10) (put ( +quote flag) (quote s!:builtin2) 11) (put (quote flagpcar) (quote s!:builtin2) +12) (put (quote gcdn) (quote s!:builtin2) 13) (put (quote geq) (quote +s!:builtin2) 14) (put (quote getv) (quote s!:builtin2) 15) (put (quote +greaterp) (quote s!:builtin2) 16) (put (quote idifference) (quote s!:builtin2 +) 17) (put (quote igreaterp) (quote s!:builtin2) 18) (put (quote ilessp) ( +quote s!:builtin2) 19) (put (quote imax) (quote s!:builtin2) 20) (put (quote +imin) (quote s!:builtin2) 21) (put (quote iplus2) (quote s!:builtin2) 22) ( +put (quote iquotient) (quote s!:builtin2) 23) (put (quote iremainder) (quote +s!:builtin2) 24) (put (quote irightshift) (quote s!:builtin2) 25) (put (quote +itimes2) (quote s!:builtin2) 26) (put (quote leq) (quote s!:builtin2) 28) ( +put (quote lessp) (quote s!:builtin2) 29) (put (quote max2) (quote +s!:builtin2) 31) (put (quote member) (quote s!:builtin2) 32) (put (quote +member!*!*) (quote s!:builtin2) 32) (put (quote memq) (quote s!:builtin2) 33) +(put (quote min2) (quote s!:builtin2) 34) (put (quote mod) (quote +s!:builtin2) 35) (put (quote modular!-difference) (quote s!:builtin2) 36) ( +put (quote modular!-expt) (quote s!:builtin2) 37) (put (quote modular!-plus) +(quote s!:builtin2) 38) (put (quote modular!-quotient) (quote s!:builtin2) 39 +) (put (quote modular!-times) (quote s!:builtin2) 40) (put (quote nconc) ( +quote s!:builtin2) 41) (put (quote neq) (quote s!:builtin2) 42) (put (quote +orderp) (quote s!:builtin2) 43) (put (quote quotient) (quote s!:builtin2) 44) +(put (quote remainder) (quote s!:builtin2) 45) (put (quote remflag) (quote +s!:builtin2) 46) (put (quote remprop) (quote s!:builtin2) 47) (put (quote +rplaca) (quote s!:builtin2) 48) (put (quote rplacd) (quote s!:builtin2) 49) ( +put (quote schar) (quote s!:builtin2) 50) (put (quote set) (quote s!:builtin2 +) 51) (put (quote smemq) (quote s!:builtin2) 52) (put (quote subla) (quote +s!:builtin2) 53) (put (quote sublis) (quote s!:builtin2) 54) (put (quote +symbol!-set!-definition) (quote s!:builtin2) 55) (put (quote symbol!-set!-env +) (quote s!:builtin2) 56) (put (quote times2) (quote s!:builtin2) 57) (put ( +quote xcons) (quote s!:builtin2) 58) (put (quote equal) (quote s!:builtin2) +59) (put (quote eq) (quote s!:builtin2) 60) (put (quote cons) (quote +s!:builtin2) 61) (put (quote list2) (quote s!:builtin2) 62) (put (quote get) +(quote s!:builtin2) 63) (put (quote qgetv) (quote s!:builtin2) 64) (put ( +quote flagp) (quote s!:builtin2) 65) (put (quote apply1) (quote s!:builtin2) +66) (put (quote difference) (quote s!:builtin2) 67) (put (quote plus2) (quote +s!:builtin2) 68) (put (quote times2) (quote s!:builtin2) 69) (put (quote +equalcar) (quote s!:builtin2) 70) (put (quote iequal) (quote s!:builtin2) 71) +(put (quote nreverse) (quote s!:builtin2) 72) (put (quote bps!-putv) (quote +s!:builtin3) 0) (put (quote errorset) (quote s!:builtin3) 1) (put (quote +list2!*) (quote s!:builtin3) 2) (put (quote list3) (quote s!:builtin3) 3) ( +put (quote putprop) (quote s!:builtin3) 4) (put (quote putv) (quote +s!:builtin3) 5) (put (quote putv!-char) (quote s!:builtin3) 6) (put (quote +subst) (quote s!:builtin3) 7) (put (quote apply2) (quote s!:builtin3) 8) (put +(quote acons) (quote s!:builtin3) 9) nil) + +(de s!:prinhex1 (n) (princ (schar "0123456789abcdef" (logand n 15)))) + +(de s!:prinhex2 (n) (progn (s!:prinhex1 (truncate n 16)) (s!:prinhex1 n))) + +(de s!:prinhex4 (n) (progn (s!:prinhex2 (truncate n 256)) (s!:prinhex2 n))) + +(flag (quote (comp plap pgwd pwrds notailcall ord nocompile carcheckflag +savedef carefuleq r2i native_code save_native strip_native)) (quote switch)) + +(cond ((not (boundp (quote !*comp))) (progn (fluid (quote (!*comp))) (setq +!*comp t)))) + +(cond ((not (boundp (quote !*nocompile))) (progn (fluid (quote (!*nocompile)) +) (setq !*nocompile nil)))) + +(cond ((not (boundp (quote !*plap))) (progn (fluid (quote (!*plap))) (setq +!*plap nil)))) + +(cond ((not (boundp (quote !*pgwd))) (progn (fluid (quote (!*pgwd))) (setq +!*pgwd nil)))) + +(cond ((not (boundp (quote !*pwrds))) (progn (fluid (quote (!*pwrds))) (setq +!*pwrds t)))) + +(cond ((not (boundp (quote !*notailcall))) (progn (fluid (quote (!*notailcall +))) (setq !*notailcall nil)))) + +(cond ((not (boundp (quote !*ord))) (progn (fluid (quote (!*ord))) (setq +!*ord nil)))) + +(cond ((not (boundp (quote !*savedef))) (progn (fluid (quote (!*savedef))) ( +setq !*savedef nil)))) + +(cond ((not (boundp (quote !*carcheckflag))) (progn (fluid (quote ( +!*carcheckflag))) (setq !*carcheckflag t)))) + +(cond ((not (boundp (quote !*carefuleq))) (progn (fluid (quote (!*carefuleq)) +) (setq !*carefuleq (or (and (boundp (quote lispsystem!*)) (not (null (member +(quote jlisp) lispsystem!*)))) (and (boundp (quote !*features!*)) (not (null +(member (quote !:jlisp) !*features!*))))))))) + +(cond ((not (boundp (quote !*r2i))) (progn (fluid (quote (!*r2i))) (setq +!*r2i t)))) + +(cond ((not (boundp (quote !*native_code))) (progn (fluid (quote ( +!*native_code))) (setq !*native_code nil)))) + +(cond ((not (boundp (quote !*save_native))) (progn (fluid (quote ( +!*save_native))) (setq !*save_native nil)))) + +(cond ((not (boundp (quote !*strip_native))) (progn (fluid (quote ( +!*strip_native))) (setq !*strip_native t)))) + +(global (quote (s!:native_file))) + +(fluid (quote (s!:current_function s!:current_label s!:current_block +s!:current_size s!:current_procedure s!:other_defs s!:lexical_env +s!:has_closure s!:recent_literals s!:used_lexicals s!:a_reg_values +s!:current_count))) + +(de s!:start_procedure (nargs nopts restarg) (progn (setq +s!:current_procedure nil) (setq s!:current_label (gensym)) (setq +s!:a_reg_values nil) (cond ((or (not (zerop nopts)) restarg) (progn (setq +s!:current_block (list (list (quote OPTARGS) nopts) nopts (list (quote +ARGCOUNT) nargs) nargs)) (setq s!:current_size 2))) (t (cond ((greaterp nargs +3) (progn (setq s!:current_block (list (list (quote ARGCOUNT) nargs) nargs)) +(setq s!:current_size 1))) (t (progn (setq s!:current_block nil) (setq +s!:current_size 0)))))))) + +(de s!:set_label (x) (progn (cond (s!:current_label (prog (w) (setq w (cons +s!:current_size s!:current_block)) (prog (var1005) (setq var1005 +s!:recent_literals) lab1004 (cond ((null var1005) (return nil))) (prog (x) ( +setq x (car var1005)) (rplaca x w)) (setq var1005 (cdr var1005)) (go lab1004) +) (setq s!:recent_literals nil) (setq s!:current_procedure (cons (cons +s!:current_label (cons (list (quote JUMP) x) w)) s!:current_procedure)) (setq +s!:current_block nil) (setq s!:current_size 0)))) (setq s!:current_label x) +(setq s!:a_reg_values nil))) + +(de s!:outjump (op lab) (prog (g w) (cond ((not (flagp op (quote +s!:preserves_a))) (setq s!:a_reg_values nil))) (cond ((null s!:current_label) +(return nil))) (cond ((equal op (quote JUMP)) (setq op (list op lab))) (t ( +cond ((equal op (quote ICASE)) (setq op (cons op lab))) (t (setq op (list op +lab (setq g (gensym)))))))) (setq w (cons s!:current_size s!:current_block)) +(prog (var1007) (setq var1007 s!:recent_literals) lab1006 (cond ((null +var1007) (return nil))) (prog (x) (setq x (car var1007)) (rplaca x w)) (setq +var1007 (cdr var1007)) (go lab1006)) (setq s!:recent_literals nil) (setq +s!:current_procedure (cons (cons s!:current_label (cons op w)) +s!:current_procedure)) (setq s!:current_block nil) (setq s!:current_size 0) ( +setq s!:current_label g) (return op))) + +(de s!:outexit nil (prog (w op) (setq op (quote (EXIT))) (cond ((null +s!:current_label) (return nil))) (setq w (cons s!:current_size +s!:current_block)) (prog (var1009) (setq var1009 s!:recent_literals) lab1008 +(cond ((null var1009) (return nil))) (prog (x) (setq x (car var1009)) (rplaca +x w)) (setq var1009 (cdr var1009)) (go lab1008)) (setq s!:recent_literals +nil) (setq s!:current_procedure (cons (cons s!:current_label (cons op w)) +s!:current_procedure)) (setq s!:current_block nil) (setq s!:current_size 0) ( +setq s!:current_label nil))) + +(flag (quote (PUSH PUSHNIL PUSHNIL2 PUSHNIL3 LOSE LOSE2 LOSE3 LOSES STORELOC +STORELOC0 STORELOC1 STORELOC2 STORELOC3 STORELOC4 STORELOC5 STORELOC6 +STORELOC7 JUMP JUMPT JUMPNIL JUMPEQ JUMPEQUAL JUMPNE JUMPNEQUAL JUMPATOM +JUMPNATOM)) (quote s!:preserves_a)) + +(de s!:outopcode0 (op doc) (prog nil (cond ((not (flagp op (quote +s!:preserves_a))) (setq s!:a_reg_values nil))) (cond ((null s!:current_label) +(return nil))) (setq s!:current_block (cons op s!:current_block)) (setq +s!:current_size (plus s!:current_size 1)) (cond ((or !*plap !*pgwd) (setq +s!:current_block (cons doc s!:current_block)))))) + +(de s!:outopcode1 (op arg doc) (prog nil (cond ((not (flagp op (quote +s!:preserves_a))) (setq s!:a_reg_values nil))) (cond ((null s!:current_label) +(return nil))) (setq s!:current_block (cons arg (cons op s!:current_block))) +(setq s!:current_size (plus s!:current_size 2)) (cond ((or !*plap !*pgwd) ( +setq s!:current_block (cons (list op doc) s!:current_block)))))) + +(deflist (quote ((LOADLIT 1) (LOADFREE 2) (CALL0 2) (CALL1 2) (LITGET 2) ( +JUMPLITEQ 2) (JUMPLITNE 2) (JUMPLITEQ!* 2) (JUMPLITNE!* 2) (JUMPFREET 2) ( +JUMPFREENIL 2))) (quote s!:short_form_bonus)) + +(de s!:record_literal (env) (prog (w extra) (setq w (gethash (car +s!:current_block) (car env))) (cond ((null w) (setq w (cons 0 nil)))) (setq +extra (get (cadr s!:current_block) (quote s!:short_form_bonus))) (cond ((null +extra) (setq extra 10)) (t (setq extra (plus extra 10)))) (setq +s!:recent_literals (cons (cons nil s!:current_block) s!:recent_literals)) ( +puthash (car s!:current_block) (car env) (cons (plus (car w) extra) (cons ( +car s!:recent_literals) (cdr w)))))) + +(de s!:record_literal_for_jump (x env lab) (prog (w extra) (cond ((null +s!:current_label) (return nil))) (setq w (gethash (cadr x) (car env))) (cond +((null w) (setq w (cons 0 nil)))) (setq extra (get (car x) (quote +s!:short_form_bonus))) (cond ((null extra) (setq extra 10)) (t (setq extra ( +plus extra 10)))) (setq x (s!:outjump x lab)) (puthash (cadar x) (car env) ( +cons (plus (car w) extra) (cons (cons nil x) (cdr w)))))) + +(de s!:outopcode1lit (op arg env) (prog nil (cond ((not (flagp op (quote +s!:preserves_a))) (setq s!:a_reg_values nil))) (cond ((null s!:current_label) +(return nil))) (setq s!:current_block (cons arg (cons op s!:current_block))) +(s!:record_literal env) (setq s!:current_size (plus s!:current_size 2)) ( +cond ((or !*plap !*pgwd) (setq s!:current_block (cons (list op arg) +s!:current_block)))))) + +(de s!:outopcode2 (op arg1 arg2 doc) (prog nil (cond ((not (flagp op (quote +s!:preserves_a))) (setq s!:a_reg_values nil))) (cond ((null s!:current_label) +(return nil))) (setq s!:current_block (cons arg2 (cons arg1 (cons op +s!:current_block)))) (setq s!:current_size (plus s!:current_size 3)) (cond (( +or !*plap !*pgwd) (setq s!:current_block (cons (cons op doc) s!:current_block +)))))) + +(de s!:outopcode2lit (op arg1 arg2 doc env) (prog nil (cond ((not (flagp op ( +quote s!:preserves_a))) (setq s!:a_reg_values nil))) (cond ((null +s!:current_label) (return nil))) (setq s!:current_block (cons arg1 (cons op +s!:current_block))) (s!:record_literal env) (setq s!:current_block (cons arg2 +s!:current_block)) (setq s!:current_size (plus s!:current_size 3)) (cond (( +or !*plap !*pgwd) (setq s!:current_block (cons (cons op doc) s!:current_block +)))))) + +(de s!:outlexref (op arg1 arg2 arg3 doc) (prog (arg4) (cond ((null +s!:current_label) (return nil))) (cond ((or (greaterp arg1 255) (greaterp +arg2 255) (greaterp arg3 255)) (progn (cond ((or (greaterp arg1 2047) ( +greaterp arg2 31) (greaterp arg3 2047)) (error 0 +"stack frame > 2047 or > 31 deep nesting"))) (setq doc (list op doc)) (setq +arg4 (logand arg3 255)) (setq arg3 (plus (truncate arg3 256) (times 16 ( +logand arg1 15)))) (cond ((equal op (quote LOADLEX)) (setq op (plus 192 arg2) +)) (t (setq op (plus 224 arg2)))) (setq arg2 (truncate arg1 16)) (setq arg1 +op) (setq op (quote BIGSTACK)))) (t (setq doc (list doc)))) (setq +s!:current_block (cons arg3 (cons arg2 (cons arg1 (cons op s!:current_block)) +))) (setq s!:current_size (plus s!:current_size 4)) (cond (arg4 (progn (setq +s!:current_block (cons arg4 s!:current_block)) (setq s!:current_size (plus +s!:current_size 1))))) (cond ((or !*plap !*pgwd) (setq s!:current_block (cons +(cons op doc) s!:current_block)))))) + +(put (quote LOADLIT) (quote s!:shortform) (cons (quote (1 . 7)) (s!:vecof ( +quote (!- LOADLIT1 LOADLIT2 LOADLIT3 LOADLIT4 LOADLIT5 LOADLIT6 LOADLIT7))))) + +(put (quote LOADFREE) (quote s!:shortform) (cons (quote (1 . 4)) (s!:vecof ( +quote (!- LOADFREE1 LOADFREE2 LOADFREE3 LOADFREE4))))) + +(put (quote STOREFREE) (quote s!:shortform) (cons (quote (1 . 3)) (s!:vecof ( +quote (!- STOREFREE1 STOREFREE2 STOREFREE3))))) + +(put (quote CALL0) (quote s!:shortform) (cons (quote (0 . 3)) (s!:vecof ( +quote (CALL0_0 CALL0_1 CALL0_2 CALL0_3))))) + +(put (quote CALL1) (quote s!:shortform) (cons (quote (0 . 5)) (s!:vecof ( +quote (CALL1_0 CALL1_1 CALL1_2 CALL1_3 CALL1_4 CALL1_5))))) + +(put (quote CALL2) (quote s!:shortform) (cons (quote (0 . 4)) (s!:vecof ( +quote (CALL2_0 CALL2_1 CALL2_2 CALL2_3 CALL2_4))))) + +(put (quote JUMPFREET) (quote s!:shortform) (cons (quote (1 . 4)) (s!:vecof ( +quote (!- JUMPFREE1T JUMPFREE2T JUMPFREE3T JUMPFREE4T))))) + +(put (quote JUMPFREENIL) (quote s!:shortform) (cons (quote (1 . 4)) (s!:vecof +(quote (!- JUMPFREE1NIL JUMPFREE2NIL JUMPFREE3NIL JUMPFREE4NIL))))) + +(put (quote JUMPLITEQ) (quote s!:shortform) (cons (quote (1 . 4)) (s!:vecof ( +quote (!- JUMPLIT1EQ JUMPLIT2EQ JUMPLIT3EQ JUMPLIT4EQ))))) + +(put (quote JUMPLITNE) (quote s!:shortform) (cons (quote (1 . 4)) (s!:vecof ( +quote (!- JUMPLIT1NE JUMPLIT2NE JUMPLIT3NE JUMPLIT4NE))))) + +(put (quote JUMPLITEQ!*) (quote s!:shortform) (get (quote JUMPLITEQ) (quote +s!:shortform))) + +(put (quote JUMPLITNE!*) (quote s!:shortform) (get (quote JUMPLITNE) (quote +s!:shortform))) + +(put (quote CALL0) (quote s!:longform) 0) + +(put (quote CALL1) (quote s!:longform) 16) + +(put (quote CALL2) (quote s!:longform) 32) + +(put (quote CALL3) (quote s!:longform) 48) + +(put (quote CALLN) (quote s!:longform) 64) + +(put (quote CALL2R) (quote s!:longform) 80) + +(put (quote LOADFREE) (quote s!:longform) 96) + +(put (quote STOREFREE) (quote s!:longform) 112) + +(put (quote JCALL0) (quote s!:longform) 128) + +(put (quote JCALL1) (quote s!:longform) 144) + +(put (quote JCALL2) (quote s!:longform) 160) + +(put (quote JCALL3) (quote s!:longform) 176) + +(put (quote JCALLN) (quote s!:longform) 192) + +(put (quote FREEBIND) (quote s!:longform) 208) + +(put (quote LITGET) (quote s!:longform) 224) + +(put (quote LOADLIT) (quote s!:longform) 240) + +(de s!:literal_order (a b) (cond ((equal (cadr a) (cadr b)) (orderp (car a) ( +car b))) (t (greaterp (cadr a) (cadr b))))) + +(de s!:resolve_literals (env checksum) (prog (w op opspec n litbytes) (setq w +(hashcontents (car env))) (setq w (sort w (function s!:literal_order))) ( +setq w (append w (list (list checksum 0)))) (setq n (length w)) (setq +litbytes (times 4 n)) (cond ((greaterp n 4096) (setq w (s!:too_many_literals +w n)))) (setq n 0) (prog (var1011) (setq var1011 w) lab1010 (cond ((null +var1011) (return nil))) (prog (x) (setq x (car var1011)) (progn (rplaca (cdr +x) n) (setq n (plus n 1)))) (setq var1011 (cdr var1011)) (go lab1010)) (prog +(var1015) (setq var1015 w) lab1014 (cond ((null var1015) (return nil))) (prog +(x) (setq x (car var1015)) (progn (setq n (cadr x)) (prog (var1013) (setq +var1013 (cddr x)) lab1012 (cond ((null var1013) (return nil))) (prog (y) ( +setq y (car var1013)) (progn (cond ((null (car y)) (progn (setq op (caadr y)) +(setq opspec (get op (quote s!:shortform))) (cond ((and opspec (leq (caar +opspec) n) (leq n (cdar opspec))) (rplaca (cdr y) (getv (cdr opspec) n))) (t +(rplaca (cdadr y) n))))) (t (progn (setq op (caddr y)) (cond ((greaterp n 255 +) (progn (rplaca (car y) (plus (caar y) 1)) (setq op (plus (get op (quote +s!:longform)) (truncate n 256))) (rplaca (cdr y) (ilogand n 255)) (rplaca ( +cddr y) (quote BIGCALL)) (rplacd (cdr y) (cons op (cddr y))))) (t (cond ((and +(setq opspec (get op (quote s!:shortform))) (leq (caar opspec) n) (leq n ( +cdar opspec))) (progn (rplaca (car y) (difference (caar y) 1)) (rplaca (cdr y +) (getv (cdr opspec) n)) (rplacd (cdr y) (cdddr y)))) (t (rplaca (cdr y) n))) +))))))) (setq var1013 (cdr var1013)) (go lab1012)))) (setq var1015 (cdr +var1015)) (go lab1014)) (prog (var1017) (setq var1017 w) lab1016 (cond ((null +var1017) (return nil))) (prog (x) (setq x (car var1017)) (rplacd x (cadr x)) +) (setq var1017 (cdr var1017)) (go lab1016)) (rplaca env (cons (reversip w) +litbytes)))) + +(de s!:only_loadlit (l) (cond ((null l) t) (t (cond ((null (caar l)) nil) (t +(cond ((not (eqcar (cddar l) (quote LOADLIT))) nil) (t (s!:only_loadlit (cdr +l))))))))) + +(de s!:too_many_literals (w n) (prog (k xvecs l r newrefs uses z1) (setq k 0) +(setq n (plus n 1)) (prog nil lab1018 (cond ((null (and (greaterp n 4096) ( +not (null w)))) (return nil))) (progn (cond ((and (not (equal (cadar w) +10000000)) (s!:only_loadlit (cddar w))) (progn (setq l (cons (car w) l)) ( +setq n (difference n 1)) (setq k (plus k 1)) (cond ((equal k 256) (progn ( +setq xvecs (cons l xvecs)) (setq l nil) (setq k 0) (setq n (plus n 1))))))) ( +t (setq r (cons (car w) r)))) (setq w (cdr w))) (go lab1018)) (cond (( +greaterp n 4096) (error 0 "function uses too many literals (4096 is limit)")) +) (setq xvecs (cons l xvecs)) (prog nil lab1019 (cond ((null r) (return nil)) +) (progn (setq w (cons (car r) w)) (setq r (cdr r))) (go lab1019)) (prog ( +var1025) (setq var1025 xvecs) lab1024 (cond ((null var1025) (return nil))) ( +prog (v) (setq v (car var1025)) (progn (setq newrefs nil) (setq uses 0) (setq +r nil) (setq k 0) (prog (var1023) (setq var1023 v) lab1022 (cond ((null +var1023) (return nil))) (prog (q) (setq q (car var1023)) (progn (prog ( +var1021) (setq var1021 (cddr q)) lab1020 (cond ((null var1021) (return nil))) +(prog (z) (setq z (car var1021)) (progn (cond ((car z) (rplaca (car z) (plus +(caar z) 2)))) (setq z1 (cons (quote QGETVN) (cons nil (cddr z)))) (rplaca ( +cdr z) k) (rplacd (cdr z) z1) (rplacd z (cdr z1)) (setq newrefs (cons z +newrefs)) (setq uses (plus uses 11)))) (setq var1021 (cdr var1021)) (go +lab1020)) (setq r (cons (car q) r)) (setq k (plus k 1)))) (setq var1023 (cdr +var1023)) (go lab1022)) (setq newrefs (cons uses newrefs)) (setq newrefs ( +cons (s!:vecof (reversip r)) newrefs)) (setq w (cons newrefs w)))) (setq +var1025 (cdr var1025)) (go lab1024)) (return (sort w (function +s!:literal_order))))) + +(fluid (quote (s!:into_c))) + +(de s!:endprocedure (name env checksum) (prog (pc labelvals w vec) ( +s!:outexit) (cond (s!:into_c (return (cons s!:current_procedure env)))) ( +s!:resolve_literals env checksum) (setq s!:current_procedure ( +s!:tidy_flowgraph s!:current_procedure)) (cond ((and (not !*notailcall) (not +s!:has_closure)) (setq s!:current_procedure (s!:try_tailcall +s!:current_procedure)))) (setq s!:current_procedure (s!:tidy_exits +s!:current_procedure)) (setq labelvals (s!:resolve_labels)) (setq pc (car +labelvals)) (setq labelvals (cdr labelvals)) (setq vec (make!-bps pc)) (setq +pc 0) (cond ((or !*plap !*pgwd) (progn (terpri) (ttab 23) (princ "+++ ") ( +prin name) (princ " +++") (terpri)))) (prog (var1027) (setq var1027 +s!:current_procedure) lab1026 (cond ((null var1027) (return nil))) (prog (b) +(setq b (car var1027)) (progn (cond ((and (car b) (flagp (car b) (quote +used_label)) (or !*plap !*pgwd)) (progn (ttab 20) (prin (car b)) (princ ":") +(terpri)))) (setq pc (s!:plant_basic_block vec pc (reverse (cdddr b)))) (setq +b (cadr b)) (cond ((and b (neq (car b) (quote ICASE)) (cdr b) (cddr b)) ( +setq b (list (car b) (cadr b))))) (setq pc (s!:plant_exit_code vec pc b +labelvals)))) (setq var1027 (cdr var1027)) (go lab1026)) (cond (!*pwrds ( +progn (cond ((neq (posn) 0) (terpri))) (princ "+++ ") (prin name) (princ +" compiled, ") (princ pc) (princ " + ") (princ (cdar env)) (princ " bytes") ( +terpri)))) (setq env (caar env)) (cond ((null env) (setq w nil)) (t (progn ( +setq w (mkvect (cdar env))) (prog nil lab1028 (cond ((null env) (return nil)) +) (progn (putv w (cdar env) (caar env)) (setq env (cdr env))) (go lab1028)))) +) (return (cons vec w)))) + +(de s!:add_pending (lab pend blocks) (prog (w) (cond ((not (atom lab)) ( +return (cons (list (gensym) lab 0) pend)))) (setq w (atsoc lab pend)) (cond ( +w (return (cons w (deleq w pend)))) (t (return (cons (atsoc lab blocks) pend) +))))) + +(de s!:invent_exit (x blocks) (prog (w) (setq w blocks) scan (cond ((null w) +(go not_found)) (t (cond ((and (eqcar (cadar w) x) (equal (caddar w) 0)) ( +return (cons (caar w) blocks))) (t (setq w (cdr w)))))) (go scan) not_found ( +setq w (gensym)) (return (cons w (cons (list w (list x) 0) blocks))))) + +(de s!:destination_label (lab blocks) (prog (n w x) (setq w (atsoc lab blocks +)) (cond ((s!:is_lose_and_exit w blocks) (return (quote (EXIT))))) (setq x ( +cadr w)) (setq n (caddr w)) (setq w (cdddr w)) (cond ((neq n 0) (return lab)) +) (cond ((or (null x) (null (cdr x))) (return x)) (t (cond ((equal (cadr x) +lab) (return lab)) (t (cond ((null (cddr x)) (return (s!:destination_label ( +cadr x) blocks))) (t (return lab))))))))) + +(de s!:remlose (b) (prog (w) (setq w b) (prog nil lab1029 (cond ((null (and w +(not (atom (car w))))) (return nil))) (setq w (cdr w)) (go lab1029)) (cond ( +(null w) (return (cons 0 b)))) (cond ((and (numberp (car w)) (eqcar (cdr w) ( +quote LOSES))) (setq w (cons 2 (cddr w)))) (t (cond ((or (equal (car w) ( +quote LOSE)) (equal (car w) (quote LOSE2)) (equal (car w) (quote LOSE3))) ( +setq w (cons 1 (cdr w)))) (t (return (cons 0 b)))))) (setq b (s!:remlose (cdr +w))) (return (cons (plus (car w) (car b)) (cdr b))))) + +(put (quote CALL0_0) (quote s!:shortcall) (quote (0 . 0))) + +(put (quote CALL0_1) (quote s!:shortcall) (quote (0 . 1))) + +(put (quote CALL0_2) (quote s!:shortcall) (quote (0 . 2))) + +(put (quote CALL0_3) (quote s!:shortcall) (quote (0 . 3))) + +(put (quote CALL1_0) (quote s!:shortcall) (quote (1 . 0))) + +(put (quote CALL1_1) (quote s!:shortcall) (quote (1 . 1))) + +(put (quote CALL1_2) (quote s!:shortcall) (quote (1 . 2))) + +(put (quote CALL1_3) (quote s!:shortcall) (quote (1 . 3))) + +(put (quote CALL1_4) (quote s!:shortcall) (quote (1 . 4))) + +(put (quote CALL1_5) (quote s!:shortcall) (quote (1 . 5))) + +(put (quote CALL2_0) (quote s!:shortcall) (quote (2 . 0))) + +(put (quote CALL2_1) (quote s!:shortcall) (quote (2 . 1))) + +(put (quote CALL2_2) (quote s!:shortcall) (quote (2 . 2))) + +(put (quote CALL2_3) (quote s!:shortcall) (quote (2 . 3))) + +(put (quote CALL2_4) (quote s!:shortcall) (quote (2 . 4))) + +(de s!:remcall (b) (prog (w p q r s) (prog nil lab1030 (cond ((null (and b ( +not (atom (car b))))) (return nil))) (progn (setq p (car b)) (setq b (cdr b)) +) (go lab1030)) (cond ((null b) (return nil)) (t (cond ((numberp (car b)) ( +progn (setq r (car b)) (setq s 2) (setq b (cdr b)) (cond ((null b) (return +nil)) (t (cond ((numberp (car b)) (progn (setq q r) (setq r (car b)) (setq s +3) (setq b (cdr b)) (cond ((and b (numberp (setq w (car b))) (eqcar (cdr b) ( +quote BIGCALL)) (equal (truncate w 16) 4)) (progn (setq r (plus (times 256 ( +logand w 15)) r)) (setq s 4) (setq b (cdr b)))) (t (cond ((eqcar b (quote +BIGCALL)) (progn (setq w (truncate r 16)) (setq r (plus (times 256 (logand r +15)) q)) (setq q w) (cond ((equal q 5) (progn (setq q 2) (setq s (difference +s 1)) (setq b (cons (quote BIGCALL) (cons (quote SWOP) (cdr b))))))) (cond (( +greaterp q 4) (return nil))))) (t (cond ((not (eqcar b (quote CALLN))) ( +return nil))))))))) (t (cond ((equal (car b) (quote CALL0)) (setq q 0)) (t ( +cond ((equal (car b) (quote CALL1)) (setq q 1)) (t (cond ((equal (car b) ( +quote CALL2)) (setq q 2)) (t (cond ((equal (car b) (quote CALL2R)) (progn ( +setq q 2) (setq s (difference s 1)) (setq b (cons (quote CALL2) (cons (quote +SWOP) (cdr b)))))) (t (cond ((equal (car b) (quote CALL3)) (setq q 3)) (t ( +return nil))))))))))))))) (setq b (cdr b)))) (t (cond ((setq q (get (car b) ( +quote s!:shortcall))) (progn (setq r (cdr q)) (setq q (car q)) (setq s 1) ( +setq b (cdr b)))) (t (return nil))))))) (return (cons p (cons q (cons r (cons +s b))))))) + +(de s!:is_lose_and_exit (b blocks) (prog (lab exit) (setq lab (car b)) (setq +exit (cadr b)) (setq b (cdddr b)) (cond ((null exit) (return nil))) (setq b ( +s!:remlose b)) (setq b (cdr b)) (prog nil lab1031 (cond ((null (and b (not ( +atom (car b))))) (return nil))) (setq b (cdr b)) (go lab1031)) (cond (b ( +return nil)) (t (cond ((equal (car exit) (quote EXIT)) (return t)) (t (cond ( +(equal (car exit) (quote JUMP)) (progn (cond ((equal (cadr exit) lab) nil) (t +(return (s!:is_lose_and_exit (atsoc (cadr exit) blocks) blocks)))))) (t ( +return nil))))))))) + +(de s!:try_tail_1 (b blocks) (prog (exit size body w w0 w1 w2 op) (setq exit +(cadr b)) (cond ((null exit) (return b)) (t (cond ((not (equal (car exit) ( +quote EXIT))) (progn (cond ((equal (car exit) (quote JUMP)) (progn (cond (( +not (s!:is_lose_and_exit (atsoc (cadr exit) blocks) blocks)) (return b))))) ( +t (return b)))))))) (setq size (caddr b)) (setq body (cdddr b)) (setq body ( +s!:remlose body)) (setq size (difference size (car body))) (setq body (cdr +body)) (setq w (s!:remcall body)) (cond ((null w) (return b))) (setq w0 (cadr +w)) (setq w1 (caddr w)) (setq body (cddddr w)) (cond ((and (leq w0 7) (leq +w1 31)) (progn (setq body (cons (quote JCALL) body)) (setq body (cons (plus ( +times 32 w0) w1) body)) (setq size (difference size 1)))) (t (cond ((lessp w1 +256) (setq body (cons w0 (cons w1 (cons (quote JCALLN) body))))) (t (progn ( +setq body (cons (quote BIGCALL) body)) (setq w2 (logand w1 255)) (setq w1 ( +truncate w1 256)) (cond ((lessp w0 4) (setq body (cons w2 (cons (plus w1 ( +times 16 w0) 128) body)))) (t (progn (setq body (cons w0 (cons w2 (cons (plus +w1 (plus (times 16 4) 128)) body)))) (setq size (plus size 1)))))))))) (cond +((car w) (setq body (cons (append (car w) (list (quote TAIL))) body)))) ( +rplaca (cdr b) nil) (rplaca (cddr b) (plus (difference size (cadddr w)) 3)) ( +rplacd (cddr b) body) (return b))) + +(de s!:try_tailcall (b) (prog (var1033 var1034) (setq var1033 b) lab1032 ( +cond ((null var1033) (return (reversip var1034)))) (prog (v) (setq v (car +var1033)) (setq var1034 (cons (s!:try_tail_1 v b) var1034))) (setq var1033 ( +cdr var1033)) (go lab1032))) + +(de s!:tidy_exits_1 (b blocks) (prog (exit size body comm w w0 w1 w2 op) ( +setq exit (cadr b)) (cond ((null exit) (return b)) (t (cond ((not (equal (car +exit) (quote EXIT))) (progn (cond ((equal (car exit) (quote JUMP)) (progn ( +cond ((not (s!:is_lose_and_exit (atsoc (cadr exit) blocks) blocks)) (return b +))))) (t (return b)))))))) (setq size (caddr b)) (setq body (cdddr b)) (setq +body (s!:remlose body)) (setq size (difference size (car body))) (setq body ( +cdr body)) (prog nil lab1035 (cond ((null (and body (not (atom (car body))))) +(return nil))) (progn (setq comm (car body)) (setq body (cdr body))) (go +lab1035)) (cond ((eqcar body (quote VNIL)) (setq w (quote NILEXIT))) (t (cond +((eqcar body (quote LOADLOC0)) (setq w (quote LOC0EXIT))) (t (cond ((eqcar +body (quote LOADLOC1)) (setq w (quote LOC1EXIT))) (t (cond ((eqcar body ( +quote LOADLOC2)) (setq w (quote LOC2EXIT))) (t (setq w nil))))))))) (cond (w +(progn (rplaca (cdr b) (list w)) (setq body (cdr body)) (setq size ( +difference size 1)))) (t (cond (comm (setq body (cons comm body)))))) (rplaca +(cddr b) size) (rplacd (cddr b) body) (return b))) + +(de s!:tidy_exits (b) (prog (var1037 var1038) (setq var1037 b) lab1036 (cond +((null var1037) (return (reversip var1038)))) (prog (v) (setq v (car var1037) +) (setq var1038 (cons (s!:tidy_exits_1 v b) var1038))) (setq var1037 (cdr +var1037)) (go lab1036))) + +(de s!:tidy_flowgraph (b) (prog (r pending) (setq b (reverse b)) (setq +pending (list (car b))) (prog nil lab1040 (cond ((null pending) (return nil)) +) (prog (c x l1 l2 done1 done2) (setq c (car pending)) (setq pending (cdr +pending)) (flag (list (car c)) (quote coded)) (setq x (cadr c)) (cond ((or ( +null x) (null (cdr x))) (setq r (cons c r))) (t (cond ((equal (car x) (quote +ICASE)) (progn (rplacd x (reversip (cdr x))) (prog (ll) (setq ll (cdr x)) +lab1039 (cond ((null ll) (return nil))) (progn (setq l1 (s!:destination_label +(car ll) b)) (cond ((not (atom l1)) (progn (setq l1 (s!:invent_exit (car l1) +b)) (setq b (cdr l1)) (setq l1 (cadr l1))))) (rplaca ll l1) (setq done1 ( +flagp l1 (quote coded))) (flag (list l1) (quote used_label)) (cond ((not +done1) (setq pending (s!:add_pending l1 pending b))))) (setq ll (cdr ll)) (go +lab1039)) (rplacd x (reversip (cdr x))) (setq r (cons c r)))) (t (cond (( +null (cddr x)) (progn (setq l1 (s!:destination_label (cadr x) b)) (cond ((not +(atom l1)) (setq c (cons (car c) (cons l1 (cddr c))))) (t (cond ((flagp l1 ( +quote coded)) (progn (flag (list l1) (quote used_label)) (setq c (cons (car c +) (cons (list (car x) l1) (cddr c)))))) (t (progn (setq c (cons (car c) (cons +nil (cddr c)))) (setq pending (s!:add_pending l1 pending b))))))) (setq r ( +cons c r)))) (t (progn (setq l1 (s!:destination_label (cadr x) b)) (setq l2 ( +s!:destination_label (caddr x) b)) (setq done1 (and (atom l1) (flagp l1 ( +quote coded)))) (setq done2 (and (atom l2) (flagp l2 (quote coded)))) (cond ( +done1 (progn (cond (done2 (progn (flag (list l1) (quote used_label)) (rplaca +(cdadr c) l1) (setq pending (cons (list (gensym) (list (quote JUMP) l2) 0) +pending)))) (t (progn (flag (list l1) (quote used_label)) (rplaca (cdadr c) +l1) (setq pending (s!:add_pending l2 pending b))))))) (t (progn (cond (done2 +(progn (flag (list l2) (quote used_label)) (rplaca (cadr c) (s!:negate_jump ( +car x))) (rplaca (cdadr c) l2) (setq pending (s!:add_pending l1 pending b)))) +(t (progn (cond ((not (atom l1)) (progn (setq l1 (s!:invent_exit (car l1) b) +) (setq b (cdr l1)) (setq l1 (car l1))))) (flag (list l1) (quote used_label)) +(rplaca (cdadr c) l1) (cond ((not (flagp l1 (quote coded))) (setq pending ( +s!:add_pending l1 pending b)))) (setq pending (s!:add_pending l2 pending b))) +))))) (setq r (cons c r)))))))))) (go lab1040)) (return (reverse r)))) + +(deflist (quote ((JUMPNIL JUMPT) (JUMPT JUMPNIL) (JUMPATOM JUMPNATOM) ( +JUMPNATOM JUMPATOM) (JUMPEQ JUMPNE) (JUMPNE JUMPEQ) (JUMPEQUAL JUMPNEQUAL) ( +JUMPNEQUAL JUMPEQUAL) (JUMPL0NIL JUMPL0T) (JUMPL0T JUMPL0NIL) (JUMPL1NIL +JUMPL1T) (JUMPL1T JUMPL1NIL) (JUMPL2NIL JUMPL2T) (JUMPL2T JUMPL2NIL) ( +JUMPL3NIL JUMPL3T) (JUMPL3T JUMPL3NIL) (JUMPL4NIL JUMPL4T) (JUMPL4T JUMPL4NIL +) (JUMPL0ATOM JUMPL0NATOM) (JUMPL0NATOM JUMPL0ATOM) (JUMPL1ATOM JUMPL1NATOM) +(JUMPL1NATOM JUMPL1ATOM) (JUMPL2ATOM JUMPL2NATOM) (JUMPL2NATOM JUMPL2ATOM) ( +JUMPL3ATOM JUMPL3NATOM) (JUMPL3NATOM JUMPL3ATOM) (JUMPST0NIL JUMPST0T) ( +JUMPST0T JUMPST0NIL) (JUMPST1NIL JUMPST1T) (JUMPST1T JUMPST1NIL) (JUMPST2NIL +JUMPST2T) (JUMPST2T JUMPST2NIL) (JUMPFREE1NIL JUMPFREE1T) (JUMPFREE1T +JUMPFREE1NIL) (JUMPFREE2NIL JUMPFREE2T) (JUMPFREE2T JUMPFREE2NIL) ( +JUMPFREE3NIL JUMPFREE3T) (JUMPFREE3T JUMPFREE3NIL) (JUMPFREE4NIL JUMPFREE4T) +(JUMPFREE4T JUMPFREE4NIL) (JUMPFREENIL JUMPFREET) (JUMPFREET JUMPFREENIL) ( +JUMPLIT1EQ JUMPLIT1NE) (JUMPLIT1NE JUMPLIT1EQ) (JUMPLIT2EQ JUMPLIT2NE) ( +JUMPLIT2NE JUMPLIT2EQ) (JUMPLIT3EQ JUMPLIT3NE) (JUMPLIT3NE JUMPLIT3EQ) ( +JUMPLIT4EQ JUMPLIT4NE) (JUMPLIT4NE JUMPLIT4EQ) (JUMPLITEQ JUMPLITNE) ( +JUMPLITNE JUMPLITEQ) (JUMPLITEQ!* JUMPLITNE!*) (JUMPLITNE!* JUMPLITEQ!*) ( +JUMPB1NIL JUMPB1T) (JUMPB1T JUMPB1NIL) (JUMPB2NIL JUMPB2T) (JUMPB2T JUMPB2NIL +) (JUMPFLAGP JUMPNFLAGP) (JUMPNFLAGP JUMPFLAGP) (JUMPEQCAR JUMPNEQCAR) ( +JUMPNEQCAR JUMPEQCAR))) (quote negjump)) + +(de s!:negate_jump (x) (cond ((atom x) (get x (quote negjump))) (t (rplaca x +(get (car x) (quote negjump)))))) + +(de s!:resolve_labels nil (prog (w labelvals converged pc x) (prog nil +lab1043 (progn (setq converged t) (setq pc 0) (prog (var1042) (setq var1042 +s!:current_procedure) lab1041 (cond ((null var1042) (return nil))) (prog (b) +(setq b (car var1042)) (progn (setq w (assoc!*!* (car b) labelvals)) (cond (( +null w) (progn (setq converged nil) (setq w (cons (car b) pc)) (setq +labelvals (cons w labelvals)))) (t (cond ((neq (cdr w) pc) (progn (rplacd w +pc) (setq converged nil)))))) (setq pc (plus pc (caddr b))) (setq x (cadr b)) +(cond ((null x) nil) (t (cond ((null (cdr x)) (setq pc (plus pc 1))) (t ( +cond ((equal (car x) (quote ICASE)) (setq pc (plus pc (times 2 (length x))))) +(t (progn (setq w (assoc!*!* (cadr x) labelvals)) (cond ((null w) (progn ( +setq w 128) (setq converged nil))) (t (setq w (difference (cdr w) pc)))) ( +setq w (s!:expand_jump (car x) w)) (setq pc (plus pc (length w)))))))))))) ( +setq var1042 (cdr var1042)) (go lab1041))) (cond ((null converged) (go +lab1043)))) (return (cons pc labelvals)))) + +(de s!:plant_basic_block (vec pc b) (prog (tagged) (prog (var1047) (setq +var1047 b) lab1046 (cond ((null var1047) (return nil))) (prog (i) (setq i ( +car var1047)) (progn (cond ((atom i) (progn (cond ((symbolp i) (setq i (get i +(quote s!:opcode))))) (cond ((and (not tagged) (or !*plap !*pgwd)) (progn ( +s!:prinhex4 pc) (princ ":") (ttab 8) (setq tagged t)))) (cond ((or (not (fixp +i)) (lessp i 0) (greaterp i 255)) (error "bad byte to put" i))) (bps!-putv +vec pc i) (cond ((or !*plap !*pgwd) (progn (s!:prinhex2 i) (princ " ")))) ( +setq pc (plus pc 1)))) (t (cond ((or !*plap !*pgwd) (progn (ttab 23) (princ ( +car i)) (prog (var1045) (setq var1045 (cdr i)) lab1044 (cond ((null var1045) +(return nil))) (prog (w) (setq w (car var1045)) (progn (princ " ") (prin w))) +(setq var1045 (cdr var1045)) (go lab1044)) (terpri) (setq tagged nil)))))))) +(setq var1047 (cdr var1047)) (go lab1046)) (return pc))) + +(de s!:plant_bytes (vec pc bytelist doc) (prog nil (cond ((or !*plap !*pgwd) +(progn (s!:prinhex4 pc) (princ ":") (ttab 8)))) (prog (var1049) (setq var1049 +bytelist) lab1048 (cond ((null var1049) (return nil))) (prog (v) (setq v ( +car var1049)) (progn (cond ((symbolp v) (setq v (get v (quote s!:opcode))))) +(cond ((or (not (fixp v)) (lessp v 0) (greaterp v 255)) (error +"bad byte to put" v))) (bps!-putv vec pc v) (cond ((or !*plap !*pgwd) (progn +(cond ((greaterp (posn) 50) (progn (terpri) (ttab 8)))) (s!:prinhex2 v) ( +princ " ")))) (setq pc (plus pc 1)))) (setq var1049 (cdr var1049)) (go +lab1048)) (cond ((or !*plap !*pgwd) (progn (cond ((greaterp (posn) 23) ( +terpri))) (ttab 23) (princ (car doc)) (prog (var1051) (setq var1051 (cdr doc) +) lab1050 (cond ((null var1051) (return nil))) (prog (w) (setq w (car var1051 +)) (progn (cond ((greaterp (posn) 65) (progn (terpri) (ttab 23)))) (princ " " +) (prin w))) (setq var1051 (cdr var1051)) (go lab1050)) (terpri)))) (return +pc))) + +(de s!:plant_exit_code (vec pc b labelvals) (prog (w loc low high r) (cond (( +null b) (return pc)) (t (cond ((null (cdr b)) (return (s!:plant_bytes vec pc +(list (get (car b) (quote s!:opcode))) b))) (t (cond ((equal (car b) (quote +ICASE)) (progn (setq loc (plus pc 3)) (prog (var1053) (setq var1053 (cdr b)) +lab1052 (cond ((null var1053) (return nil))) (prog (ll) (setq ll (car var1053 +)) (progn (setq w (difference (cdr (assoc!*!* ll labelvals)) loc)) (setq loc +(plus loc 2)) (cond ((lessp w 0) (progn (setq w (minus w)) (setq low (ilogand +w 255)) (setq high (plus 128 (truncate (difference w low) 256))))) (t (progn +(setq low (ilogand w 255)) (setq high (truncate (difference w low) 256))))) +(setq r (cons low (cons high r))))) (setq var1053 (cdr var1053)) (go lab1052) +) (setq r (cons (get (quote ICASE) (quote s!:opcode)) (cons (length (cddr b)) +(reversip r)))) (return (s!:plant_bytes vec pc r b))))))))) (setq w ( +difference (cdr (assoc!*!* (cadr b) labelvals)) pc)) (setq w (s!:expand_jump +(car b) w)) (return (s!:plant_bytes vec pc w b)))) + +(deflist (quote ((JUMPL0NIL ((LOADLOC0) JUMPNIL)) (JUMPL0T ((LOADLOC0) JUMPT) +) (JUMPL1NIL ((LOADLOC1) JUMPNIL)) (JUMPL1T ((LOADLOC1) JUMPT)) (JUMPL2NIL (( +LOADLOC2) JUMPNIL)) (JUMPL2T ((LOADLOC2) JUMPT)) (JUMPL3NIL ((LOADLOC3) +JUMPNIL)) (JUMPL3T ((LOADLOC3) JUMPT)) (JUMPL4NIL ((LOADLOC4) JUMPNIL)) ( +JUMPL4T ((LOADLOC4) JUMPT)) (JUMPL0ATOM ((LOADLOC0) JUMPATOM)) (JUMPL0NATOM ( +(LOADLOC0) JUMPNATOM)) (JUMPL1ATOM ((LOADLOC1) JUMPATOM)) (JUMPL1NATOM (( +LOADLOC1) JUMPNATOM)) (JUMPL2ATOM ((LOADLOC2) JUMPATOM)) (JUMPL2NATOM (( +LOADLOC2) JUMPNATOM)) (JUMPL3ATOM ((LOADLOC3) JUMPATOM)) (JUMPL3NATOM (( +LOADLOC3) JUMPNATOM)) (JUMPST0NIL ((STORELOC0) JUMPNIL)) (JUMPST0T (( +STORELOC0) JUMPT)) (JUMPST1NIL ((STORELOC1) JUMPNIL)) (JUMPST1T ((STORELOC1) +JUMPT)) (JUMPST2NIL ((STORELOC2) JUMPNIL)) (JUMPST2T ((STORELOC2) JUMPT)) ( +JUMPFREE1NIL ((LOADFREE1) JUMPNIL)) (JUMPFREE1T ((LOADFREE1) JUMPT)) ( +JUMPFREE2NIL ((LOADFREE2) JUMPNIL)) (JUMPFREE2T ((LOADFREE2) JUMPT)) ( +JUMPFREE3NIL ((LOADFREE3) JUMPNIL)) (JUMPFREE3T ((LOADFREE3) JUMPT)) ( +JUMPFREE4NIL ((LOADFREE4) JUMPNIL)) (JUMPFREE4T ((LOADFREE4) JUMPT)) ( +JUMPFREENIL ((LOADFREE !*) JUMPNIL)) (JUMPFREET ((LOADFREE !*) JUMPT)) ( +JUMPLIT1EQ ((LOADLIT1) JUMPEQ)) (JUMPLIT1NE ((LOADLIT1) JUMPNE)) (JUMPLIT2EQ +((LOADLIT2) JUMPEQ)) (JUMPLIT2NE ((LOADLIT2) JUMPNE)) (JUMPLIT3EQ ((LOADLIT3) +JUMPEQ)) (JUMPLIT3NE ((LOADLIT3) JUMPNE)) (JUMPLIT4EQ ((LOADLIT4) JUMPEQ)) ( +JUMPLIT4NE ((LOADLIT4) JUMPNE)) (JUMPLITEQ ((LOADLIT !*) JUMPEQ)) (JUMPLITNE +((LOADLIT !*) JUMPNE)) (JUMPLITEQ!* ((LOADLIT !* SWOP) JUMPEQ)) (JUMPLITNE!* +((LOADLIT !* SWOP) JUMPNE)) (JUMPB1NIL ((BUILTIN1 !*) JUMPNIL)) (JUMPB1T (( +BUILTIN1 !*) JUMPT)) (JUMPB2NIL ((BUILTIN2 !*) JUMPNIL)) (JUMPB2T ((BUILTIN2 +!*) JUMPT)) (JUMPFLAGP ((LOADLIT !* FLAGP) JUMPT)) (JUMPNFLAGP ((LOADLIT !* +FLAGP) JUMPNIL)) (JUMPEQCAR ((LOADLIT !* EQCAR) JUMPT)) (JUMPNEQCAR ((LOADLIT +!* EQCAR) JUMPNIL)))) (quote s!:expand_jump)) + +(fluid (quote (s!:backwards_jump s!:longer_jump))) + +(progn (setq s!:backwards_jump (make!-simple!-string 256)) (setq +s!:longer_jump (make!-simple!-string 256)) nil) + +(prog (var1055) (setq var1055 (quote ((JUMP JUMP_B JUMP_L JUMP_BL) (JUMPNIL +JUMPNIL_B JUMPNIL_L JUMPNIL_BL) (JUMPT JUMPT_B JUMPT_L JUMPT_BL) (JUMPATOM +JUMPATOM_B JUMPATOM_L JUMPATOM_BL) (JUMPNATOM JUMPNATOM_B JUMPNATOM_L +JUMPNATOM_BL) (JUMPEQ JUMPEQ_B JUMPEQ_L JUMPEQ_BL) (JUMPNE JUMPNE_B JUMPNE_L +JUMPNE_BL) (JUMPEQUAL JUMPEQUAL_B JUMPEQUAL_L JUMPEQUAL_BL) (JUMPNEQUAL +JUMPNEQUAL_B JUMPNEQUAL_L JUMPNEQUAL_BL) (CATCH CATCH_B CATCH_L CATCH_BL)))) +lab1054 (cond ((null var1055) (return nil))) (prog (op) (setq op (car var1055 +)) (progn (putv!-char s!:backwards_jump (get (car op) (quote s!:opcode)) (get +(cadr op) (quote s!:opcode))) (putv!-char s!:backwards_jump (get (caddr op) +(quote s!:opcode)) (get (cadddr op) (quote s!:opcode))) (putv!-char +s!:longer_jump (get (car op) (quote s!:opcode)) (get (caddr op) (quote +s!:opcode))) (putv!-char s!:longer_jump (get (cadr op) (quote s!:opcode)) ( +get (cadddr op) (quote s!:opcode))))) (setq var1055 (cdr var1055)) (go +lab1054)) + +(de s!:expand_jump (op offset) (prog (arg low high opcode expanded) (cond (( +not (atom op)) (progn (setq arg (cadr op)) (setq op (car op)) (setq offset ( +difference offset 1))))) (setq expanded (get op (quote s!:expand_jump))) ( +cond ((and expanded (not (and (leq 2 offset) (lessp offset (plus 256 2)) (or +(null arg) (lessp arg 256))))) (progn (setq op (cadr expanded)) (setq +expanded (car expanded)) (cond (arg (progn (cond ((greaterp arg 2047) (error +0 "function uses too many literals (2048 limit)")) (t (cond ((greaterp arg +255) (prog (high low) (setq low (ilogand arg 255)) (setq high (truncate ( +difference arg low) 256)) (setq expanded (cons (quote BIGCALL) (cons (plus ( +get (car expanded) (quote s!:longform)) high) (cons low (cddr expanded))))))) +(t (setq expanded (subst arg (quote !*) expanded)))))) (setq offset (plus +offset 1))))) (setq offset (difference offset (length expanded))) (setq arg +nil))) (t (setq expanded nil))) (setq opcode (get op (quote s!:opcode))) ( +cond ((null opcode) (error 0 (list op offset "invalid block exit")))) (cond ( +(and (lessp (plus (minus 256) 2) offset) (lessp offset (plus 256 2))) (setq +offset (difference offset 2))) (t (progn (setq high t) (setq offset ( +difference offset 3))))) (cond ((lessp offset 0) (progn (setq opcode ( +byte!-getv s!:backwards_jump opcode)) (setq offset (minus offset))))) (cond ( +high (progn (setq low (logand offset 255)) (setq high (truncate (difference +offset low) 256)))) (t (cond ((greaterp (setq low offset) 255) (error 0 +"Bad offset in expand_jump"))))) (cond (arg (return (list opcode arg low))) ( +t (cond ((not high) (return (append expanded (list opcode low)))) (t (return +(append expanded (list (byte!-getv s!:longer_jump opcode) high low))))))))) + +(de s!:comval (x env context) (prog (helper) (setq x (s!:improve x)) (cond (( +atom x) (return (s!:comatom x env context))) (t (cond ((eqcar (car x) (quote +lambda)) (return (s!:comlambda (cadar x) (cddar x) (cdr x) env context))) (t +(cond ((eq (car x) s!:current_function) (s!:comcall x env context)) (t (cond +((and (setq helper (get (car x) (quote s!:compilermacro))) (setq helper ( +funcall helper x env context))) (return (s!:comval helper env context))) (t ( +cond ((setq helper (get (car x) (quote s!:newname))) (return (s!:comval (cons +helper (cdr x)) env context))) (t (cond ((setq helper (get (car x) (quote +s!:compfn))) (return (funcall helper x env context))) (t (cond ((setq helper +(macro!-function (car x))) (return (s!:comval (funcall helper x) env context) +)) (t (return (s!:comcall x env context)))))))))))))))))) + +(de s!:comspecform (x env context) (error 0 (list "special form" x))) + +(cond ((null (get (quote and) (quote s!:compfn))) (progn (put (quote +compiler!-let) (quote s!:compfn) (function s!:comspecform)) (put (quote de) ( +quote s!:compfn) (function s!:comspecform)) (put (quote defun) (quote +s!:compfn) (function s!:comspecform)) (put (quote eval!-when) (quote +s!:compfn) (function s!:comspecform)) (put (quote flet) (quote s!:compfn) ( +function s!:comspecform)) (put (quote labels) (quote s!:compfn) (function +s!:comspecform)) (put (quote macrolet) (quote s!:compfn) (function +s!:comspecform)) (put (quote multiple!-value!-call) (quote s!:compfn) ( +function s!:comspecform)) (put (quote multiple!-value!-prog1) (quote +s!:compfn) (function s!:comspecform)) (put (quote prog!*) (quote s!:compfn) ( +function s!:comspecform)) (put (quote progv) (quote s!:compfn) (function +s!:comspecform)) nil))) + +(de s!:improve (u) (prog (w) (cond ((atom u) (return u)) (t (cond ((setq w ( +get (car u) (quote s!:tidy_fn))) (return (funcall w u))) (t (cond ((setq w ( +get (car u) (quote s!:newname))) (return (s!:improve (cons w (cdr u))))) (t ( +return u))))))))) + +(de s!:imp_minus (u) (prog (a) (setq a (s!:improve (cadr u))) (return (cond ( +(numberp a) (minus a)) (t (cond ((or (eqcar a (quote minus)) (eqcar a (quote +iminus))) (cadr a)) (t (cond ((eqcar a (quote difference)) (s!:improve (list +(quote difference) (caddr a) (cadr a)))) (t (cond ((eqcar a (quote +idifference)) (s!:improve (list (quote idifference) (caddr a) (cadr a)))) (t +(list (car u) a)))))))))))) + +(put (quote minus) (quote s!:tidy_fn) (quote s!:imp_minus)) + +(put (quote iminus) (quote s!:tidy_fn) (quote s!:imp_minus)) + +(de s!:imp_times (u) (prog (a b) (cond ((not (equal (length u) 3)) (return ( +cons (car u) (prog (var1057 var1058) (setq var1057 (cdr u)) lab1056 (cond (( +null var1057) (return (reversip var1058)))) (prog (v) (setq v (car var1057)) +(setq var1058 (cons (s!:improve v) var1058))) (setq var1057 (cdr var1057)) ( +go lab1056)))))) (setq a (s!:improve (cadr u))) (setq b (s!:improve (caddr u) +)) (return (cond ((equal a 1) b) (t (cond ((equal b 1) a) (t (cond ((equal a +(minus 1)) (s!:imp_minus (list (quote minus) b))) (t (cond ((equal b (minus 1 +)) (s!:imp_minus (list (quote minus) a))) (t (list (car u) a b)))))))))))) + +(put (quote times) (quote s!:tidy_fn) (quote s!:imp_times)) + +(de s!:imp_itimes (u) (prog (a b) (cond ((not (equal (length u) 3)) (return ( +cons (car u) (prog (var1060 var1061) (setq var1060 (cdr u)) lab1059 (cond (( +null var1060) (return (reversip var1061)))) (prog (v) (setq v (car var1060)) +(setq var1061 (cons (s!:improve v) var1061))) (setq var1060 (cdr var1060)) ( +go lab1059)))))) (setq a (s!:improve (cadr u))) (setq b (s!:improve (caddr u) +)) (return (cond ((equal a 1) b) (t (cond ((equal b 1) a) (t (cond ((equal a +(minus 1)) (s!:imp_minus (list (quote iminus) b))) (t (cond ((equal b (minus +1)) (s!:imp_minus (list (quote iminus) a))) (t (list (car u) a b)))))))))))) + +(put (quote itimes) (quote s!:tidy_fn) (quote s!:imp_itimes)) + +(de s!:imp_difference (u) (prog (a b) (setq a (s!:improve (cadr u))) (setq b +(s!:improve (caddr u))) (return (cond ((equal a 0) (s!:imp_minus (list (quote +minus) b))) (t (cond ((equal b 0) a) (t (list (car u) a b)))))))) + +(put (quote difference) (quote s!:tidy_fn) (quote s!:imp_difference)) + +(de s!:imp_idifference (u) (prog (a b) (setq a (s!:improve (cadr u))) (setq b +(s!:improve (caddr u))) (return (cond ((equal a 0) (s!:imp_minus (list ( +quote iminus) b))) (t (cond ((equal b 0) a) (t (list (car u) a b)))))))) + +(put (quote idifference) (quote s!:tidy_fn) (quote s!:imp_idifference)) + +(de s!:alwayseasy (x) t) + +(put (quote quote) (quote s!:helpeasy) (function s!:alwayseasy)) + +(put (quote function) (quote s!:helpeasy) (function s!:alwayseasy)) + +(de s!:easyifarg (x) (or (null (cdr x)) (and (null (cddr x)) (s!:iseasy (cadr +x))))) + +(put (quote ncons) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote car) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cdr) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote caar) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cadr) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cdar) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cddr) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote caaar) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote caadr) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cadar) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote caddr) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cdaar) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cdadr) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cddar) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cdddr) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote caaaar) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote caaadr) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote caadar) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote caaddr) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cadaar) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cadadr) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote caddar) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cadddr) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cdaaar) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cdaadr) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cdadar) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cdaddr) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cddaar) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cddadr) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cdddar) (quote s!:helpeasy) (function s!:easyifarg)) + +(put (quote cddddr) (quote s!:helpeasy) (function s!:easyifarg)) + +(de s!:easygetv (x) (prog (a2) (setq a2 (caddr x)) (cond ((and (null +!*carcheckflag) (fixp a2) (geq a2 0) (lessp a2 256)) (return (s!:iseasy (cadr +x)))) (t (return nil))))) + +(put (quote getv) (quote s!:helpeasy) (function s!:easygetv)) + +(de s!:easyqgetv (x) (prog (a2) (setq a2 (caddr x)) (cond ((and (fixp a2) ( +geq a2 0) (lessp a2 256)) (return (s!:iseasy (cadr x)))) (t (return nil))))) + +(put (quote qgetv) (quote s!:helpeasy) (function s!:easyqgetv)) + +(de s!:iseasy (x) (prog (h) (cond ((atom x) (return t))) (cond ((not (atom ( +car x))) (return nil))) (cond ((setq h (get (car x) (quote s!:helpeasy))) ( +return (funcall h x))) (t (return nil))))) + +(de s!:instate_local_decs (v d w) (prog (fg) (cond ((fluidp v) (return w))) ( +prog (var1063) (setq var1063 d) lab1062 (cond ((null var1063) (return nil))) +(prog (z) (setq z (car var1063)) (cond ((and (eqcar z (quote special)) (memq +v (cdr z))) (setq fg t)))) (setq var1063 (cdr var1063)) (go lab1062)) (cond ( +fg (progn (make!-special v) (setq w (cons v w))))) (return w))) + +(de s!:residual_local_decs (d w) (prog nil (prog (var1067) (setq var1067 d) +lab1066 (cond ((null var1067) (return nil))) (prog (z) (setq z (car var1067)) +(cond ((eqcar z (quote special)) (prog (var1065) (setq var1065 (cdr z)) +lab1064 (cond ((null var1065) (return nil))) (prog (v) (setq v (car var1065)) +(cond ((and (not (fluidp v)) (not (globalp v))) (progn (make!-special v) ( +setq w (cons v w)))))) (setq var1065 (cdr var1065)) (go lab1064))))) (setq +var1067 (cdr var1067)) (go lab1066)) (return w))) + +(de s!:cancel_local_decs (w) (unfluid w)) + +(de s!:find_local_decs (body isprog) (prog (w local_decs) (cond ((and (not +isprog) body (null (cdr body)) (eqcar (car body) (quote progn))) (setq body ( +cdar body)))) (prog nil lab1068 (cond ((null (and body (or (eqcar (car body) +(quote declare)) (stringp (car body))))) (return nil))) (progn (cond (( +stringp (car body)) (setq w (cons (car body) w))) (t (setq local_decs (append +local_decs (cdar body))))) (setq body (cdr body))) (go lab1068)) (prog nil +lab1069 (cond ((null w) (return nil))) (progn (setq body (cons (car w) body)) +(setq w (cdr w))) (go lab1069)) (return (cons local_decs body)))) + +(de s!:comlambda (bvl body args env context) (prog (s nbvl fluids fl1 w +local_decs) (setq nbvl (setq s (cdr env))) (setq body (s!:find_local_decs +body nil)) (setq local_decs (car body)) (setq body (cdr body)) (cond ((atom +body) (setq body nil)) (t (cond ((atom (cdr body)) (setq body (car body))) (t +(setq body (cons (quote progn) body)))))) (setq w nil) (prog (var1071) (setq +var1071 bvl) lab1070 (cond ((null var1071) (return nil))) (prog (v) (setq v +(car var1071)) (setq w (s!:instate_local_decs v local_decs w))) (setq var1071 +(cdr var1071)) (go lab1070)) (prog (var1073) (setq var1073 bvl) lab1072 ( +cond ((null var1073) (return nil))) (prog (v) (setq v (car var1073)) (progn ( +cond ((or (fluidp v) (globalp v)) (prog (g) (setq g (gensym)) (setq nbvl ( +cons g nbvl)) (setq fl1 (cons v fl1)) (setq fluids (cons (cons v g) fluids))) +) (t (setq nbvl (cons v nbvl)))) (cond ((equal (car args) nil) (s!:outstack 1 +)) (t (progn (s!:comval (car args) env 1) (s!:outopcode0 (quote PUSH) (quote +(PUSH)))))) (rplacd env (cons 0 (cdr env))) (setq args (cdr args)))) (setq +var1073 (cdr var1073)) (go lab1072)) (rplacd env nbvl) (cond (fluids (progn ( +setq fl1 (s!:vecof fl1)) (s!:outopcode1lit (quote FREEBIND) fl1 env) (prog ( +var1075) (setq var1075 (cons nil fluids)) lab1074 (cond ((null var1075) ( +return nil))) (prog (v) (setq v (car var1075)) (rplacd env (cons 0 (cdr env)) +)) (setq var1075 (cdr var1075)) (go lab1074)) (rplacd env (cons (plus 2 ( +length fluids)) (cdr env))) (prog (var1077) (setq var1077 fluids) lab1076 ( +cond ((null var1077) (return nil))) (prog (v) (setq v (car var1077)) ( +s!:comval (list (quote setq) (car v) (cdr v)) env 2)) (setq var1077 (cdr +var1077)) (go lab1076))))) (setq w (s!:residual_local_decs local_decs w)) ( +s!:comval body env 1) (s!:cancel_local_decs w) (cond (fluids (s!:outopcode0 ( +quote FREERSTR) (quote (FREERSTR))))) (s!:outlose (length bvl)) (rplacd env s +))) + +(de s!:loadliteral (x env) (cond ((member!*!* (list (quote quote) x) +s!:a_reg_values) nil) (t (progn (cond ((equal x nil) (s!:outopcode0 (quote +VNIL) (quote (loadlit nil)))) (t (s!:outopcode1lit (quote LOADLIT) x env))) ( +setq s!:a_reg_values (list (list (quote quote) x))))))) + +(de s!:comquote (x env context) (cond ((leq context 1) (s!:loadliteral (cadr +x) env)))) + +(put (quote quote) (quote s!:compfn) (function s!:comquote)) + +(fluid (quote (s!:current_exitlab s!:current_proglabels s!:local_macros))) + +(de s!:comfunction (x env context) (cond ((leq context 1) (progn (setq x ( +cadr x)) (cond ((eqcar x (quote lambda)) (prog (g w s!:used_lexicals) (setq +s!:has_closure t) (setq g (hashtagged!-name (quote lambda) (cdr x))) (setq w +(s!:compile1 g (cadr x) (cddr x) (cons (list (cdr env) s!:current_exitlab +s!:current_proglabels s!:local_macros) s!:lexical_env))) (cond ( +s!:used_lexicals (setq w (s!:compile1 g (cons (gensym) (cadr x)) (cddr x) ( +cons (list (cdr env) s!:current_exitlab s!:current_proglabels s!:local_macros +) s!:lexical_env))))) (setq s!:other_defs (append w s!:other_defs)) ( +s!:loadliteral g env) (setq w (length (cdr env))) (cond (s!:used_lexicals ( +progn (setq s!:has_closure t) (cond ((greaterp w 4095) (error 0 +"stack frame > 4095")) (t (cond ((greaterp w 255) (s!:outopcode2 (quote +BIGSTACK) (plus 128 (truncate w 256)) (logand w 255) (list (quote CLOSURE) w) +)) (t (s!:outopcode1 (quote CLOSURE) w x)))))))))) (t (s!:loadliteral x env)) +))))) + +(put (quote function) (quote s!:compfn) (function s!:comfunction)) + +(de s!:should_be_fluid (x) (cond ((not (or (fluidp x) (globalp x))) (progn ( +cond (!*pwrds (progn (cond ((neq (posn) 0) (terpri))) (princ "+++ ") (prin x) +(princ " declared fluid") (terpri)))) (fluid (list x)) nil)))) + +(de s!:find_lexical (x lex n) (prog (p) (cond ((null lex) (return nil))) ( +setq p (memq x (caar lex))) (cond (p (progn (cond ((not (memq x +s!:used_lexicals)) (setq s!:used_lexicals (cons x s!:used_lexicals)))) ( +return (list n (length p))))) (t (return (s!:find_lexical x (cdr lex) (plus n +1))))))) + +(global (quote (s!:loadlocs))) + +(setq s!:loadlocs (s!:vecof (quote (LOADLOC0 LOADLOC1 LOADLOC2 LOADLOC3 +LOADLOC4 LOADLOC5 LOADLOC6 LOADLOC7 LOADLOC8 LOADLOC9 LOADLOC10 LOADLOC11)))) + +(de s!:comatom (x env context) (prog (n w) (cond ((greaterp context 1) ( +return nil)) (t (cond ((or (null x) (not (symbolp x))) (return ( +s!:loadliteral x env)))))) (setq n 0) (setq w (cdr env)) (prog nil lab1078 ( +cond ((null (and w (not (eqcar w x)))) (return nil))) (progn (setq n (add1 n) +) (setq w (cdr w))) (go lab1078)) (cond (w (progn (setq w (cons (quote loc) w +)) (cond ((member!*!* w s!:a_reg_values) (return nil)) (t (progn (cond (( +lessp n 12) (s!:outopcode0 (getv s!:loadlocs n) (list (quote LOADLOC) x))) (t +(cond ((greaterp n 4095) (error 0 "stack frame > 4095")) (t (cond ((greaterp +n 255) (s!:outopcode2 (quote BIGSTACK) (truncate n 256) (logand n 255) (list +(quote LOADLOC) x))) (t (s!:outopcode1 (quote LOADLOC) n x))))))) (setq +s!:a_reg_values (list w)) (return nil))))))) (cond ((setq w (s!:find_lexical +x s!:lexical_env 0)) (progn (cond ((member!*!* (cons (quote lex) w) +s!:a_reg_values) (return nil))) (s!:outlexref (quote LOADLEX) (length (cdr +env)) (car w) (cadr w) x) (setq s!:a_reg_values (list (cons (quote lex) w))) +(return nil)))) (s!:should_be_fluid x) (cond ((flagp x (quote constant!?)) ( +return (s!:loadliteral (eval x) env)))) (setq w (cons (quote free) x)) (cond +((member!*!* w s!:a_reg_values) (return nil))) (s!:outopcode1lit (quote +LOADFREE) x env) (setq s!:a_reg_values (list w)))) + +(flag (quote (t !$EOL!$ !$EOF!$)) (quote constant!?)) + +(de s!:islocal (x env) (prog (n w) (cond ((or (null x) (not (symbolp x)) (eq +x t)) (return 99999))) (setq n 0) (setq w (cdr env)) (prog nil lab1079 (cond +((null (and w (not (eqcar w x)))) (return nil))) (progn (setq n (add1 n)) ( +setq w (cdr w))) (go lab1079)) (cond (w (return n)) (t (return 99999))))) + +(de s!:load2 (a b env) (progn (cond ((s!:iseasy b) (prog (wa wb w) (setq wa ( +s!:islocal a env)) (setq wb (s!:islocal b env)) (cond ((and (lessp wa 4) ( +lessp wb 4)) (progn (cond ((and (equal wa 0) (equal wb 1)) (setq w (quote +LOC0LOC1))) (t (cond ((and (equal wa 1) (equal wb 2)) (setq w (quote LOC1LOC2 +))) (t (cond ((and (equal wa 2) (equal wb 3)) (setq w (quote LOC2LOC3))) (t ( +cond ((and (equal wa 1) (equal wb 0)) (setq w (quote LOC1LOC0))) (t (cond (( +and (equal wa 2) (equal wb 1)) (setq w (quote LOC2LOC1))) (t (cond ((and ( +equal wa 3) (equal wb 2)) (setq w (quote LOC3LOC2)))))))))))))) (cond (w ( +progn (s!:outopcode0 w (list (quote LOCLOC) a b)) (return nil))))))) ( +s!:comval a env 1) (setq s!:a_reg_values nil) (s!:comval b env 1) (return nil +))) (t (cond (!*ord (progn (s!:comval a env 1) (s!:outopcode0 (quote PUSH) ( +quote (PUSH))) (rplacd env (cons 0 (cdr env))) (setq s!:a_reg_values nil) ( +s!:comval b env 1) (s!:outopcode0 (quote POP) (quote (POP))) (rplacd env ( +cddr env)) t)) (t (cond ((s!:iseasy a) (progn (s!:comval b env 1) (setq +s!:a_reg_values nil) (s!:comval a env 1) t)) (t (progn (s!:comval b env 1) ( +s!:outopcode0 (quote PUSH) (quote (PUSH))) (rplacd env (cons 0 (cdr env))) ( +setq s!:a_reg_values nil) (s!:comval a env 1) (s!:outopcode0 (quote POP) ( +quote (POP))) (rplacd env (cddr env)) nil))))))))) + +(global (quote (s!:carlocs s!:cdrlocs s!:caarlocs))) + +(setq s!:carlocs (s!:vecof (quote (CARLOC0 CARLOC1 CARLOC2 CARLOC3 CARLOC4 +CARLOC5 CARLOC6 CARLOC7 CARLOC8 CARLOC9 CARLOC10 CARLOC11)))) + +(setq s!:cdrlocs (s!:vecof (quote (CDRLOC0 CDRLOC1 CDRLOC2 CDRLOC3 CDRLOC4 +CDRLOC5)))) + +(setq s!:caarlocs (s!:vecof (quote (CAARLOC0 CAARLOC1 CAARLOC2 CAARLOC3)))) + +(flag (quote (plus2 times2 eq equal)) (quote s!:symmetric)) + +(flag (quote (car cdr caar cadr cdar cddr ncons add1 sub1 numberp length)) ( +quote s!:onearg)) + +(flag (quote (cons xcons list2 get flagp plus2 difference times2 greaterp +lessp apply1 eq equal getv qgetv eqcar)) (quote s!:twoarg)) + +(flag (quote (apply2 list2!* list3 acons)) (quote s!:threearg)) + +(de s!:comcall (x env context) (prog (fn args nargs op s w1 w2 w3 sw) (setq +fn (car x)) (cond ((not (symbolp fn)) (error 0 +"non-symbol used in function position"))) (setq args (prog (var1081 var1082) +(setq var1081 (cdr x)) lab1080 (cond ((null var1081) (return (reversip +var1082)))) (prog (v) (setq v (car var1081)) (setq var1082 (cons (s!:improve +v) var1082))) (setq var1081 (cdr var1081)) (go lab1080))) (setq nargs (length +args)) (cond ((and (greaterp nargs 15) !*pwrds) (progn (cond ((neq (posn) 0) +(terpri))) (princ "+++ ") (prin fn) (princ " called with ") (prin nargs) ( +princ " from function ") (prin s!:current_function) (terpri)))) (setq s (cdr +env)) (cond ((equal nargs 0) (cond ((setq w2 (get fn (quote s!:builtin0))) ( +s!:outopcode1 (quote BUILTIN0) w2 fn)) (t (s!:outopcode1lit (quote CALL0) fn +env)))) (t (cond ((equal nargs 1) (progn (cond ((and (equal fn (quote car)) ( +lessp (setq w2 (s!:islocal (car args) env)) 12)) (s!:outopcode0 (getv +s!:carlocs w2) (list (quote carloc) (car args)))) (t (cond ((and (equal fn ( +quote cdr)) (lessp (setq w2 (s!:islocal (car args) env)) 6)) (s!:outopcode0 ( +getv s!:cdrlocs w2) (list (quote cdrloc) (car args)))) (t (cond ((and (equal +fn (quote caar)) (lessp (setq w2 (s!:islocal (car args) env)) 4)) ( +s!:outopcode0 (getv s!:caarlocs w2) (list (quote caarloc) (car args)))) (t ( +progn (s!:comval (car args) env 1) (cond ((flagp fn (quote s!:onearg)) ( +s!:outopcode0 fn (list fn))) (t (cond ((setq w2 (get fn (quote s!:builtin1))) +(s!:outopcode1 (quote BUILTIN1) w2 fn)) (t (s!:outopcode1lit (quote CALL1) +fn env)))))))))))))) (t (cond ((equal nargs 2) (progn (setq sw (s!:load2 (car +args) (cadr args) env)) (cond ((flagp fn (quote s!:symmetric)) (setq sw nil) +)) (cond ((flagp fn (quote s!:twoarg)) (progn (cond (sw (s!:outopcode0 (quote +SWOP) (quote (SWOP))))) (s!:outopcode0 fn (list fn)))) (t (progn (setq w3 ( +get fn (quote s!:builtin2))) (cond (sw (progn (cond (w3 (s!:outopcode1 (quote +BUILTIN2R) w3 fn)) (t (s!:outopcode1lit (quote CALL2R) fn env))))) (t (cond +(w3 (s!:outopcode1 (quote BUILTIN2) w3 fn)) (t (s!:outopcode1lit (quote CALL2 +) fn env)))))))))) (t (cond ((equal nargs 3) (progn (cond ((equal (car args) +nil) (s!:outstack 1)) (t (progn (s!:comval (car args) env 1) (s!:outopcode0 ( +quote PUSH) (quote (PUSHA3)))))) (rplacd env (cons 0 (cdr env))) (setq +s!:a_reg_values nil) (cond ((s!:load2 (cadr args) (caddr args) env) ( +s!:outopcode0 (quote SWOP) (quote (SWOP))))) (cond ((flagp fn (quote +s!:threearg)) (s!:outopcode0 (cond ((equal fn (quote list2!*)) (quote +list2star)) (t fn)) (list fn))) (t (cond ((setq w2 (get fn (quote s!:builtin3 +))) (s!:outopcode1 (quote BUILTIN3) w2 fn)) (t (s!:outopcode1lit (quote CALL3 +) fn env))))) (rplacd env (cddr env)))) (t (prog (largs) (setq largs (reverse +args)) (prog (var1084) (setq var1084 (reverse (cddr largs))) lab1083 (cond ( +(null var1084) (return nil))) (prog (a) (setq a (car var1084)) (progn (cond ( +(null a) (s!:outstack 1)) (t (progn (s!:comval a env 1) (cond ((equal nargs 4 +) (s!:outopcode0 (quote PUSH) (quote (PUSHA4)))) (t (s!:outopcode0 (quote +PUSH) (quote (PUSHARG)))))))) (rplacd env (cons 0 (cdr env))) (setq +s!:a_reg_values nil))) (setq var1084 (cdr var1084)) (go lab1083)) (cond (( +s!:load2 (cadr largs) (car largs) env) (s!:outopcode0 (quote SWOP) (quote ( +SWOP))))) (cond ((and (equal fn (quote apply3)) (equal nargs 4)) ( +s!:outopcode0 (quote APPLY3) (quote (APPLY3)))) (t (cond ((greaterp nargs 255 +) (error 0 "Over 255 args in a function call")) (t (s!:outopcode2lit (quote +CALLN) fn nargs (list nargs fn) env))))) (rplacd env s)))))))))))) + +(de s!:ad_name (l) (cond ((equal (car l) (quote a)) (cond ((equal (cadr l) ( +quote a)) (quote caar)) (t (quote cadr)))) (t (cond ((equal (cadr l) (quote a +)) (quote cdar)) (t (quote cddr)))))) + +(de s!:comcarcdr3 (x env context) (prog (name outer c1 c2) (setq name (cdr ( +explode2 (car x)))) (setq x (list (s!:ad_name name) (list (cond ((equal ( +caddr name) (quote a)) (quote car)) (t (quote cdr))) (cadr x)))) (return ( +s!:comval x env context)))) + +(put (quote caaar) (quote s!:compfn) (function s!:comcarcdr3)) + +(put (quote caadr) (quote s!:compfn) (function s!:comcarcdr3)) + +(put (quote cadar) (quote s!:compfn) (function s!:comcarcdr3)) + +(put (quote caddr) (quote s!:compfn) (function s!:comcarcdr3)) + +(put (quote cdaar) (quote s!:compfn) (function s!:comcarcdr3)) + +(put (quote cdadr) (quote s!:compfn) (function s!:comcarcdr3)) + +(put (quote cddar) (quote s!:compfn) (function s!:comcarcdr3)) + +(put (quote cdddr) (quote s!:compfn) (function s!:comcarcdr3)) + +(de s!:comcarcdr4 (x env context) (prog (name outer c1 c2) (setq name (cdr ( +explode2 (car x)))) (setq x (list (s!:ad_name name) (list (s!:ad_name (cddr +name)) (cadr x)))) (return (s!:comval x env context)))) + +(put (quote caaaar) (quote s!:compfn) (function s!:comcarcdr4)) + +(put (quote caaadr) (quote s!:compfn) (function s!:comcarcdr4)) + +(put (quote caadar) (quote s!:compfn) (function s!:comcarcdr4)) + +(put (quote caaddr) (quote s!:compfn) (function s!:comcarcdr4)) + +(put (quote cadaar) (quote s!:compfn) (function s!:comcarcdr4)) + +(put (quote cadadr) (quote s!:compfn) (function s!:comcarcdr4)) + +(put (quote caddar) (quote s!:compfn) (function s!:comcarcdr4)) + +(put (quote cadddr) (quote s!:compfn) (function s!:comcarcdr4)) + +(put (quote cdaaar) (quote s!:compfn) (function s!:comcarcdr4)) + +(put (quote cdaadr) (quote s!:compfn) (function s!:comcarcdr4)) + +(put (quote cdadar) (quote s!:compfn) (function s!:comcarcdr4)) + +(put (quote cdaddr) (quote s!:compfn) (function s!:comcarcdr4)) + +(put (quote cddaar) (quote s!:compfn) (function s!:comcarcdr4)) + +(put (quote cddadr) (quote s!:compfn) (function s!:comcarcdr4)) + +(put (quote cdddar) (quote s!:compfn) (function s!:comcarcdr4)) + +(put (quote cddddr) (quote s!:compfn) (function s!:comcarcdr4)) + +(de s!:comgetv (x env context) (cond (!*carcheckflag (s!:comcall x env +context)) (t (s!:comval (cons (quote qgetv) (cdr x)) env context)))) + +(put (quote getv) (quote s!:compfn) (function s!:comgetv)) + +(de s!:comqgetv (x env context) (cond ((and (fixp (caddr x)) (geq (caddr x) 0 +) (lessp (caddr x) 256)) (progn (s!:comval (cadr x) env 1) (s!:outopcode1 ( +quote QGETVN) (caddr x) (caddr x)))) (t (s!:comcall x env context)))) + +(put (quote qgetv) (quote s!:compfn) (function s!:comqgetv)) + +(de s!:comget (x env context) (prog (a b c w) (setq a (cadr x)) (setq b ( +caddr x)) (setq c (cdddr x)) (cond ((eqcar b (quote quote)) (progn (setq b ( +cadr b)) (setq w (symbol!-make!-fastget b nil)) (cond (c (progn (cond (w ( +progn (cond ((s!:load2 a b env) (s!:outopcode0 (quote SWOP) (quote (SWOP))))) +(s!:outopcode1 (quote FASTGET) (logor w 64) b))) (t (s!:comcall x env +context))))) (t (progn (s!:comval a env 1) (cond (w (s!:outopcode1 (quote +FASTGET) w b)) (t (s!:outopcode1lit (quote LITGET) b env)))))))) (t ( +s!:comcall x env context))))) + +(put (quote get) (quote s!:compfn) (function s!:comget)) + +(de s!:comflagp (x env context) (prog (a b) (setq a (cadr x)) (setq b (caddr +x)) (cond ((eqcar b (quote quote)) (progn (setq b (cadr b)) (s!:comval a env +1) (setq a (symbol!-make!-fastget b nil)) (cond (a (s!:outopcode1 (quote +FASTGET) (logor a 128) b)) (t (s!:comcall x env context))))) (t (s!:comcall x +env context))))) + +(put (quote flagp) (quote s!:compfn) (function s!:comflagp)) + +(de s!:complus (x env context) (s!:comval (expand (cdr x) (quote plus2)) env +context)) + +(put (quote plus) (quote s!:compfn) (function s!:complus)) + +(de s!:comtimes (x env context) (s!:comval (expand (cdr x) (quote times2)) +env context)) + +(put (quote times) (quote s!:compfn) (function s!:comtimes)) + +(de s!:comiplus (x env context) (s!:comval (expand (cdr x) (quote iplus2)) +env context)) + +(put (quote iplus) (quote s!:compfn) (function s!:comiplus)) + +(de s!:comitimes (x env context) (s!:comval (expand (cdr x) (quote itimes2)) +env context)) + +(put (quote itimes) (quote s!:compfn) (function s!:comitimes)) + +(de s!:complus2 (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( +setq b (s!:improve (caddr x))) (return (cond ((and (numberp a) (numberp b)) ( +s!:comval (plus a b) env context)) (t (cond ((equal a 0) (s!:comval b env +context)) (t (cond ((equal a 1) (s!:comval (list (quote add1) b) env context) +) (t (cond ((equal b 0) (s!:comval a env context)) (t (cond ((equal b 1) ( +s!:comval (list (quote add1) a) env context)) (t (cond ((equal b (minus 1)) ( +s!:comval (list (quote sub1) a) env context)) (t (s!:comcall x env context))) +))))))))))))) + +(put (quote plus2) (quote s!:compfn) (function s!:complus2)) + +(de s!:comdifference (x env context) (prog (a b) (setq a (s!:improve (cadr x) +)) (setq b (s!:improve (caddr x))) (return (cond ((and (numberp a) (numberp b +)) (s!:comval (difference a b) env context)) (t (cond ((equal a 0) (s!:comval +(list (quote minus) b) env context)) (t (cond ((equal b 0) (s!:comval a env +context)) (t (cond ((equal b 1) (s!:comval (list (quote sub1) a) env context) +) (t (cond ((equal b (minus 1)) (s!:comval (list (quote add1) a) env context) +) (t (s!:comcall x env context)))))))))))))) + +(put (quote difference) (quote s!:compfn) (function s!:comdifference)) + +(de s!:comiplus2 (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( +setq b (s!:improve (caddr x))) (return (cond ((and (numberp a) (numberp b)) ( +s!:comval (plus a b) env context)) (t (cond ((equal a 1) (s!:comval (list ( +quote iadd1) b) env context)) (t (cond ((equal b 1) (s!:comval (list (quote +iadd1) a) env context)) (t (cond ((equal b (minus 1)) (s!:comval (list (quote +isub1) a) env context)) (t (s!:comcall x env context)))))))))))) + +(put (quote iplus2) (quote s!:compfn) (function s!:comiplus2)) + +(de s!:comidifference (x env context) (prog (a b) (setq a (s!:improve (cadr x +))) (setq b (s!:improve (caddr x))) (return (cond ((and (numberp a) (numberp +b)) (s!:comval (difference a b) env context)) (t (cond ((equal b 1) ( +s!:comval (list (quote isub1) a) env context)) (t (cond ((equal b (minus 1)) +(s!:comval (list (quote iadd1) a) env context)) (t (s!:comcall x env context) +))))))))) + +(put (quote idifference) (quote s!:compfn) (function s!:comidifference)) + +(de s!:comtimes2 (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( +setq b (s!:improve (caddr x))) (return (cond ((and (numberp a) (numberp b)) ( +s!:comval (times a b) env context)) (t (cond ((equal a 1) (s!:comval b env +context)) (t (cond ((equal a (minus 1)) (s!:comval (list (quote minus) b) env +context)) (t (cond ((equal b 1) (s!:comval a env context)) (t (cond ((equal +b (minus 1)) (s!:comval (list (quote minus) a) env context)) (t (s!:comcall x +env context)))))))))))))) + +(put (quote times2) (quote s!:compfn) (function s!:comtimes2)) + +(put (quote itimes2) (quote s!:compfn) (function s!:comtimes2)) + +(de s!:comminus (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( +return (cond ((numberp a) (s!:comval (minus a) env context)) (t (cond ((eqcar +a (quote minus)) (s!:comval (cadr a) env context)) (t (s!:comcall x env +context)))))))) + +(put (quote minus) (quote s!:compfn) (function s!:comminus)) + +(de s!:comminusp (x env context) (prog (a) (setq a (s!:improve (cadr x))) ( +cond ((eqcar a (quote difference)) (return (s!:comval (cons (quote lessp) ( +cdr a)) env context))) (t (return (s!:comcall x env context)))))) + +(put (quote minusp) (quote s!:compfn) (function s!:comminusp)) + +(de s!:comlessp (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( +setq b (s!:improve (caddr x))) (cond ((equal b 0) (return (s!:comval (list ( +quote minusp) a) env context))) (t (return (s!:comcall x env context)))))) + +(put (quote lessp) (quote s!:compfn) (function s!:comlessp)) + +(de s!:comiminusp (x env context) (prog (a) (setq a (s!:improve (cadr x))) ( +cond ((eqcar a (quote difference)) (return (s!:comval (cons (quote ilessp) ( +cdr a)) env context))) (t (return (s!:comcall x env context)))))) + +(put (quote iminusp) (quote s!:compfn) (function s!:comiminusp)) + +(de s!:comilessp (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( +setq b (s!:improve (caddr x))) (cond ((equal b 0) (return (s!:comval (list ( +quote iminusp) a) env context))) (t (return (s!:comcall x env context)))))) + +(put (quote ilessp) (quote s!:compfn) (function s!:comilessp)) + +(de s!:comprogn (x env context) (progn (setq x (cdr x)) (cond ((null x) ( +s!:comval nil env context)) (t (prog (a) (setq a (car x)) (prog nil lab1085 ( +cond ((null (setq x (cdr x))) (return nil))) (progn (s!:comval a env (cond (( +geq context 4) context) (t 2))) (setq a (car x))) (go lab1085)) (s!:comval a +env context)))))) + +(put (quote progn) (quote s!:compfn) (function s!:comprogn)) + +(de s!:comprog1 (x env context) (prog nil (setq x (cdr x)) (cond ((null x) ( +return (s!:comval nil env context)))) (s!:comval (car x) env context) (cond ( +(null (setq x (cdr x))) (return nil))) (s!:outopcode0 (quote PUSH) (quote ( +PUSH))) (rplacd env (cons 0 (cdr env))) (prog (var1087) (setq var1087 x) +lab1086 (cond ((null var1087) (return nil))) (prog (a) (setq a (car var1087)) +(s!:comval a env (cond ((geq context 4) context) (t 2)))) (setq var1087 (cdr +var1087)) (go lab1086)) (s!:outopcode0 (quote POP) (quote (POP))) (rplacd +env (cddr env)))) + +(put (quote prog1) (quote s!:compfn) (function s!:comprog1)) + +(de s!:comprog2 (x env context) (prog (a) (setq x (cdr x)) (cond ((null x) ( +return (s!:comval nil env context)))) (setq a (car x)) (s!:comval a env (cond +((geq context 4) context) (t 2))) (s!:comprog1 x env context))) + +(put (quote prog2) (quote s!:compfn) (function s!:comprog2)) + +(de s!:outstack (n) (prog (w a) (setq w s!:current_block) (prog nil lab1088 ( +cond ((null (and w (not (atom (car w))))) (return nil))) (setq w (cdr w)) (go +lab1088)) (cond ((eqcar w (quote PUSHNIL)) (setq a 1)) (t (cond ((eqcar w ( +quote PUSHNIL2)) (setq a 2)) (t (cond ((eqcar w (quote PUSHNIL3)) (setq a 3)) +(t (cond ((and w (numberp (setq a (car w))) (not (equal a 255)) (eqcar (cdr +w) (quote PUSHNILS))) (progn (setq w (cdr w)) (setq s!:current_size ( +difference s!:current_size 1)))) (t (setq a nil))))))))) (cond (a (progn ( +setq s!:current_block (cdr w)) (setq s!:current_size (difference +s!:current_size 1)) (setq n (plus n a))))) (cond ((equal n 1) (s!:outopcode0 +(quote PUSHNIL) (quote (PUSHNIL)))) (t (cond ((equal n 2) (s!:outopcode0 ( +quote PUSHNIL2) (quote (PUSHNIL2)))) (t (cond ((equal n 3) (s!:outopcode0 ( +quote PUSHNIL3) (quote (PUSHNIL3)))) (t (cond ((greaterp n 255) (progn ( +s!:outopcode1 (quote PUSHNILS) 255 255) (s!:outstack (difference n 255)))) (t +(cond ((greaterp n 3) (s!:outopcode1 (quote PUSHNILS) n n))))))))))))) + +(de s!:outlose (n) (prog (w a) (setq w s!:current_block) (prog nil lab1089 ( +cond ((null (and w (not (atom (car w))))) (return nil))) (setq w (cdr w)) (go +lab1089)) (cond ((eqcar w (quote LOSE)) (setq a 1)) (t (cond ((eqcar w ( +quote LOSE2)) (setq a 2)) (t (cond ((eqcar w (quote LOSE3)) (setq a 3)) (t ( +cond ((and w (numberp (setq a (car w))) (not (equal a 255)) (eqcar (cdr w) ( +quote LOSES))) (progn (setq w (cdr w)) (setq s!:current_size (difference +s!:current_size 1)))) (t (setq a nil))))))))) (cond (a (progn (setq +s!:current_block (cdr w)) (setq s!:current_size (difference s!:current_size 1 +)) (setq n (plus n a))))) (cond ((equal n 1) (s!:outopcode0 (quote LOSE) ( +quote (LOSE)))) (t (cond ((equal n 2) (s!:outopcode0 (quote LOSE2) (quote ( +LOSE2)))) (t (cond ((equal n 3) (s!:outopcode0 (quote LOSE3) (quote (LOSE3))) +) (t (cond ((greaterp n 255) (progn (s!:outopcode1 (quote LOSES) 255 255) ( +s!:outlose (difference n 255)))) (t (cond ((greaterp n 3) (s!:outopcode1 ( +quote LOSES) n n))))))))))))) + +(de s!:comprog (x env context) (prog (labs s bvl fluids n body local_decs w) +(setq body (s!:find_local_decs (cddr x) t)) (setq local_decs (car body)) ( +setq body (cdr body)) (setq n 0) (prog (var1091) (setq var1091 (cadr x)) +lab1090 (cond ((null var1091) (return nil))) (prog (v) (setq v (car var1091)) +(setq w (s!:instate_local_decs v local_decs w))) (setq var1091 (cdr var1091) +) (go lab1090)) (prog (var1093) (setq var1093 (cadr x)) lab1092 (cond ((null +var1093) (return nil))) (prog (v) (setq v (car var1093)) (progn (cond (( +globalp v) (progn (cond (!*pwrds (progn (cond ((neq (posn) 0) (terpri))) ( +princ "+++++ global ") (prin v) (princ " converted to fluid") (terpri)))) ( +unglobal (list v)) (fluid (list v))))) (cond ((fluidp v) (setq fluids (cons v +fluids))) (t (progn (setq n (plus n 1)) (setq bvl (cons v bvl))))))) (setq +var1093 (cdr var1093)) (go lab1092)) (setq s (cdr env)) (setq +s!:current_exitlab (cons (cons nil (cons (gensym) s)) s!:current_exitlab)) ( +s!:outstack n) (rplacd env (append bvl (cdr env))) (cond (fluids (prog (fl1) +(setq fl1 (s!:vecof fluids)) (s!:outopcode1lit (quote FREEBIND) fl1 env) ( +prog (var1095) (setq var1095 (cons nil fluids)) lab1094 (cond ((null var1095) +(return nil))) (prog (v) (setq v (car var1095)) (rplacd env (cons 0 (cdr env +)))) (setq var1095 (cdr var1095)) (go lab1094)) (rplacd env (cons (plus 2 ( +length fluids)) (cdr env))) (cond ((equal context 0) (setq context 1)))))) ( +prog (var1097) (setq var1097 body) lab1096 (cond ((null var1097) (return nil) +)) (prog (a) (setq a (car var1097)) (cond ((atom a) (progn (cond ((atsoc a +labs) (progn (cond ((not (null a)) (progn (cond ((neq (posn) 0) (terpri))) ( +princ "+++++ label ") (prin a) (princ " multiply defined") (terpri)))))) (t ( +setq labs (cons (cons a (cons (cons (gensym) (cdr env)) nil)) labs)))))))) ( +setq var1097 (cdr var1097)) (go lab1096)) (setq s!:current_proglabels (cons +labs s!:current_proglabels)) (setq w (s!:residual_local_decs local_decs w)) ( +prog (var1099) (setq var1099 body) lab1098 (cond ((null var1099) (return nil) +)) (prog (a) (setq a (car var1099)) (cond ((not (atom a)) (s!:comval a env ( +plus context 4))) (t (prog (d) (setq d (atsoc a labs)) (cond ((null (cddr d)) +(progn (rplacd (cdr d) t) (s!:set_label (caadr d))))))))) (setq var1099 (cdr +var1099)) (go lab1098)) (s!:cancel_local_decs w) (s!:comval nil env context) +(cond (fluids (s!:outopcode0 (quote FREERSTR) (quote (FREERSTR))))) ( +s!:outlose n) (rplacd env s) (s!:set_label (cadar s!:current_exitlab)) (setq +s!:current_exitlab (cdr s!:current_exitlab)) (setq s!:current_proglabels (cdr +s!:current_proglabels)))) + +(put (quote prog) (quote s!:compfn) (function s!:comprog)) + +(de s!:comtagbody (x env context) (prog (labs) (prog (var1101) (setq var1101 +(cdr x)) lab1100 (cond ((null var1101) (return nil))) (prog (a) (setq a (car +var1101)) (cond ((atom a) (progn (cond ((atsoc a labs) (progn (cond ((not ( +null a)) (progn (cond ((neq (posn) 0) (terpri))) (princ "+++++ label ") (prin +a) (princ " multiply defined") (terpri)))))) (t (setq labs (cons (cons a ( +cons (cons (gensym) (cdr env)) nil)) labs)))))))) (setq var1101 (cdr var1101) +) (go lab1100)) (setq s!:current_proglabels (cons labs s!:current_proglabels) +) (prog (var1103) (setq var1103 (cdr x)) lab1102 (cond ((null var1103) ( +return nil))) (prog (a) (setq a (car var1103)) (cond ((not (atom a)) ( +s!:comval a env (plus context 4))) (t (prog (d) (setq d (atsoc a labs)) (cond +((null (cddr d)) (progn (rplacd (cdr d) t) (s!:set_label (caadr d))))))))) ( +setq var1103 (cdr var1103)) (go lab1102)) (s!:comval nil env context) (setq +s!:current_proglabels (cdr s!:current_proglabels)))) + +(put (quote tagbody) (quote s!:compfn) (function s!:comtagbody)) + +(de s!:comblock (x env context) (prog nil (setq s!:current_exitlab (cons ( +cons (cadr x) (cons (gensym) (cdr env))) s!:current_exitlab)) (s!:comval ( +cons (quote progn) (cddr x)) env context) (s!:set_label (cadar +s!:current_exitlab)) (setq s!:current_exitlab (cdr s!:current_exitlab)))) + +(put (quote !~block) (quote s!:compfn) (function s!:comblock)) + +(de s!:comcatch (x env context) (prog (g) (setq g (gensym)) (s!:comval (cadr +x) env 1) (s!:outjump (quote CATCH) g) (rplacd env (cons (quote (catch)) ( +cons 0 (cons 0 (cdr env))))) (s!:comval (cons (quote progn) (cddr x)) env +context) (s!:outopcode0 (quote UNCATCH) (quote (UNCATCH))) (rplacd env ( +cddddr env)) (s!:set_label g))) + +(put (quote catch) (quote s!:compfn) (quote s!:comcatch)) + +(de s!:comthrow (x env context) (prog nil (s!:comval (cadr x) env 1) ( +s!:outopcode0 (quote PUSH) (quote (PUSH))) (rplacd env (cons 0 (cdr env))) ( +s!:comval (caddr x) env 1) (s!:outopcode0 (quote THROW) (quote (THROW))) ( +rplacd env (cddr env)))) + +(put (quote throw) (quote s!:compfn) (quote s!:comthrow)) + +(de s!:comunwind!-protect (x env context) (prog (g) (setq g (gensym)) ( +s!:comval (quote (load!-spid)) env 1) (s!:outjump (quote CATCH) g) (rplacd +env (cons (list (quote unwind!-protect) (cddr x)) (cons 0 (cons 0 (cdr env))) +)) (s!:comval (cadr x) env context) (s!:outopcode0 (quote PROTECT) (quote ( +PROTECT))) (s!:set_label g) (rplaca (cdr env) 0) (s!:comval (cons (quote +progn) (cddr x)) env context) (s!:outopcode0 (quote UNPROTECT) (quote ( +UNPROTECT))) (rplacd env (cddddr env)))) + +(put (quote unwind!-protect) (quote s!:compfn) (quote s!:comunwind!-protect)) + +(de s!:comdeclare (x env context) (prog nil (cond (!*pwrds (progn (princ +"+++ ") (prin x) (princ " ignored") (terpri)))))) + +(put (quote declare) (quote s!:compfn) (function s!:comdeclare)) + +(de s!:expand_let (vl b) (prog (vars vals) (prog (var1105) (setq var1105 vl) +lab1104 (cond ((null var1105) (return nil))) (prog (v) (setq v (car var1105)) +(cond ((atom v) (progn (setq vars (cons v vars)) (setq vals (cons nil vals)) +)) (t (cond ((atom (cdr v)) (progn (setq vars (cons (car v) vars)) (setq vals +(cons nil vals)))) (t (progn (setq vars (cons (car v) vars)) (setq vals ( +cons (cadr v) vals)))))))) (setq var1105 (cdr var1105)) (go lab1104)) (return +(list (cons (cons (quote lambda) (cons vars b)) vals))))) + +(de s!:comlet (x env context) (s!:comval (cons (quote progn) (s!:expand_let ( +cadr x) (cddr x))) env context)) + +(put (quote !~let) (quote s!:compfn) (function s!:comlet)) + +(de s!:expand_let!* (vl local_decs b) (prog (r var val) (setq r (cons (cons ( +quote declare) local_decs) b)) (prog (var1109) (setq var1109 (reverse vl)) +lab1108 (cond ((null var1109) (return nil))) (prog (x) (setq x (car var1109)) +(progn (setq val nil) (cond ((atom x) (setq var x)) (t (cond ((atom (cdr x)) +(setq var (car x))) (t (progn (setq var (car x)) (setq val (cadr x))))))) ( +prog (var1107) (setq var1107 local_decs) lab1106 (cond ((null var1107) ( +return nil))) (prog (z) (setq z (car var1107)) (cond ((eqcar z (quote special +)) (cond ((memq var (cdr z)) (setq r (cons (list (quote declare) (list (quote +special) var)) r))))))) (setq var1107 (cdr var1107)) (go lab1106)) (setq r ( +list (list (cons (quote lambda) (cons (list var) r)) val))))) (setq var1109 ( +cdr var1109)) (go lab1108)) (cond ((eqcar (car r) (quote declare)) (setq r ( +list (cons (quote lambda) (cons nil r))))) (t (setq r (cons (quote progn) r)) +)) (return r))) + +(de s!:comlet!* (x env context) (prog (b) (setq b (s!:find_local_decs (cddr x +) nil)) (return (s!:comval (s!:expand_let!* (cadr x) (car b) (cdr b)) env +context)))) + +(put (quote let!*) (quote s!:compfn) (function s!:comlet!*)) + +(de s!:restore_stack (e1 e2) (prog (n) (setq n 0) (prog nil lab1111 (cond (( +null (not (equal e1 e2))) (return nil))) (progn (cond ((null e1) (error 0 +"bad block nesting with GO or RETURN-FROM"))) (cond ((and (numberp (car e1)) +(greaterp (car e1) 2)) (progn (cond ((not (zerop n)) (s!:outlose n))) (setq n +(car e1)) (s!:outopcode0 (quote FREERSTR) (quote (FREERSTR))) (prog (i) ( +setq i 1) lab1110 (cond ((minusp (times 1 (difference n i))) (return nil))) ( +setq e1 (cdr e1)) (setq i (plus i 1)) (go lab1110)) (setq n 0))) (t (cond (( +equal (car e1) (quote (catch))) (progn (cond ((not (zerop n)) (s!:outlose n)) +) (s!:outopcode0 (quote UNCATCH) (quote (UNCATCH))) (setq e1 (cdddr e1)) ( +setq n 0))) (t (cond ((eqcar (car e1) (quote unwind!-protect)) (progn (cond ( +(not (zerop n)) (s!:outlose n))) (s!:outopcode0 (quote PROTECT) (quote ( +PROTECT))) (s!:comval (cons (quote progn) (cadar e1)) e1 2) (s!:outopcode0 ( +quote UNPROTECT) (quote (UNPROTECT))) (setq e1 (cdddr e1)) (setq n 0))) (t ( +progn (setq e1 (cdr e1)) (setq n (plus n 1)))))))))) (go lab1111)) (cond (( +not (zerop n)) (s!:outlose n))))) + +(de s!:comgo (x env context) (prog (pl d) (cond ((lessp context 4) (progn ( +princ "go not in program context") (terpri)))) (setq pl s!:current_proglabels +) (prog nil lab1112 (cond ((null (and pl (null d))) (return nil))) (progn ( +setq d (atsoc (cadr x) (car pl))) (cond ((null d) (setq pl (cdr pl))))) (go +lab1112)) (cond ((null d) (progn (cond ((neq (posn) 0) (terpri))) (princ +"+++++ label ") (prin (cadr x)) (princ " not set") (terpri) (return nil)))) ( +setq d (cadr d)) (s!:restore_stack (cdr env) (cdr d)) (s!:outjump (quote JUMP +) (car d)))) + +(put (quote go) (quote s!:compfn) (function s!:comgo)) + +(de s!:comreturn!-from (x env context) (prog (tag) (cond ((lessp context 4) ( +progn (princ "+++++ return or return-from not in prog context") (terpri)))) ( +setq x (cdr x)) (setq tag (car x)) (cond ((cdr x) (setq x (cadr x))) (t (setq +x nil))) (s!:comval x env (difference context 4)) (setq x (atsoc tag +s!:current_exitlab)) (cond ((null x) (error 0 (list "invalid return-from" tag +)))) (setq x (cdr x)) (s!:restore_stack (cdr env) (cdr x)) (s!:outjump (quote +JUMP) (car x)))) + +(put (quote return!-from) (quote s!:compfn) (function s!:comreturn!-from)) + +(de s!:comreturn (x env context) (s!:comreturn!-from (cons (quote +return!-from) (cons nil (cdr x))) env context)) + +(put (quote return) (quote s!:compfn) (function s!:comreturn)) + +(global (quote (s!:jumplts s!:jumplnils s!:jumpatoms s!:jumpnatoms))) + +(setq s!:jumplts (s!:vecof (quote (JUMPL0T JUMPL1T JUMPL2T JUMPL3T JUMPL4T))) +) + +(setq s!:jumplnils (s!:vecof (quote (JUMPL0NIL JUMPL1NIL JUMPL2NIL JUMPL3NIL +JUMPL4NIL)))) + +(setq s!:jumpatoms (s!:vecof (quote (JUMPL0ATOM JUMPL1ATOM JUMPL2ATOM +JUMPL3ATOM)))) + +(setq s!:jumpnatoms (s!:vecof (quote (JUMPL0NATOM JUMPL1NATOM JUMPL2NATOM +JUMPL3NATOM)))) + +(de s!:jumpif (neg x env lab) (prog (w w1 j) top (cond ((null x) (progn (cond +((not neg) (s!:outjump (quote JUMP) lab))) (return nil))) (t (cond ((or (eq +x t) (and (eqcar x (quote quote)) (cadr x)) (and (atom x) (not (symbolp x)))) +(progn (cond (neg (s!:outjump (quote JUMP) lab))) (return nil))) (t (cond (( +lessp (setq w (s!:islocal x env)) 5) (return (s!:outjump (getv (cond (neg +s!:jumplts) (t s!:jumplnils)) w) lab))) (t (cond ((and (equal w 99999) ( +symbolp x)) (progn (s!:should_be_fluid x) (setq w (list (cond (neg (quote +JUMPFREET)) (t (quote JUMPFREENIL))) x x)) (return ( +s!:record_literal_for_jump w env lab))))))))))) (cond ((and (not (atom x)) ( +atom (car x)) (setq w (get (car x) (quote s!:testfn)))) (return (funcall w +neg x env lab)))) (cond ((not (atom x)) (progn (setq w (s!:improve x)) (cond +((or (atom w) (not (eqcar x (car w)))) (progn (setq x w) (go top)))) (cond (( +and (setq w1 (get (car w) (quote s!:compilermacro))) (setq w1 (funcall w1 w +env 1))) (progn (setq x w1) (go top))))))) remacro (cond ((and (not (atom w)) +(setq w1 (macro!-function (car w)))) (progn (setq w (funcall w1 w)) (cond (( +or (atom w) (eqcar w (quote quote)) (get (car w) (quote s!:testfn)) (get (car +w) (quote s!:compilermacro))) (progn (setq x w) (go top)))) (go remacro)))) +(s!:comval x env 1) (setq w s!:current_block) (prog nil lab1113 (cond ((null +(and w (not (atom (car w))))) (return nil))) (setq w (cdr w)) (go lab1113)) ( +setq j (quote (JUMPNIL . JUMPT))) (cond (w (progn (setq w1 (car w)) (setq w ( +cdr w)) (cond ((equal w1 (quote STORELOC0)) (progn (setq s!:current_block w) +(setq s!:current_size (difference s!:current_size 1)) (setq j (quote ( +JUMPST0NIL . JUMPST0T))))) (t (cond ((equal w1 (quote STORELOC1)) (progn ( +setq s!:current_block w) (setq s!:current_size (difference s!:current_size 1) +) (setq j (quote (JUMPST1NIL . JUMPST1T))))) (t (cond ((equal w1 (quote +STORELOC2)) (progn (setq s!:current_block w) (setq s!:current_size ( +difference s!:current_size 1)) (setq j (quote (JUMPST2NIL . JUMPST2T))))) (t +(cond ((eqcar w (quote BUILTIN1)) (progn (setq s!:current_block (cdr w)) ( +setq s!:current_size (difference s!:current_size 2)) (setq j (cons (list ( +quote JUMPB1NIL) w1) (list (quote JUMPB1T) w1))))) (t (cond ((eqcar w (quote +BUILTIN2)) (progn (setq s!:current_block (cdr w)) (setq s!:current_size ( +difference s!:current_size 2)) (setq j (cons (list (quote JUMPB2NIL) w1) ( +list (quote JUMPB2T) w1))))))))))))))))) (return (s!:outjump (cond (neg (cdr +j)) (t (car j))) lab)))) + +(de s!:testnot (neg x env lab) (s!:jumpif (not neg) (cadr x) env lab)) + +(put (quote null) (quote s!:testfn) (function s!:testnot)) + +(put (quote not) (quote s!:testfn) (function s!:testnot)) + +(de s!:testatom (neg x env lab) (prog (w) (cond ((lessp (setq w (s!:islocal ( +cadr x) env)) 4) (return (s!:outjump (getv (cond (neg s!:jumpatoms) (t +s!:jumpnatoms)) w) lab)))) (s!:comval (cadr x) env 1) (cond (neg (s!:outjump +(quote JUMPATOM) lab)) (t (s!:outjump (quote JUMPNATOM) lab))))) + +(put (quote atom) (quote s!:testfn) (function s!:testatom)) + +(de s!:testconsp (neg x env lab) (prog (w) (cond ((lessp (setq w (s!:islocal +(cadr x) env)) 4) (return (s!:outjump (getv (cond (neg s!:jumpnatoms) (t +s!:jumpatoms)) w) lab)))) (s!:comval (cadr x) env 1) (cond (neg (s!:outjump ( +quote JUMPNATOM) lab)) (t (s!:outjump (quote JUMPATOM) lab))))) + +(put (quote consp) (quote s!:testfn) (function s!:testconsp)) + +(de s!:comcond (x env context) (prog (l1 l2 w) (setq l1 (gensym)) (prog nil +lab1114 (cond ((null (setq x (cdr x))) (return nil))) (progn (setq w (car x)) +(cond ((atom (cdr w)) (progn (s!:comval (car w) env 1) (s!:outjump (quote +JUMPT) l1) (setq l2 nil))) (t (progn (cond ((equal (car w) t) (setq l2 nil)) +(t (progn (setq l2 (gensym)) (s!:jumpif nil (car w) env l2)))) (setq w (cdr w +)) (cond ((null (cdr w)) (setq w (car w))) (t (setq w (cons (quote progn) w)) +)) (s!:comval w env context) (cond (l2 (progn (s!:outjump (quote JUMP) l1) ( +s!:set_label l2))) (t (setq x (quote (nil))))))))) (go lab1114)) (cond (l2 ( +s!:comval nil env context))) (s!:set_label l1))) + +(put (quote cond) (quote s!:compfn) (function s!:comcond)) + +(de s!:comif (x env context) (prog (l1 l2) (setq l2 (gensym)) (s!:jumpif nil +(cadr x) env l2) (setq x (cddr x)) (s!:comval (car x) env context) (setq x ( +cdr x)) (cond ((or x (and (lessp context 2) (setq x (quote (nil))))) (progn ( +setq l1 (gensym)) (s!:outjump (quote JUMP) l1) (s!:set_label l2) (s!:comval ( +car x) env context) (s!:set_label l1))) (t (s!:set_label l2))))) + +(put (quote if) (quote s!:compfn) (function s!:comif)) + +(de s!:comwhen (x env context) (prog (l2) (setq l2 (gensym)) (cond ((lessp +context 2) (progn (s!:comval (cadr x) env 1) (s!:outjump (quote JUMPNIL) l2)) +) (t (s!:jumpif nil (cadr x) env l2))) (s!:comval (cons (quote progn) (cddr x +)) env context) (s!:set_label l2))) + +(put (quote when) (quote s!:compfn) (function s!:comwhen)) + +(de s!:comunless (x env context) (s!:comwhen (list!* (quote when) (list ( +quote not) (cadr x)) (cddr x)) env context)) + +(put (quote unless) (quote s!:compfn) (function s!:comunless)) + +(de s!:comicase (x env context) (prog (l1 labs labassoc w) (setq x (cdr x)) ( +prog (var1116) (setq var1116 (cdr x)) lab1115 (cond ((null var1116) (return +nil))) (prog (v) (setq v (car var1116)) (progn (setq w (assoc!*!* v labassoc) +) (cond (w (setq l1 (cons (cdr w) l1))) (t (progn (setq l1 (gensym)) (setq +labs (cons l1 labs)) (setq labassoc (cons (cons v l1) labassoc))))))) (setq +var1116 (cdr var1116)) (go lab1115)) (s!:comval (car x) env 1) (s!:outjump ( +quote ICASE) (reversip labs)) (setq l1 (gensym)) (prog (var1118) (setq +var1118 labassoc) lab1117 (cond ((null var1118) (return nil))) (prog (v) ( +setq v (car var1118)) (progn (s!:set_label (cdr v)) (s!:comval (car v) env +context) (s!:outjump (quote JUMP) l1))) (setq var1118 (cdr var1118)) (go +lab1117)) (s!:set_label l1))) + +(put (quote s!:icase) (quote s!:compfn) (function s!:comicase)) + +(put (quote JUMPLITEQ!*) (quote s!:opcode) (get (quote JUMPLITEQ) (quote +s!:opcode))) + +(put (quote JUMPLITNE!*) (quote s!:opcode) (get (quote JUMPLITNE) (quote +s!:opcode))) + +(de s!:jumpliteql (val lab env) (prog (w) (cond ((or (idp val) (eq!-safe val) +) (progn (setq w (list (quote JUMPLITEQ!*) val val)) ( +s!:record_literal_for_jump w env lab))) (t (progn (s!:outopcode0 (quote PUSH) +(quote (PUSH))) (s!:loadliteral val env) (s!:outopcode1 (quote BUILTIN2) ( +get (quote eql) (quote s!:builtin2)) (quote eql)) (s!:outjump (quote JUMPT) +lab) (flag (list lab) (quote s!:jumpliteql)) (s!:outopcode0 (quote POP) ( +quote (POP)))))))) + +(de s!:casebranch (sw env dflt) (prog (size w w1 r g) (setq size (plus 4 ( +truncate (length sw) 2))) (prog nil lab1119 (cond ((null (or (equal ( +remainder size 2) 0) (equal (remainder size 3) 0) (equal (remainder size 5) 0 +) (equal (remainder size 13) 0))) (return nil))) (setq size (plus size 1)) ( +go lab1119)) (prog (var1121) (setq var1121 sw) lab1120 (cond ((null var1121) +(return nil))) (prog (p) (setq p (car var1121)) (progn (setq w (remainder ( +eqlhash (car p)) size)) (setq w1 (assoc!*!* w r)) (cond (w1 (rplacd (cdr w1) +(cons p (cddr w1)))) (t (setq r (cons (list w (gensym) p) r)))))) (setq +var1121 (cdr var1121)) (go lab1120)) (s!:outopcode0 (quote PUSH) (quote (PUSH +))) (rplacd env (cons 0 (cdr env))) (s!:outopcode1lit (quote CALL1) (quote +eqlhash) env) (s!:loadliteral size env) (setq g (gensym)) (s!:outopcode1 ( +quote BUILTIN2) (get (quote iremainder) (quote s!:builtin2)) (quote +iremainder)) (s!:outjump (quote ICASE) (cons g (prog (i var1123) (setq i 0) +lab1122 (cond ((minusp (times 1 (difference (difference size 1) i))) (return +(reversip var1123)))) (setq var1123 (cons (progn (setq w (assoc!*!* i r)) ( +cond (w (cadr w)) (t g))) var1123)) (setq i (plus i 1)) (go lab1122)))) (prog +(var1127) (setq var1127 r) lab1126 (cond ((null var1127) (return nil))) ( +prog (p) (setq p (car var1127)) (progn (s!:set_label (cadr p)) (s!:outopcode0 +(quote POP) (quote (POP))) (prog (var1125) (setq var1125 (cddr p)) lab1124 ( +cond ((null var1125) (return nil))) (prog (q) (setq q (car var1125)) ( +s!:jumpliteql (car q) (cdr q) env)) (setq var1125 (cdr var1125)) (go lab1124) +) (s!:outjump (quote JUMP) dflt))) (setq var1127 (cdr var1127)) (go lab1126)) +(s!:set_label g) (s!:outopcode0 (quote POP) (quote (POP))) (s!:outjump ( +quote JUMP) dflt) (rplacd env (cddr env)))) + +(de s!:comcase (x env context) (prog (keyform blocks v w g dflt sw keys +nonnum) (setq x (cdr x)) (setq keyform (car x)) (prog (y) (setq y (cdr x)) +lab1130 (cond ((null y) (return nil))) (progn (setq w (assoc!*!* (cdar y) +blocks)) (cond (w (setq g (cdr w))) (t (progn (setq g (gensym)) (setq blocks +(cons (cons (cdar y) g) blocks))))) (setq w (caar y)) (cond ((and (null (cdr +y)) (or (equal w t) (equal w (quote otherwise)))) (setq dflt g)) (t (progn ( +cond ((atom w) (setq w (list w)))) (prog (var1129) (setq var1129 w) lab1128 ( +cond ((null var1129) (return nil))) (prog (n) (setq n (car var1129)) (progn ( +cond ((or (idp n) (numberp n)) (progn (cond ((not (fixp n)) (setq nonnum t))) +(setq keys (cons n keys)) (setq sw (cons (cons n g) sw)))) (t (error 0 (list +"illegal case label" n)))))) (setq var1129 (cdr var1129)) (go lab1128)))))) +(setq y (cdr y)) (go lab1130)) (cond ((null dflt) (progn (cond ((setq w ( +assoc!*!* nil blocks)) (setq dflt (cdr w))) (t (setq blocks (cons (cons nil ( +setq dflt (gensym))) blocks))))))) (cond ((not nonnum) (progn (setq keys ( +sort keys (function lessp))) (setq nonnum (car keys)) (setq g (lastcar keys)) +(cond ((lessp (difference g nonnum) (times 2 (length keys))) (progn (cond (( +not (equal nonnum 0)) (progn (setq keyform (list (quote xdifference) keyform +nonnum)) (setq sw (prog (var1132 var1133) (setq var1132 sw) lab1131 (cond (( +null var1132) (return (reversip var1133)))) (prog (y) (setq y (car var1132)) +(setq var1133 (cons (cons (difference (car y) nonnum) (cdr y)) var1133))) ( +setq var1132 (cdr var1132)) (go lab1131)))))) (s!:comval keyform env 1) (setq +w nil) (prog (i) (setq i 0) lab1134 (cond ((minusp (times 1 (difference g i) +)) (return nil))) (cond ((setq v (assoc!*!* i sw)) (setq w (cons (cdr v) w))) +(t (setq w (cons dflt w)))) (setq i (plus i 1)) (go lab1134)) (setq w (cons +dflt (reversip w))) (s!:outjump (quote ICASE) w) (setq nonnum nil))) (t (setq +nonnum t)))))) (cond (nonnum (progn (s!:comval keyform env 1) (cond ((lessp +(length sw) 7) (progn (prog (var1136) (setq var1136 sw) lab1135 (cond ((null +var1136) (return nil))) (prog (y) (setq y (car var1136)) (s!:jumpliteql (car +y) (cdr y) env)) (setq var1136 (cdr var1136)) (go lab1135)) (s!:outjump ( +quote JUMP) dflt))) (t (s!:casebranch sw env dflt)))))) (setq g (gensym)) ( +prog (var1138) (setq var1138 blocks) lab1137 (cond ((null var1138) (return +nil))) (prog (v) (setq v (car var1138)) (progn (s!:set_label (cdr v)) (cond ( +(flagp (cdr v) (quote s!:jumpliteql)) (s!:outlose 1))) (s!:comval (cons ( +quote progn) (car v)) env context) (s!:outjump (quote JUMP) g))) (setq +var1138 (cdr var1138)) (go lab1137)) (s!:set_label g))) + +(put (quote case) (quote s!:compfn) (function s!:comcase)) + +(fluid (quote (!*defn dfprint!* s!:dfprintsave s!:faslmod_name))) + +(de s!:comeval!-when (x env context) (prog (y) (setq x (cdr x)) (setq y (car +x)) (princ "COMPILING eval-when: ") (print y) (print x) (setq x (cons (quote +progn) (cdr x))) (cond ((memq (quote compile) y) (eval x))) (cond ((memq ( +quote load) y) (progn (cond (dfprint!* (apply1 dfprint!* x)))))) (cond ((memq +(quote eval) y) (s!:comval x env context)) (t (s!:comval nil env context)))) +) + +(put (quote eval!-when) (quote s!:compfn) (function s!:comeval!-when)) + +(de s!:comthe (x env context) (s!:comval (caddr x) env context)) + +(put (quote the) (quote s!:compfn) (function s!:comthe)) + +(de s!:comand (x env context) (prog (l) (setq l (gensym)) (setq x (cdr x)) ( +s!:comval (car x) env 1) (prog nil lab1139 (cond ((null (setq x (cdr x))) ( +return nil))) (progn (s!:outjump (quote JUMPNIL) l) (s!:comval (car x) env 1) +) (go lab1139)) (s!:set_label l))) + +(put (quote and) (quote s!:compfn) (function s!:comand)) + +(de s!:comor (x env context) (prog (l) (setq l (gensym)) (setq x (cdr x)) ( +s!:comval (car x) env 1) (prog nil lab1140 (cond ((null (setq x (cdr x))) ( +return nil))) (progn (s!:outjump (quote JUMPT) l) (s!:comval (car x) env 1)) +(go lab1140)) (s!:set_label l))) + +(put (quote or) (quote s!:compfn) (function s!:comor)) + +(de s!:combool (neg x env lab) (prog (fn) (setq fn (eqcar x (quote or))) ( +cond ((eq fn neg) (prog nil lab1141 (cond ((null (setq x (cdr x))) (return +nil))) (s!:jumpif fn (car x) env lab) (go lab1141))) (t (progn (setq neg ( +gensym)) (prog nil lab1142 (cond ((null (setq x (cdr x))) (return nil))) ( +s!:jumpif fn (car x) env neg) (go lab1142)) (s!:outjump (quote JUMP) lab) ( +s!:set_label neg)))))) + +(put (quote and) (quote s!:testfn) (function s!:combool)) + +(put (quote or) (quote s!:testfn) (function s!:combool)) + +(de s!:testeq (neg x env lab) (prog (a b) (setq a (s!:improve (cadr x))) ( +setq b (s!:improve (caddr x))) (cond ((or (s!:eval_to_eq_unsafe a) ( +s!:eval_to_eq_unsafe b)) (progn (cond ((neq (posn) 0) (terpri))) (princ +"++++ EQ on number upgraded to EQUAL in ") (prin s!:current_function) (princ +" : ") (prin a) (princ " ") (print b) (return (s!:testequal neg (cons (quote +equal) (cdr x)) env lab))))) (cond (!*carefuleq (progn (s!:comval x env 1) ( +s!:outjump (cond (neg (quote JUMPT)) (t (quote JUMPNIL))) lab) (return nil))) +) (cond ((null a) (s!:jumpif (not neg) b env lab)) (t (cond ((null b) ( +s!:jumpif (not neg) a env lab)) (t (cond ((or (eqcar a (quote quote)) (and ( +atom a) (not (symbolp a)))) (progn (s!:comval b env 1) (cond ((eqcar a (quote +quote)) (setq a (cadr a)))) (setq b (list (cond (neg (quote JUMPLITEQ)) (t ( +quote JUMPLITNE))) a a)) (s!:record_literal_for_jump b env lab))) (t (cond (( +or (eqcar b (quote quote)) (and (atom b) (not (symbolp b)))) (progn ( +s!:comval a env 1) (cond ((eqcar b (quote quote)) (setq b (cadr b)))) (setq a +(list (cond (neg (quote JUMPLITEQ)) (t (quote JUMPLITNE))) b b)) ( +s!:record_literal_for_jump a env lab))) (t (progn (s!:load2 a b env) (cond ( +neg (s!:outjump (quote JUMPEQ) lab)) (t (s!:outjump (quote JUMPNE) lab))))))) +))))))) + +(de s!:testeq1 (neg x env lab) (prog (a b) (cond (!*carefuleq (progn ( +s!:comval x env 1) (s!:outjump (cond (neg (quote JUMPT)) (t (quote JUMPNIL))) +lab) (return nil)))) (setq a (s!:improve (cadr x))) (setq b (s!:improve ( +caddr x))) (cond ((null a) (s!:jumpif (not neg) b env lab)) (t (cond ((null b +) (s!:jumpif (not neg) a env lab)) (t (cond ((or (eqcar a (quote quote)) (and +(atom a) (not (symbolp a)))) (progn (s!:comval b env 1) (cond ((eqcar a ( +quote quote)) (setq a (cadr a)))) (setq b (list (cond (neg (quote JUMPLITEQ)) +(t (quote JUMPLITNE))) a a)) (s!:record_literal_for_jump b env lab))) (t ( +cond ((or (eqcar b (quote quote)) (and (atom b) (not (symbolp b)))) (progn ( +s!:comval a env 1) (cond ((eqcar b (quote quote)) (setq b (cadr b)))) (setq a +(list (cond (neg (quote JUMPLITEQ)) (t (quote JUMPLITNE))) b b)) ( +s!:record_literal_for_jump a env lab))) (t (progn (s!:load2 a b env) (cond ( +neg (s!:outjump (quote JUMPEQ) lab)) (t (s!:outjump (quote JUMPNE) lab))))))) +))))))) + +(put (quote eq) (quote s!:testfn) (function s!:testeq)) + +(cond ((eq!-safe 0) (put (quote iequal) (quote s!:testfn) (function +s!:testeq1))) (t (put (quote iequal) (quote s!:testfn) (function s!:testequal +)))) + +(de s!:testequal (neg x env lab) (prog (a b) (setq a (cadr x)) (setq b (caddr +x)) (cond ((null a) (s!:jumpif (not neg) b env lab)) (t (cond ((null b) ( +s!:jumpif (not neg) a env lab)) (t (cond ((or (and (eqcar a (quote quote)) ( +or (symbolp (cadr a)) (eq!-safe (cadr a)))) (and (eqcar b (quote quote)) (or +(symbolp (cadr b)) (eq!-safe (cadr b)))) (and (not (idp a)) (eq!-safe a)) ( +and (not (idp b)) (eq!-safe b))) (s!:testeq1 neg (cons (quote eq) (cdr x)) +env lab)) (t (progn (s!:load2 a b env) (cond (neg (s!:outjump (quote +JUMPEQUAL) lab)) (t (s!:outjump (quote JUMPNEQUAL) lab)))))))))))) + +(put (quote equal) (quote s!:testfn) (function s!:testequal)) + +(de s!:testneq (neg x env lab) (s!:testequal (not neg) (cons (quote equal) ( +cdr x)) env lab)) + +(put (quote neq) (quote s!:testfn) (function s!:testneq)) + +(de s!:testeqcar (neg x env lab) (prog (a b sw promote) (setq a (cadr x)) ( +setq b (s!:improve (caddr x))) (cond ((s!:eval_to_eq_unsafe b) (progn (cond ( +(neq (posn) 0) (terpri))) (princ +"++++ EQCAR on number upgraded to EQUALCAR in ") (prin s!:current_function) ( +princ " : ") (print b) (setq promote t))) (t (cond (!*carefuleq (progn ( +s!:comval x env 1) (s!:outjump (cond (neg (quote JUMPT)) (t (quote JUMPNIL))) +lab) (return nil)))))) (cond ((and (not promote) (eqcar b (quote quote))) ( +progn (s!:comval a env 1) (setq b (cadr b)) (setq a (list (cond (neg (quote +JUMPEQCAR)) (t (quote JUMPNEQCAR))) b b)) (s!:record_literal_for_jump a env +lab))) (t (progn (setq sw (s!:load2 a b env)) (cond (sw (s!:outopcode0 (quote +SWOP) (quote (SWOP))))) (cond (promote (s!:outopcode1 (quote BUILTIN2) (get +(quote equalcar) (quote s!:builtin2)) (quote equalcar))) (t (s!:outopcode0 ( +quote EQCAR) (quote (EQCAR))))) (s!:outjump (cond (neg (quote JUMPT)) (t ( +quote JUMPNIL))) lab)))))) + +(put (quote eqcar) (quote s!:testfn) (function s!:testeqcar)) + +(de s!:testflagp (neg x env lab) (prog (a b sw) (setq a (cadr x)) (setq b ( +caddr x)) (cond ((eqcar b (quote quote)) (progn (s!:comval a env 1) (setq b ( +cadr b)) (setq sw (symbol!-make!-fastget b nil)) (cond (sw (progn ( +s!:outopcode1 (quote FASTGET) (logor sw 128) b) (s!:outjump (cond (neg (quote +JUMPT)) (t (quote JUMPNIL))) lab))) (t (progn (setq a (list (cond (neg ( +quote JUMPFLAGP)) (t (quote JUMPNFLAGP))) b b)) (s!:record_literal_for_jump a +env lab)))))) (t (progn (setq sw (s!:load2 a b env)) (cond (sw ( +s!:outopcode0 (quote SWOP) (quote (SWOP))))) (s!:outopcode0 (quote FLAGP) ( +quote (FLAGP))) (s!:outjump (cond (neg (quote JUMPT)) (t (quote JUMPNIL))) +lab)))))) + +(put (quote flagp) (quote s!:testfn) (function s!:testflagp)) + +(global (quote (s!:storelocs))) + +(setq s!:storelocs (s!:vecof (quote (STORELOC0 STORELOC1 STORELOC2 STORELOC3 +STORELOC4 STORELOC5 STORELOC6 STORELOC7)))) + +(de s!:comsetq (x env context) (prog (n w var) (setq x (cdr x)) (cond ((null +x) (return nil))) (cond ((or (not (symbolp (car x))) (null (cdr x))) (return +(error 0 (list "bad args for setq" x))))) (s!:comval (cadr x) env 1) (setq +var (car x)) (setq n 0) (setq w (cdr env)) (prog nil lab1143 (cond ((null ( +and w (not (eqcar w var)))) (return nil))) (progn (setq n (add1 n)) (setq w ( +cdr w))) (go lab1143)) (cond (w (progn (cond ((not (member!*!* (cons (quote +loc) w) s!:a_reg_values)) (setq s!:a_reg_values (cons (cons (quote loc) w) +s!:a_reg_values)))) (cond ((lessp n 8) (s!:outopcode0 (getv s!:storelocs n) ( +list (quote storeloc) var))) (t (cond ((greaterp n 4095) (error 0 +"stack frame > 4095")) (t (cond ((greaterp n 255) (s!:outopcode2 (quote +BIGSTACK) (plus 64 (truncate n 256)) (logand n 255) (list (quote STORELOC) +var))) (t (s!:outopcode1 (quote STORELOC) n var))))))))) (t (cond ((setq w ( +s!:find_lexical var s!:lexical_env 0)) (progn (cond ((not (member!*!* (cons ( +quote lex) w) s!:a_reg_values)) (setq s!:a_reg_values (cons (cons (quote lex) +w) s!:a_reg_values)))) (s!:outlexref (quote STORELEX) (length (cdr env)) ( +car w) (cadr w) var))) (t (progn (cond ((or (null var) (eq var t)) (error 0 ( +list "bad variable in setq" var))) (t (s!:should_be_fluid var))) (setq w ( +cons (quote free) var)) (cond ((not (member!*!* w s!:a_reg_values)) (setq +s!:a_reg_values (cons w s!:a_reg_values)))) (s!:outopcode1lit (quote +STOREFREE) var env)))))) (cond ((cddr x) (return (s!:comsetq (cdr x) env +context)))))) + +(put (quote setq) (quote s!:compfn) (function s!:comsetq)) + +(put (quote noisy!-setq) (quote s!:compfn) (function s!:comsetq)) + +(de s!:comlist (x env context) (prog (w) (cond ((null (setq x (cdr x))) ( +return (s!:comval nil env context)))) (setq s!:a_reg_values nil) (cond ((null +(setq w (cdr x))) (s!:comval (list (quote ncons) (car x)) env context)) (t ( +cond ((null (setq w (cdr w))) (s!:comval (list (quote list2) (car x) (cadr x) +) env context)) (t (cond ((null (cdr w)) (s!:comval (list (quote list3) (car +x) (cadr x) (car w)) env context)) (t (s!:comval (list (quote list2!*) (car x +) (cadr x) (cons (quote list) w)) env context))))))))) + +(put (quote list) (quote s!:compfn) (function s!:comlist)) + +(de s!:comlist!* (x env context) (prog (w) (cond ((null (setq x (cdr x))) ( +return (s!:comval nil env context)))) (setq s!:a_reg_values nil) (cond ((null +(setq w (cdr x))) (s!:comval (car x) env context)) (t (cond ((null (setq w ( +cdr w))) (s!:comval (list (quote cons) (car x) (cadr x)) env context)) (t ( +cond ((null (cdr w)) (s!:comval (list (quote list2!*) (car x) (cadr x) (car w +)) env context)) (t (s!:comval (list (quote list2!*) (car x) (cadr x) (cons ( +quote list!*) w)) env context))))))))) + +(put (quote list!*) (quote s!:compfn) (function s!:comlist!*)) + +(de s!:comcons (x env context) (prog (a b) (setq a (cadr x)) (setq b (caddr x +)) (cond ((or (equal b nil) (equal b (quote (quote nil)))) (s!:comval (list ( +quote ncons) a) env context)) (t (cond ((eqcar a (quote cons)) (s!:comval ( +list (quote acons) (cadr a) (caddr a) b) env context)) (t (cond ((eqcar b ( +quote cons)) (cond ((null (caddr b)) (s!:comval (list (quote list2) a (cadr b +)) env context)) (t (s!:comval (list (quote list2!*) a (cadr b) (caddr b)) +env context)))) (t (cond ((and (not !*ord) (s!:iseasy a) (not (s!:iseasy b))) +(s!:comval (list (quote xcons) b a) env context)) (t (s!:comcall x env +context))))))))))) + +(put (quote cons) (quote s!:compfn) (function s!:comcons)) + +(de s!:comapply (x env context) (prog (a b n) (setq a (cadr x)) (setq b ( +caddr x)) (cond ((and (null (cdddr x)) (eqcar b (quote list))) (progn (cond ( +(eqcar a (quote quote)) (return (progn (setq n s!:current_function) (prog ( +s!:current_function) (setq s!:current_function (compress (append (explode n) +(cons (quote !!) (cons (quote !.) (explodec (setq s!:current_count (plus +s!:current_count 1)))))))) (return (s!:comval (cons (cadr a) (cdr b)) env +context))))))) (setq n (length (setq b (cdr b)))) (return (s!:comval (cons ( +quote funcall) (cons a b)) env context)))) (t (cond ((and (null b) (null ( +cdddr x))) (return (s!:comval (list (quote funcall) a) env context))) (t ( +return (s!:comcall x env context)))))))) + +(put (quote apply) (quote s!:compfn) (function s!:comapply)) + +(de s!:imp_funcall (u) (prog (n) (setq u (cdr u)) (cond ((eqcar (car u) ( +quote function)) (return (s!:improve (cons (cadar u) (cdr u)))))) (setq n ( +length (cdr u))) (setq u (cond ((equal n 0) (cons (quote apply0) u)) (t (cond +((equal n 1) (cons (quote apply1) u)) (t (cond ((equal n 2) (cons (quote +apply2) u)) (t (cond ((equal n 3) (cons (quote apply3) u)) (t (cons (quote +funcall!*) u)))))))))) (return u))) + +(put (quote funcall) (quote s!:tidy_fn) (quote s!:imp_funcall)) + +(de s!:eval_to_eq_safe (x) (or (null x) (equal x t) (and (not (symbolp x)) ( +eq!-safe x)) (and (not (atom x)) (flagp (car x) (quote eq!-safe))) (and ( +eqcar x (quote quote)) (or (symbolp (cadr x)) (eq!-safe (cadr x)))))) + +(de s!:eval_to_eq_unsafe (x) (or (and (atom x) (not (symbolp x)) (not ( +eq!-safe x))) (and (not (atom x)) (flagp (car x) (quote eq!-unsafe))) (and ( +eqcar x (quote quote)) (or (not (atom (cadr x))) (and (not (symbolp (cadr x)) +) (not (eq!-safe (cadr x)))))))) + +(de s!:list_all_eq_safe (u) (or (atom u) (and (or (symbolp (car u)) (eq!-safe +(car u))) (s!:list_all_eq_safe (cdr u))))) + +(de s!:eval_to_list_all_eq_safe (x) (or (null x) (and (eqcar x (quote quote)) +(s!:list_all_eq_safe (cadr x))) (and (eqcar x (quote list)) (or (null (cdr x +)) (and (s!:eval_to_eq_safe (cadr x)) (s!:eval_to_list_all_eq_safe (cons ( +quote list) (cddr x)))))) (and (eqcar x (quote cons)) (s!:eval_to_eq_safe ( +cadr x)) (s!:eval_to_list_all_eq_safe (caddr x))))) + +(de s!:list_some_eq_unsafe (u) (and (not (atom u)) (or (s!:eval_to_eq_unsafe +(car u)) (s!:list_some_eq_unsafe (cdr u))))) + +(de s!:eval_to_list_some_eq_unsafe (x) (cond ((atom x) nil) (t (cond ((eqcar +x (quote quote)) (s!:list_some_eq_unsafe (cadr x))) (t (cond ((and (eqcar x ( +quote list)) (cdr x)) (or (s!:eval_to_eq_unsafe (cadr x)) ( +s!:eval_to_list_some_eq_unsafe (cons (quote list) (cddr x))))) (t (cond (( +eqcar x (quote cons)) (or (s!:eval_to_eq_unsafe (cadr x)) ( +s!:eval_to_list_some_eq_unsafe (caddr x)))) (t nil))))))))) + +(de s!:eval_to_car_eq_safe (x) (and (or (eqcar x (quote cons)) (eqcar x ( +quote list))) (not (null (cdr x))) (s!:eval_to_eq_safe (cadr x)))) + +(de s!:eval_to_car_eq_unsafe (x) (and (or (eqcar x (quote cons)) (eqcar x ( +quote list))) (not (null (cdr x))) (s!:eval_to_eq_unsafe (cadr x)))) + +(de s!:alist_eq_safe (u) (or (atom u) (and (not (atom (car u))) (or (symbolp +(caar u)) (eq!-safe (caar u))) (s!:alist_eq_safe (cdr u))))) + +(de s!:eval_to_alist_eq_safe (x) (or (null x) (and (eqcar x (quote quote)) ( +s!:alist_eq_safe (cadr x))) (and (eqcar x (quote list)) (or (null (cdr x)) ( +and (s!:eval_to_car_eq_safe (cadr x)) (s!:eval_to_alist_eq_safe (cons (quote +list) (cddr x)))))) (and (eqcar x (quote cons)) (s!:eval_to_car_eq_safe (cadr +x)) (s!:eval_to_alist_eq_safe (caddr x))))) + +(de s!:alist_eq_unsafe (u) (and (not (atom u)) (not (atom (car u))) (or (not +(atom (caar u))) (and (not (symbolp (caar u))) (not (eq!-safe (caar u)))) ( +s!:alist_eq_unsafe (cdr u))))) + +(de s!:eval_to_alist_eq_unsafe (x) (cond ((null x) nil) (t (cond ((eqcar x ( +quote quote)) (s!:alist_eq_unsafe (cadr x))) (t (cond ((eqcar x (quote list)) +(and (cdr x) (or (s!:eval_to_car_eq_unsafe (cadr x)) ( +s!:eval_to_alist_eq_unsafe (cons (quote list) (cddr x)))))) (t (cond ((eqcar +x (quote cons)) (or (s!:eval_to_car_eq_unsafe (cadr x)) ( +s!:eval_to_alist_eq_safe (caddr x)))) (t nil))))))))) + +(flag (quote (eq eqcar null not greaterp lessp geq leq minusp atom numberp +consp)) (quote eq!-safe)) + +(cond ((not (eq!-safe 1)) (flag (quote (length plus minus difference times +quotient plus2 times2 expt fix float)) (quote eq!-unsafe)))) + +(de s!:comequal (x env context) (cond ((or (s!:eval_to_eq_safe (cadr x)) ( +s!:eval_to_eq_safe (caddr x))) (s!:comcall (cons (quote eq) (cdr x)) env +context)) (t (s!:comcall x env context)))) + +(put (quote equal) (quote s!:compfn) (function s!:comequal)) + +(de s!:comeq (x env context) (cond ((or (s!:eval_to_eq_unsafe (cadr x)) ( +s!:eval_to_eq_unsafe (caddr x))) (progn (cond ((neq (posn) 0) (terpri))) ( +princ "++++ EQ on number upgraded to EQUAL in ") (prin s!:current_function) ( +princ " : ") (prin (cadr x)) (princ " ") (print (caddr x)) (s!:comcall (cons +(quote equal) (cdr x)) env context))) (t (s!:comcall x env context)))) + +(put (quote eq) (quote s!:compfn) (function s!:comeq)) + +(de s!:comeqcar (x env context) (cond ((s!:eval_to_eq_unsafe (caddr x)) ( +progn (cond ((neq (posn) 0) (terpri))) (princ +"++++ EQCAR on number upgraded to EQUALCAR in ") (prin s!:current_function) ( +princ " : ") (prin (caddr x)) (s!:comcall (cons (quote equalcar) (cdr x)) env +context))) (t (s!:comcall x env context)))) + +(put (quote eqcar) (quote s!:compfn) (function s!:comeqcar)) + +(de s!:comsublis (x env context) (cond ((s!:eval_to_alist_eq_safe (cadr x)) ( +s!:comval (cons (quote subla) (cdr x)) env context)) (t (s!:comcall x env +context)))) + +(put (quote sublis) (quote s!:compfn) (function s!:comsublis)) + +(de s!:comsubla (x env context) (cond ((s!:eval_to_alist_eq_unsafe (cadr x)) +(progn (cond ((neq (posn) 0) (terpri))) (princ +"++++ SUBLA on number upgraded to SUBLIS in ") (prin s!:current_function) ( +princ " : ") (print (cadr x)) (s!:comval (cons (quote sublis) (cdr x)) env +context))) (t (s!:comcall x env context)))) + +(put (quote subla) (quote s!:compfn) (function s!:comsubla)) + +(de s!:comassoc (x env context) (cond ((and (or (s!:eval_to_eq_safe (cadr x)) +(s!:eval_to_alist_eq_safe (caddr x))) (equal (length x) 3)) (s!:comval (cons +(quote atsoc) (cdr x)) env context)) (t (cond ((equal (length x) 3) ( +s!:comcall (cons (quote assoc!*!*) (cdr x)) env context)) (t (s!:comcall x +env context)))))) + +(put (quote assoc) (quote s!:compfn) (function s!:comassoc)) + +(put (quote assoc!*!*) (quote s!:compfn) (function s!:comassoc)) + +(de s!:comatsoc (x env context) (cond ((or (s!:eval_to_eq_unsafe (cadr x)) ( +s!:eval_to_alist_eq_unsafe (caddr x))) (progn (cond ((neq (posn) 0) (terpri)) +) (princ "++++ ATSOC on number upgraded to ASSOC in ") (prin +s!:current_function) (princ " : ") (prin (cadr x)) (princ " ") (print (caddr +x)) (s!:comval (cons (quote assoc) (cdr x)) env context))) (t (s!:comcall x +env context)))) + +(put (quote atsoc) (quote s!:compfn) (function s!:comatsoc)) + +(de s!:commember (x env context) (cond ((and (or (s!:eval_to_eq_safe (cadr x) +) (s!:eval_to_list_all_eq_safe (caddr x))) (equal (length x) 3)) (s!:comval ( +cons (quote memq) (cdr x)) env context)) (t (s!:comcall x env context)))) + +(put (quote member) (quote s!:compfn) (function s!:commember)) + +(put (quote member!*!*) (quote s!:compfn) (function s!:commember)) + +(de s!:commemq (x env context) (cond ((or (s!:eval_to_eq_unsafe (cadr x)) ( +s!:eval_to_list_some_eq_unsafe (caddr x))) (progn (cond ((neq (posn) 0) ( +terpri))) (princ "++++ MEMQ on number upgraded to MEMBER in ") (prin +s!:current_function) (princ " : ") (prin (cadr x)) (princ " ") (print (caddr +x)) (s!:comval (cons (quote member) (cdr x)) env context))) (t (s!:comcall x +env context)))) + +(put (quote memq) (quote s!:compfn) (function s!:commemq)) + +(de s!:comdelete (x env context) (cond ((and (or (s!:eval_to_eq_safe (cadr x) +) (s!:eval_to_list_all_eq_safe (caddr x))) (equal (length x) 3)) (s!:comval ( +cons (quote deleq) (cdr x)) env context)) (t (s!:comcall x env context)))) + +(put (quote delete) (quote s!:compfn) (function s!:comdelete)) + +(de s!:comdeleq (x env context) (cond ((or (s!:eval_to_eq_unsafe (cadr x)) ( +s!:eval_to_list_some_eq_unsafe (caddr x))) (progn (cond ((neq (posn) 0) ( +terpri))) (princ "++++ DELEQ on number upgraded to DELETE in ") (prin +s!:current_function) (princ " : ") (prin (cadr x)) (princ " ") (print (caddr +x)) (s!:comval (cons (quote delete) (cdr x)) env context))) (t (s!:comcall x +env context)))) + +(put (quote deleq) (quote s!:compfn) (function s!:comdeleq)) + +(de s!:commap (fnargs env context) (prog (carp fn fn1 args var avar moveon l1 +r s closed) (setq fn (car fnargs)) (cond ((greaterp context 1) (progn (cond +((equal fn (quote mapcar)) (setq fn (quote mapc))) (t (cond ((equal fn (quote +maplist)) (setq fn (quote map))))))))) (cond ((or (equal fn (quote mapc)) ( +equal fn (quote mapcar)) (equal fn (quote mapcan))) (setq carp t))) (setq +fnargs (cdr fnargs)) (cond ((atom fnargs) (error 0 +"bad arguments to map function"))) (setq fn1 (cadr fnargs)) (prog nil lab1144 +(cond ((null (or (eqcar fn1 (quote function)) (and (eqcar fn1 (quote quote)) +(eqcar (cadr fn1) (quote lambda))))) (return nil))) (progn (setq fn1 (cadr +fn1)) (setq closed t)) (go lab1144)) (setq args (car fnargs)) (setq l1 ( +gensym)) (setq r (gensym)) (setq s (gensym)) (setq var (gensym)) (setq avar +var) (cond (carp (setq avar (list (quote car) avar)))) (cond (closed (setq +fn1 (list fn1 avar))) (t (setq fn1 (list (quote funcall) fn1 avar)))) (setq +moveon (list (quote setq) var (list (quote cdr) var))) (cond ((or (equal fn ( +quote map)) (equal fn (quote mapc))) (setq fn (sublis (list (cons (quote l1) +l1) (cons (quote var) var) (cons (quote fn) fn1) (cons (quote args) args) ( +cons (quote moveon) moveon)) (quote (prog (var) (setq var args) l1 (cond (( +not var) (return nil))) fn moveon (go l1)))))) (t (cond ((or (equal fn (quote +maplist)) (equal fn (quote mapcar))) (setq fn (sublis (list (cons (quote l1) +l1) (cons (quote var) var) (cons (quote fn) fn1) (cons (quote args) args) ( +cons (quote moveon) moveon) (cons (quote r) r)) (quote (prog (var r) (setq +var args) l1 (cond ((not var) (return (reversip r)))) (setq r (cons fn r)) +moveon (go l1)))))) (t (setq fn (sublis (list (cons (quote l1) l1) (cons ( +quote l2) (gensym)) (cons (quote var) var) (cons (quote fn) fn1) (cons (quote +args) args) (cons (quote moveon) moveon) (cons (quote r) (gensym)) (cons ( +quote s) (gensym))) (quote (prog (var r s) (setq var args) (setq r (setq s ( +list nil))) l1 (cond ((not var) (return (cdr r)))) (rplacd s fn) l2 (cond (( +not (atom (cdr s))) (setq s (cdr s)) (go l2))) moveon (go l1))))))))) ( +s!:comval fn env context))) + +(put (quote map) (quote s!:compfn) (function s!:commap)) + +(put (quote maplist) (quote s!:compfn) (function s!:commap)) + +(put (quote mapc) (quote s!:compfn) (function s!:commap)) + +(put (quote mapcar) (quote s!:compfn) (function s!:commap)) + +(put (quote mapcon) (quote s!:compfn) (function s!:commap)) + +(put (quote mapcan) (quote s!:compfn) (function s!:commap)) + +(de s!:nilargs (use) (cond ((null use) t) (t (cond ((or (equal (car use) ( +quote nil)) (equal (car use) (quote (quote nil)))) (s!:nilargs (cdr use))) (t +nil))))) + +(de s!:subargs (args use) (cond ((null use) t) (t (cond ((null args) ( +s!:nilargs use)) (t (cond ((not (equal (car args) (car use))) nil) (t ( +s!:subargs (cdr args) (cdr use))))))))) + +(fluid (quote (!*where_defined!*))) + +(de clear_source_database nil (progn (setq !*where_defined!* (mkhash 10 2 1.5 +)) nil)) + +(de load_source_database (filename) (prog (a b) (clear_source_database) (setq +a (open filename (quote input))) (cond ((null a) (return nil))) (setq a (rds +a)) (prog nil lab1145 (cond ((null (setq b (read))) (return nil))) (puthash +(car b) !*where_defined!* (cdr b)) (go lab1145)) (close (rds a)) (return nil) +)) + +(de save_source_database (filename) (prog (a) (setq a (open filename (quote +output))) (cond ((null a) (return nil))) (setq a (wrs a)) (prog (var1147) ( +setq var1147 (sort (hashcontents !*where_defined!*) (function orderp))) +lab1146 (cond ((null var1147) (return nil))) (prog (z) (setq z (car var1147)) +(progn (prin z) (terpri))) (setq var1147 (cdr var1147)) (go lab1146)) (princ +nil) (terpri) (wrs a) (setq !*where_defined!* nil) (return nil))) + +(de display_source_database nil (prog (w) (cond ((null !*where_defined!*) ( +return nil))) (setq w (hashcontents !*where_defined!*)) (setq w (sort w ( +function orderp))) (terpri) (prog (var1149) (setq var1149 w) lab1148 (cond (( +null var1149) (return nil))) (prog (x) (setq x (car var1149)) (progn (princ ( +car x)) (ttab 40) (prin (cdr x)) (terpri))) (setq var1149 (cdr var1149)) (go +lab1148)))) + +(fluid (quote (s!:r2i_simple_recurse s!:r2i_cons_recurse))) + +(de s!:r2i (name args body) (prog (lab v b1 s!:r2i_simple_recurse +s!:r2i_cons_recurse) (setq lab (gensym)) (setq v (list (gensym))) (setq b1 ( +s!:r2i1 name args body lab v)) (cond (s!:r2i_cons_recurse (progn (setq b1 ( +list (quote prog) v lab b1)) (return b1))) (t (cond (s!:r2i_simple_recurse ( +progn (setq v (list (gensym))) (setq b1 (s!:r2i2 name args body lab v)) (setq +b1 (list (quote prog) (cdr v) lab b1)) (return b1))) (t (return (s!:r2i3 +name args body lab v)))))))) + +(de s!:r2i1 (name args body lab v) (cond ((or (null body) (equal body (quote +(progn)))) (list (quote return) (list (quote nreverse) (car v)))) (t (cond (( +and (eqcar body name) (equal (length (cdr body)) (length args))) (progn (setq +s!:r2i_simple_recurse t) (cons (quote progn) (append (s!:r2isteps args (cdr +body) v) (list (list (quote go) lab)))))) (t (cond ((eqcar body (quote cond)) +(cons (quote cond) (s!:r2icond name args (cdr body) lab v))) (t (cond (( +eqcar body (quote if)) (cons (quote if) (s!:r2iif name args (cdr body) lab v) +)) (t (cond ((eqcar body (quote when)) (cons (quote when) (s!:r2iwhen name +args (cdr body) lab v))) (t (cond ((eqcar body (quote cons)) (s!:r2icons name +args (cadr body) (caddr body) lab v)) (t (cond ((or (eqcar body (quote progn +)) (eqcar body (quote prog2))) (cons (quote progn) (s!:r2iprogn name args ( +cdr body) lab v))) (t (cond ((eqcar body (quote and)) (s!:r2i1 name args ( +s!:r2iand (cdr body)) lab v)) (t (cond ((eqcar body (quote or)) (s!:r2i1 name +args (s!:r2ior (cdr body)) lab v)) (t (list (quote return) (list (quote +nreverse) (car v) body))))))))))))))))))))) + +(de s!:r2iand (l) (cond ((null l) t) (t (cond ((null (cdr l)) (car l)) (t ( +list (quote cond) (list (car l) (s!:r2iand (cdr l))))))))) + +(de s!:r2ior (l) (cond ((null l) nil) (t (cons (quote cond) (prog (var1151 +var1152) (setq var1151 l) lab1150 (cond ((null var1151) (return (reversip +var1152)))) (prog (x) (setq x (car var1151)) (setq var1152 (cons (list x) +var1152))) (setq var1151 (cdr var1151)) (go lab1150)))))) + +(de s!:r2icond (name args b lab v) (cond ((null b) (list (list t (list (quote +return) (list (quote nreverse) (car v)))))) (t (cond ((null (cdar b)) (progn +(cond ((null (cdr v)) (rplacd v (list (gensym))))) (cons (list (list (quote +setq) (cadr v) (caar b)) (list (quote return) (list (quote nreverse) (car v) +(cadr v)))) (s!:r2icond name args (cdr b) lab v)))) (t (cond ((eqcar (car b) +t) (list (cons t (s!:r2iprogn name args (cdar b) lab v)))) (t (cons (cons ( +caar b) (s!:r2iprogn name args (cdar b) lab v)) (s!:r2icond name args (cdr b) +lab v))))))))) + +(de s!:r2iif (name args b lab v) (cond ((null (cddr b)) (list (car b) ( +s!:r2i1 name args (cadr b) lab v))) (t (list (car b) (s!:r2i1 name args (cadr +b) lab v) (s!:r2i1 name args (caddr b) lab v))))) + +(de s!:r2iwhen (name args b lab v) (cons (car b) (s!:r2iprogn name args (cdr +b) lab v))) + +(de s!:r2iprogn (name args b lab v) (cond ((null (cdr b)) (list (s!:r2i1 name +args (car b) lab v))) (t (cons (car b) (s!:r2iprogn name args (cdr b) lab v) +)))) + +(de s!:r2icons (name args a d lab v) (cond ((eqcar d (quote cons)) ( +s!:r2icons2 name args a (cadr d) (caddr d) lab v)) (t (cond ((and (eqcar d +name) (equal (length (cdr d)) (length args))) (progn (setq +s!:r2i_cons_recurse t) (cons (quote progn) (cons (list (quote setq) (car v) ( +list (quote cons) a (car v))) (append (s!:r2isteps args (cdr d) v) (list ( +list (quote go) lab))))))) (t (list (quote return) (list (quote nreverse) ( +car v) (list (quote cons) a d)))))))) + +(de s!:r2icons2 (name args a ad dd lab v) (cond ((and (eqcar dd name) (equal +(length (cdr dd)) (length args))) (progn (setq s!:r2i_cons_recurse t) (cons ( +quote progn) (cons (list (quote setq) (car v) (list (quote cons) a (car v))) +(cons (list (quote setq) (car v) (list (quote cons) ad (car v))) (append ( +s!:r2isteps args (cdr dd) v) (list (list (quote go) lab)))))))) (t (list ( +quote return) (list (quote nreverse) (car v) (list (quote cons) a (list ( +quote cons) ad dd))))))) + +(de s!:r2isteps (vars vals v) (cond ((null vars) (cond ((null vals) nil) (t ( +error 0 "too many args in recursive call to self")))) (t (cond ((null vals) ( +error 0 "not enough args in recursive call to self")) (t (cond ((equal (car +vars) (car vals)) (s!:r2isteps (cdr vars) (cdr vals) v)) (t (cond (( +s!:r2i_safestep (car vars) (cdr vars) (cdr vals)) (cons (list (quote setq) ( +car vars) (car vals)) (s!:r2isteps (cdr vars) (cdr vals) v))) (t (prog (w) ( +cond ((null (cdr v)) (rplacd v (list (gensym))))) (setq v (cdr v)) (setq w ( +s!:r2isteps (cdr vars) (cdr vals) v)) (return (cons (list (quote setq) (car v +) (car vals)) (append w (list (list (quote setq) (car vars) (car v))))))))))) +))))) + +(de s!:r2i_safestep (x vars vals) (cond ((and (null vars) (null vals)) t) (t +(cond ((s!:r2i_dependson (car vals) x) nil) (t (s!:r2i_safestep x (cdr vars) +(cdr vals))))))) + +(de s!:r2i_dependson (e x) (cond ((equal e x) t) (t (cond ((or (atom e) ( +eqcar e (quote quote))) nil) (t (cond ((not (atom (car e))) t) (t (cond (( +flagp (car e) (quote s!:r2i_safe)) (s!:r2i_list_dependson (cdr e) x)) (t ( +cond ((or (fluidp x) (globalp x)) t) (t (cond ((or (flagp (car e) (quote +s!:r2i_unsafe)) (macro!-function (car e))) t) (t (s!:r2i_list_dependson (cdr +e) x)))))))))))))) + +(flag (quote (car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr +cddar cdddr cons ncons rcons acons list list2 list3 list!* add1 sub1 plus +plus2 times times2 difference minus quotient append reverse nreverse null not +assoc atsoc member memq subst sublis subla pair prog1 prog2 progn)) (quote +s!:r2i_safe)) + +(flag (quote (cond if when case de defun dm defmacro prog let let!* flet and +or)) (quote s!:r2i_unsafe)) + +(de s!:r2i_list_dependson (l x) (cond ((null l) nil) (t (cond (( +s!:r2i_dependson (car l) x) t) (t (s!:r2i_list_dependson (cdr l) x)))))) + +(de s!:r2i2 (name args body lab v) (cond ((or (null body) (equal body (quote +(progn)))) (list (quote return) nil)) (t (cond ((and (eqcar body name) (equal +(length (cdr body)) (length args))) (progn (cons (quote progn) (append ( +s!:r2isteps args (cdr body) v) (list (list (quote go) lab)))))) (t (cond (( +eqcar body (quote cond)) (cons (quote cond) (s!:r2i2cond name args (cdr body) +lab v))) (t (cond ((eqcar body (quote if)) (cons (quote if) (s!:r2i2if name +args (cdr body) lab v))) (t (cond ((eqcar body (quote when)) (cons (quote +when) (s!:r2i2when name args (cdr body) lab v))) (t (cond ((or (eqcar body ( +quote progn)) (eqcar body (quote prog2))) (cons (quote progn) (s!:r2i2progn +name args (cdr body) lab v))) (t (cond ((eqcar body (quote and)) (s!:r2i2 +name args (s!:r2iand (cdr body)) lab v)) (t (cond ((eqcar body (quote or)) ( +s!:r2i2 name args (s!:r2ior (cdr body)) lab v)) (t (list (quote return) body) +))))))))))))))))) + +(de s!:r2i2cond (name args b lab v) (cond ((null b) (list (list t (list ( +quote return) nil)))) (t (cond ((null (cdar b)) (progn (cond ((null (cdr v)) +(rplacd v (list (gensym))))) (cons (list (list (quote setq) (cadr v) (caar b) +) (list (quote return) (cadr v))) (s!:r2i2cond name args (cdr b) lab v)))) (t +(cond ((eqcar (car b) t) (list (cons t (s!:r2i2progn name args (cdar b) lab +v)))) (t (cons (cons (caar b) (s!:r2i2progn name args (cdar b) lab v)) ( +s!:r2i2cond name args (cdr b) lab v))))))))) + +(de s!:r2i2if (name args b lab v) (cond ((null (cddr b)) (list (car b) ( +s!:r2i2 name args (cadr b) lab v))) (t (list (car b) (s!:r2i2 name args (cadr +b) lab v) (s!:r2i2 name args (caddr b) lab v))))) + +(de s!:r2i2when (name args b lab v) (cons (car b) (s!:r2i2progn name args ( +cdr b) lab v))) + +(de s!:r2i2progn (name args b lab v) (cond ((null (cdr b)) (list (s!:r2i2 +name args (car b) lab v))) (t (cons (car b) (s!:r2i2progn name args (cdr b) +lab v))))) + +(de s!:r2i3 (name args body lab v) (prog (v v1 v2 lab1 lab2 lab3 w P Q g R) ( +cond ((s!:any_fluid args) (return body))) (cond ((eqcar body (quote cond)) ( +progn (cond ((not (setq w (cdr body))) (return body))) (setq P (car w)) (setq +w (cdr w)) (cond ((null P) (return body))) (setq Q (cdr P)) (setq P (car P)) +(cond ((or (null Q) (cdr Q)) (return body))) (setq Q (car Q)) (cond ((or ( +null w) (cdr w)) (return body))) (setq w (car w)) (cond ((not (eqcar w t)) ( +return body))) (setq w (cdr w)) (cond ((or (not w) (cdr w)) (return body))) ( +setq w (car w)))) (t (cond ((eqcar body (quote if)) (progn (setq w (cdr body) +) (setq P (car w)) (setq w (cdr w)) (setq Q (car w)) (setq w (cdr w)) (cond ( +(null w) (return body))) (setq w (car w)))) (t (return body))))) (cond ((or ( +atom w) (atom (cdr w)) (atom (cddr w)) (cdddr w)) (return body))) (setq g ( +car w)) (setq R (cadr w)) (setq w (caddr w)) (cond ((not (atom g)) (return +body))) (cond ((member g (quote (and or progn prog1 prog2 cond if when))) ( +return body))) (cond ((not (eqcar w name)) (return body))) (setq w (cdr w)) ( +cond ((not (equal (length w) (length args))) (return body))) (setq v1 (gensym +)) (setq v2 (gensym)) (setq v (list v2)) (setq lab1 (gensym)) (setq lab2 ( +gensym)) (setq lab3 (gensym)) (setq w (s!:r2isteps args w v)) (setq w (list ( +quote prog) (cons v1 v) lab1 (list (quote cond) (list P (list (quote go) lab2 +))) (list (quote setq) v1 (list (quote cons) R v1)) (cons (quote progn) w) ( +list (quote go) lab1) lab2 (list (quote setq) v2 Q) lab3 (list (quote cond) ( +list (list (quote null) v1) (list (quote return) v2))) (list (quote setq) v2 +(list g (list (quote car) v1) v2)) (list (quote setq) v1 (list (quote cdr) v1 +)) (list (quote go) lab3))) (return w))) + +(de s!:any_fluid (l) (cond ((null l) nil) (t (cond ((fluidp (car l)) t) (t ( +s!:any_fluid (cdr l))))))) + +(de s!:compile1 (name args body s!:lexical_env) (prog (w aargs oargs oinit +restarg svars nargs nopts env fluids s!:current_function s!:current_label +s!:current_block s!:current_size s!:current_procedure s!:current_exitlab +s!:current_proglabels s!:other_defs local_decs s!:has_closure s!:local_macros +s!:recent_literals s!:a_reg_values w1 w2 s!:current_count s!:env_alist +checksum) (cond (s!:lexical_env (setq checksum 0)) (t (setq checksum (md60 ( +cons name (cons args body)))))) (setq s!:current_function name) (setq +s!:current_count 0) (cond (!*where_defined!* (progn (setq w name) (puthash w +!*where_defined!* (where!-was!-that))))) (setq body (s!:find_local_decs body +nil)) (setq local_decs (car body)) (setq body (cdr body)) (cond ((atom body) +(setq body nil)) (t (cond ((null (cdr body)) (setq body (car body))) (t (setq +body (cons (quote progn) body)))))) (setq nargs (setq nopts 0)) (prog nil +lab1153 (cond ((null (and args (not (eqcar args (quote !&optional))) (not ( +eqcar args (quote !&rest))))) (return nil))) (progn (cond ((or (equal (car +args) (quote !&key)) (equal (car args) (quote !&aux))) (error 0 "&key/&aux")) +) (setq aargs (cons (car args) aargs)) (setq nargs (plus nargs 1)) (setq args +(cdr args))) (go lab1153)) (cond ((eqcar args (quote !&optional)) (progn ( +setq args (cdr args)) (prog nil lab1155 (cond ((null (and args (not (eqcar +args (quote !&rest))))) (return nil))) (progn (cond ((or (equal (car args) ( +quote !&key)) (equal (car args) (quote !&aux))) (error 0 "&key/&aux"))) (setq +w (car args)) (prog nil lab1154 (cond ((null (and (not (atom w)) (or (atom ( +cdr w)) (equal (cdr w) (quote (nil)))))) (return nil))) (setq w (car w)) (go +lab1154)) (setq args (cdr args)) (setq oargs (cons w oargs)) (setq nopts ( +plus nopts 1)) (cond ((atom w) (setq aargs (cons w aargs))) (t (progn (setq +oinit t) (setq aargs (cons (car w) aargs)) (cond ((not (atom (cddr w))) (setq +svars (cons (caddr w) svars)))))))) (go lab1155))))) (cond ((eqcar args ( +quote !&rest)) (progn (setq w (cadr args)) (setq aargs (cons w aargs)) (setq +restarg w) (setq args (cddr args)) (cond (args (error 0 +"&rest arg not at end")))))) (setq args (reverse aargs)) (setq oargs (reverse +oargs)) (prog (var1157) (setq var1157 (append svars args)) lab1156 (cond (( +null var1157) (return nil))) (prog (v) (setq v (car var1157)) (progn (cond (( +globalp v) (progn (cond (!*pwrds (progn (cond ((neq (posn) 0) (terpri))) ( +princ "+++++ global ") (prin v) (princ " converted to fluid") (terpri)))) ( +unglobal (list v)) (fluid (list v))))))) (setq var1157 (cdr var1157)) (go +lab1156)) (cond (oinit (return (s!:compile2 name nargs nopts args oargs +restarg body local_decs checksum)))) (setq w nil) (prog (var1159) (setq +var1159 args) lab1158 (cond ((null var1159) (return nil))) (prog (v) (setq v +(car var1159)) (setq w (s!:instate_local_decs v local_decs w))) (setq var1159 +(cdr var1159)) (go lab1158)) (cond ((and !*r2i (null oargs) (null restarg)) +(setq body (s!:r2i name args body)))) (prog (v) (setq v args) lab1160 (cond ( +(null v) (return nil))) (progn (cond ((fluidp (car v)) (prog (g) (setq g ( +gensym)) (setq fluids (cons (cons (car v) g) fluids)) (rplaca v g))))) (setq +v (cdr v)) (go lab1160)) (cond (fluids (progn (setq body (list (list (quote +return) body))) (prog (var1162) (setq var1162 fluids) lab1161 (cond ((null +var1162) (return nil))) (prog (v) (setq v (car var1162)) (setq body (cons ( +list (quote setq) (car v) (cdr v)) body))) (setq var1162 (cdr var1162)) (go +lab1161)) (setq body (cons (quote prog) (cons (prog (var1164 var1165) (setq +var1164 fluids) lab1163 (cond ((null var1164) (return (reversip var1165)))) ( +prog (v) (setq v (car var1164)) (setq var1165 (cons (car v) var1165))) (setq +var1164 (cdr var1164)) (go lab1163)) body)))))) (setq env (cons (mkhash 10 2 +1.5) (reverse args))) (puthash name (car env) (cons 10000000 nil)) (setq w ( +s!:residual_local_decs local_decs w)) (s!:start_procedure nargs nopts restarg +) (setq w1 body) more (cond ((atom w1) nil) (t (cond ((and (equal (car w1) ( +quote block)) (equal (length w1) 3)) (progn (setq w1 (caddr w1)) (go more))) +(t (cond ((and (equal (car w1) (quote progn)) (equal (length w1) 2)) (progn ( +setq w1 (cadr w1)) (go more))) (t (cond ((and (atom (setq w2 (car w1))) (setq +w2 (get w2 (quote s!:newname)))) (progn (setq w1 (cons w2 (cdr w1))) (go +more))) (t (cond ((and (atom (setq w2 (car w1))) (setq w2 (macro!-function w2 +))) (progn (setq w1 (funcall w2 w1)) (go more)))))))))))) (cond ((not (equal +(setq w2 (s!:improve w1)) w1)) (progn (setq w1 w2) (go more)))) (cond ((and ( +not (atom w1)) (atom (car w1)) (not (special!-form!-p (car w1))) (s!:subargs +args (cdr w1)) (leq nargs 3) (equal nopts 0) (not restarg) (leq (length (cdr +w1)) nargs)) (progn (s!:cancel_local_decs w) (cond (restarg (setq nopts (plus +nopts 512)))) (setq nopts (plus nopts (times 1024 (length w1)))) (setq nargs +(plus nargs (times 256 nopts))) (cond (!*pwrds (progn (cond ((neq (posn) 0) +(terpri))) (princ "+++ ") (prin name) (princ " compiled as link to ") (princ +(car w1)) (terpri)))) (return (cons (cons name (cons nargs (cons nil (car w1) +))) s!:other_defs))))) (s!:comval body env 0) (s!:cancel_local_decs w) (cond +(restarg (setq nopts (plus nopts 512)))) (setq nargs (plus nargs (times 256 +nopts))) (return (cons (cons name (cons nargs (s!:endprocedure name env +checksum))) s!:other_defs)))) + +(de s!:compile2 (name nargs nopts args oargs restarg body local_decs checksum +) (prog (fluids env penv g v init atend w) (prog (var1167) (setq var1167 args +) lab1166 (cond ((null var1167) (return nil))) (prog (v) (setq v (car var1167 +)) (progn (setq env (cons 0 env)) (setq penv (cons env penv)))) (setq var1167 +(cdr var1167)) (go lab1166)) (setq env (cons (mkhash 10 2 1.5) env)) ( +puthash name (car env) (cons 10000000 nil)) (setq penv (reversip penv)) (cond +(restarg (setq oargs (append oargs (quote (0)))))) (prog (i) (setq i 1) +lab1168 (cond ((minusp (times 1 (difference nargs i))) (return nil))) (setq +oargs (cons 0 oargs)) (setq i (plus i 1)) (go lab1168)) (s!:start_procedure +nargs nopts restarg) (prog nil lab1169 (cond ((null args) (return nil))) ( +progn (setq v (car args)) (setq init (car oargs)) (cond ((equal init 0) ( +progn (setq w (s!:instate_local_decs v local_decs w)) (cond ((fluidp v) ( +progn (setq g (gensym)) (rplaca (car penv) g) (s!:outopcode1lit (quote +FREEBIND) (s!:vecof (list v)) env) (rplacd env (cons 3 (cons 0 (cons 0 (cdr +env))))) (setq atend (cons (quote FREERSTR) atend)) (s!:comval (list (quote +setq) v g) env 2))) (t (rplaca (car penv) v))))) (t (prog (ival sp l1 l2) ( +cond ((not (atom init)) (progn (setq init (cdr init)) (setq ival (car init)) +(cond ((not (atom (cdr init))) (setq sp (cadr init))))))) (setq l1 (gensym)) +(setq g (gensym)) (rplaca (car penv) g) (cond ((and (null ival) (null sp)) ( +s!:comval (list (quote setq) g (list (quote spid!-to!-nil) g)) env 1)) (t ( +progn (s!:jumpif nil (list (quote is!-spid) g) env l1) (s!:comval (list ( +quote setq) g ival) env 1) (cond (sp (progn (cond ((fluidp sp) (progn ( +s!:outopcode1lit (quote FREEBIND) (s!:vecof (list sp)) env) (s!:outjump ( +quote JUMP) (setq l2 (gensym))) (s!:set_label l1) (s!:outopcode1lit (quote +FREEBIND) (s!:vecof (list sp)) env) (rplacd env (cons 3 (cons 0 (cons 0 (cdr +env))))) (s!:comval (list (quote setq) sp t) env 1) (s!:set_label l2) (setq +atend (cons (quote FREERSTR) atend)))) (t (progn (s!:outopcode0 (quote +PUSHNIL) (quote (PUSHNIL))) (s!:outjump (quote JUMP) (setq l2 (gensym))) ( +s!:set_label l1) (s!:loadliteral t env) (s!:outopcode0 (quote PUSH) (quote ( +PUSH))) (s!:set_label l2) (rplacd env (cons sp (cdr env))) (setq atend (cons +(quote LOSE) atend))))))) (t (s!:set_label l1)))))) (setq w ( +s!:instate_local_decs v local_decs w)) (cond ((fluidp v) (progn ( +s!:outopcode1lit (quote FREEBIND) (s!:vecof (list v)) env) (rplacd env (cons +3 (cons 0 (cons 0 (cdr env))))) (s!:comval (list (quote setq) v g) env 1) ( +setq atend (cons (quote FREERSTR) atend)))) (t (rplaca (car penv) v)))))) ( +setq args (cdr args)) (setq oargs (cdr oargs)) (setq penv (cdr penv))) (go +lab1169)) (setq w (s!:residual_local_decs local_decs w)) (s!:comval body env +0) (prog nil lab1170 (cond ((null atend) (return nil))) (progn (s!:outopcode0 +(car atend) (list (car atend))) (setq atend (cdr atend))) (go lab1170)) ( +s!:cancel_local_decs w) (setq nopts (plus nopts 256)) (cond (restarg (setq +nopts (plus nopts 512)))) (setq nargs (plus nargs (times 256 nopts))) (return +(cons (cons name (cons nargs (s!:endprocedure name env checksum))) +s!:other_defs)))) + +(de compile!-all nil (prog (var1172) (setq var1172 (oblist)) lab1171 (cond (( +null var1172) (return nil))) (prog (x) (setq x (car var1172)) (prog (w) (setq +w (getd x)) (cond ((and (or (eqcar w (quote expr)) (eqcar w (quote macro))) +(eqcar (cdr w) (quote lambda))) (progn (princ "Compile: ") (prin x) (terpri) +(errorset (list (quote compile) (mkquote (list x))) t t)))))) (setq var1172 ( +cdr var1172)) (go lab1171))) + +(flag (quote (rds deflist flag fluid global remprop remflag unfluid unglobal +dm defmacro carcheck faslend c_end)) (quote eval)) + +(flag (quote (rds)) (quote ignore)) + +(fluid (quote (!*backtrace))) + +(de s!:fasl_supervisor nil (prog (u w !*echo) top (setq u (errorset (quote ( +read)) t !*backtrace)) (cond ((atom u) (return nil))) (setq u (car u)) (cond +((equal u !$eof!$) (return nil))) (cond ((not (atom u)) (setq u (macroexpand +u)))) (cond ((atom u) (go top)) (t (cond ((eqcar u (quote faslend)) (return ( +apply (quote faslend) nil))) (t (cond ((eqcar u (quote rdf)) (progn (setq w ( +open (setq u (eval (cadr u))) (quote input))) (cond (w (progn (terpri) (princ +"Reading file ") (prin u) (terpri) (setq w (rds w)) (s!:fasl_supervisor) ( +princ "End of file ") (prin u) (terpri) (close (rds w)))) (t (progn (princ +"Failed to open file ") (prin u) (terpri)))))) (t (s!:fslout0 u))))))) (go +top))) + +(de s!:fslout0 (u) (s!:fslout1 u nil)) + +(de s!:fslout1 (u loadonly) (prog (w) (cond ((not (atom u)) (setq u ( +macroexpand u)))) (cond ((atom u) (return nil)) (t (cond ((eqcar u (quote +progn)) (progn (prog (var1174) (setq var1174 (cdr u)) lab1173 (cond ((null +var1174) (return nil))) (prog (v) (setq v (car var1174)) (s!:fslout1 v +loadonly)) (setq var1174 (cdr var1174)) (go lab1173)) (return nil))) (t (cond +((eqcar u (quote eval!-when)) (return (prog nil (setq w (cadr u)) (setq u ( +cons (quote progn) (cddr u))) (cond ((and (memq (quote compile) w) (not +loadonly)) (eval u))) (cond ((memq (quote load) w) (s!:fslout1 u t))) (return +nil)))) (t (cond ((or (flagp (car u) (quote eval)) (and (equal (car u) ( +quote setq)) (not (atom (caddr u))) (flagp (caaddr u) (quote eval)))) (cond ( +(not loadonly) (errorset u t !*backtrace))))))))))) (cond ((eqcar u (quote +rdf)) (prog nil (setq w (open (setq u (eval (cadr u))) (quote input))) (cond +(w (progn (princ "Reading file ") (prin u) (terpri) (setq w (rds w)) ( +s!:fasl_supervisor) (princ "End of file ") (prin u) (terpri) (close (rds w))) +) (t (progn (princ "Failed to open file ") (prin u) (terpri)))))) (t (cond ( +!*nocompile (progn (cond ((and (not (eqcar u (quote faslend))) (not (eqcar u +(quote carcheck)))) (write!-module u))))) (t (cond ((or (eqcar u (quote de)) +(eqcar u (quote defun))) (progn (cond ((and !*native_code (not (memq (quote +win64) lispsystem!*))) (progn (cond ((c!:valid_fndef (caddr u) (cdddr u)) ( +prog (pending_functions u1) (c!:ccmpout1a u) (prog nil lab1175 (cond ((null +pending_functions) (return nil))) (progn (setq u1 (car pending_functions)) ( +setq pending_functions (cdr pending_functions)) (s!:fslout0 u1)) (go lab1175) +))) (t (progn (princ "+++ ") (prin (cadr u)) (printc +" can not be compiled into native code"))))))) (setq u (cdr u)) (cond ((and ( +setq w (get (car u) (quote c!-version))) (equal w (md60 (cons (car u) (cons ( +cadr u) (s!:fully_macroexpand_list (cddr u))))))) (progn (princ "+++ ") (prin +(car u)) (printc " not compiled (C version available)") (write!-module (list +(quote restore!-c!-code) (mkquote (car u)))))) (t (cond ((flagp (car u) ( +quote lose)) (progn (princ "+++ ") (prin (car u)) (printc +" not compiled (LOSE flag)"))) (t (progn (cond ((setq w (get (car u) (quote +c!-version))) (progn (princ "+++ ") (prin (car u)) (princ +" reports C version with checksum ") (print w) (print +"+++ differing from this version:") (setq w (cons (car u) (cons (cadr u) ( +s!:fully_macroexpand_list (cddr u))))) (princ "::: ") (prettyprint w) (princ +"+++ which has checksum ") (print (md60 w))))) (prog (var1177) (setq var1177 +(s!:compile1 (car u) (cadr u) (cddr u) nil)) lab1176 (cond ((null var1177) ( +return nil))) (prog (p) (setq p (car var1177)) (s!:fslout2 p u)) (setq +var1177 (cdr var1177)) (go lab1176))))))))) (t (cond ((or (eqcar u (quote dm) +) (eqcar u (quote defmacro))) (prog (g) (setq g (hashtagged!-name (cadr u) ( +cddr u))) (setq u (cdr u)) (cond ((flagp (car u) (quote lose)) (progn (princ +"+++ ") (prin (car u)) (printc " not compiled (LOSE flag)") (return nil)))) ( +setq w (cadr u)) (cond ((and w (null (cdr w))) (setq w (cons (car w) (cons ( +quote !&optional) (cons (gensym) nil)))))) (prog (var1179) (setq var1179 ( +s!:compile1 g w (cddr u) nil)) lab1178 (cond ((null var1179) (return nil))) ( +prog (p) (setq p (car var1179)) (s!:fslout2 p u)) (setq var1179 (cdr var1179) +) (go lab1178)) (write!-module (list (quote dm) (car u) (quote (u !&optional +e)) (list g (quote u) (quote e)))))) (t (cond ((eqcar u (quote putd)) (prog ( +a1 a2 a3) (setq a1 (cadr u)) (setq a2 (caddr u)) (setq a3 (cadddr u)) (cond ( +(and (eqcar a1 (quote quote)) (or (equal a2 (quote (quote expr))) (equal a2 ( +quote (quote macro)))) (or (eqcar a3 (quote quote)) (eqcar a3 (quote function +))) (eqcar (cadr a3) (quote lambda))) (progn (setq a1 (cadr a1)) (setq a2 ( +cadr a2)) (setq a3 (cadr a3)) (setq u (cons (cond ((equal a2 (quote expr)) ( +quote de)) (t (quote dm))) (cons a1 (cdr a3)))) (s!:fslout1 u loadonly))) (t +(write!-module u))))) (t (cond ((and (not (eqcar u (quote faslend))) (not ( +eqcar u (quote carcheck)))) (write!-module u))))))))))))))) + +(de s!:fslout2 (p u) (prog (name nargs code env w) (setq name (car p)) (setq +nargs (cadr p)) (setq code (caddr p)) (setq env (cdddr p)) (cond ((and +!*savedef (equal name (car u))) (progn (define!-in!-module (minus 1)) ( +write!-module (cons (quote lambda) (cons (cadr u) (s!:fully_macroexpand_list +(cddr u)))))))) (setq w (irightshift nargs 18)) (setq nargs (logand nargs +262143)) (cond ((not (equal w 0)) (setq code (difference w 1)))) ( +define!-in!-module nargs) (write!-module name) (write!-module code) ( +write!-module env))) + +(remprop (quote faslend) (quote stat)) + +(de faslend nil (prog (copysrc copydest) (cond ((null s!:faslmod_name) ( +return nil))) (princ "Completed FASL files for ") (print (car s!:faslmod_name +)) (cond ((and !*native_code (not (memq (quote win64) lispsystem!*))) (prog ( +cmnd w w1 obj deff) (setq w (C!-end1 nil)) (close C_file) (setq cmnd (append +(explodec s!:native_file) (quote (!")))) (cond ((memq (quote win32) +lispsystem!*) (setq obj "dll")) (t (setq obj "so"))) (setq obj (tmpnam obj)) +(cond ((memq (quote win32) lispsystem!*) (prog (nn) (setq nn (car +s!:faslmod_name)) (setq nn (list!-to!-string (prog (var1181 var1182) (setq +var1181 (explodec nn)) lab1180 (cond ((null var1181) (return (reversip +var1182)))) (prog (c) (setq c (car var1181)) (setq var1182 (cons (cond (( +equal c (quote !-)) (quote !_)) (t c)) var1182))) (setq var1181 (cdr var1181) +) (go lab1180)))) (setq deff (tmpnam "def")) (setq w1 (open deff (quote +output))) (setq w1 (wrs w1)) (princ "LIBRARY ") (princ (car s!:faslmod_name)) +(printc ".dll") (printc "EXPORTS") (printc " init") (princ " ") (princ nn) ( +printc "_setup") (printc "IMPORTS") (print!-imports) (close (wrs w1)) (setq +cmnd (append (explodec deff) (cons (quote ! ) cmnd)))))) (setq cmnd (append ( +explodec obj) (cons (quote ! ) cmnd))) (setq cmnd (append (explodec " -o ") +cmnd)) (prog (var1184) (setq var1184 (reverse (cdr (assoc (quote +compiler!-command) lispsystem!*)))) lab1183 (cond ((null var1184) (return nil +))) (prog (x) (setq x (car var1184)) (setq cmnd (append (explodec x) (cons ( +quote ! ) cmnd)))) (setq var1184 (cdr var1184)) (go lab1183)) (setq cmnd ( +compress (cons (quote !") cmnd))) (print cmnd) (cond ((not (zerop ( +silent!-system cmnd))) (progn (princ "+++ C compilation for ") (prin (car +s!:faslmod_name)) (printc " failed"))) (t (progn (cond (!*strip_native (progn +(setq cmnd (compress (cons (quote !") (append (explodec "strip ") (append ( +explodec obj) (quote (!"))))))) (print cmnd) (silent!-system cmnd)))) (setq +copysrc obj) (setq copydest (list!-to!-string (append (explodec (car +s!:faslmod_name)) (cons (quote !.) (explodec (cdr (assoc (quote linker) +lispsystem!*))))))) (cond ((not !*save_native) (progn (delete!-file +s!:native_file) (cond ((memq (quote win32) lispsystem!*) (delete!-file deff)) +)))) (write!-module (list (quote instate!-c!-code) (mkquote (car +s!:faslmod_name)) (mkquote w))))))))) (start!-module nil) (cond (copysrc ( +progn (copy!-native copysrc copydest) (cond ((not !*save_native) ( +delete!-file copysrc)))))) (setq dfprint!* s!:dfprintsave) (setq !*defn nil) +(setq !*comp (cdr s!:faslmod_name)) (setq s!:faslmod_name nil) (return nil))) + +(put (quote faslend) (quote stat) (quote endstat)) + +(de s!:file (s) (prog (r) (setq s (reverse (explodec s))) (prog nil lab1185 ( +cond ((null (and s (not (or (eqcar s (quote !/)) (eqcar s (quote !\)))))) ( +return nil))) (progn (setq r (cons (car s) r)) (setq s (cdr s))) (go lab1185) +) (return (list!-to!-string r)))) + +(de s!:trim!.c (s) (prog (r) (setq s (reverse (explodec s))) (cond ((eqcar s +(quote c)) (progn (setq s (cdr s)) (cond ((eqcar s (quote !.)) (setq s (cdr s +))))))) (return (list!-to!-string (reverse s))))) + +(de s!:dir (s) (prog nil (setq s (reverse (explodec s))) (prog nil lab1186 ( +cond ((null (and s (not (or (eqcar s (quote !/)) (eqcar s (quote !\)))))) ( +return nil))) (setq s (cdr s)) (go lab1186)) (cond (s (setq s (cdr s)))) ( +cond ((null s) (return ".")) (t (return (list!-to!-string (reverse s))))))) + +(de faslout (u) (prog nil (terpri) (princ "FASLOUT ") (prin u) (princ +": IN files; or type in expressions") (terpri) (princ +"When all done, execute FASLEND;") (terpri) (cond ((not (atom u)) (setq u ( +car u)))) (cond ((not (start!-module u)) (progn (cond ((neq (posn) 0) (terpri +))) (princ "+++ Failed to open FASL output file") (terpri) (return nil)))) ( +cond ((and !*native_code (not (memq (quote win64) lispsystem!*))) (progn ( +setq s!:native_file (tmpnam "c")) (c!:ccompilestart (s!:trim!.c (s!:file +s!:native_file)) u (s!:dir s!:native_file) t)))) (setq s!:faslmod_name (cons +u !*comp)) (setq s!:dfprintsave dfprint!*) (setq dfprint!* (quote s!:fslout0) +) (setq !*defn t) (setq !*comp nil) (cond ((getd (quote begin)) (return nil)) +) (s!:fasl_supervisor))) + +(put (quote faslout) (quote stat) (quote rlis)) + +(de s!:c_supervisor nil (prog (u w !*echo) top (setq u (errorset (quote (read +)) t !*backtrace)) (cond ((atom u) (return nil))) (setq u (car u)) (cond (( +equal u !$eof!$) (return nil))) (cond ((not (atom u)) (setq u (macroexpand u) +))) (cond ((atom u) (go top)) (t (cond ((eqcar u (quote c_end)) (return ( +apply (quote c_end) nil))) (t (cond ((eqcar u (quote rdf)) (progn (setq w ( +open (setq u (eval (cadr u))) (quote input))) (cond (w (progn (terpri) (princ +"Reading file ") (prin u) (terpri) (setq w (rds w)) (s!:c_supervisor) (princ +"End of file ") (prin u) (terpri) (close (rds w)))) (t (progn (princ +"Failed to open file ") (prin u) (terpri)))))) (t (s!:cout0 u))))))) (go top) +)) + +(de s!:cout0 (u) (s!:cout1 u nil)) + +(de s!:cout1 (u loadonly) (prog (s!:into_c) (setq s!:into_c t) (cond ((not ( +atom u)) (setq u (macroexpand u)))) (cond ((atom u) (return nil)) (t (cond (( +eqcar u (quote progn)) (progn (prog (var1188) (setq var1188 (cdr u)) lab1187 +(cond ((null var1188) (return nil))) (prog (v) (setq v (car var1188)) ( +s!:cout1 v loadonly)) (setq var1188 (cdr var1188)) (go lab1187)) (return nil) +)) (t (cond ((eqcar u (quote eval!-when)) (return (prog (w) (setq w (cadr u)) +(setq u (cons (quote progn) (cddr u))) (cond ((and (memq (quote compile) w) +(not loadonly)) (eval u))) (cond ((memq (quote load) w) (s!:cout1 u t))) ( +return nil)))) (t (cond ((or (flagp (car u) (quote eval)) (and (equal (car u) +(quote setq)) (not (atom (caddr u))) (flagp (caaddr u) (quote eval)))) (cond +((not loadonly) (errorset u t !*backtrace))))))))))) (cond ((eqcar u (quote +rdf)) (prog (w) (setq w (open (setq u (eval (cadr u))) (quote input))) (cond +(w (progn (princ "Reading file ") (prin u) (terpri) (setq w (rds w)) ( +s!:c_supervisor) (princ "End of file ") (prin u) (terpri) (close (rds w)))) ( +t (progn (princ "Failed to open file ") (prin u) (terpri)))))) (t (cond ((or +(eqcar u (quote de)) (eqcar u (quote defun))) (prog (w) (setq u (cdr u)) ( +setq w (s!:compile1 (car u) (cadr u) (cddr u) nil)) (prog (var1190) (setq +var1190 w) lab1189 (cond ((null var1190) (return nil))) (prog (p) (setq p ( +car var1190)) (s!:cgen (car p) (cadr p) (caddr p) (cdddr p))) (setq var1190 ( +cdr var1190)) (go lab1189)))) (t (cond ((or (eqcar u (quote dm)) (eqcar u ( +quote defmacro))) (prog (w g) (setq g (hashtagged!-name (cadr u) (cddr u))) ( +setq u (cdr u)) (setq w (cadr u)) (cond ((and w (null (cdr w))) (setq w (cons +(car w) (cons (quote !&optional) (cons (gensym) nil)))))) (setq w ( +s!:compile1 g w (cddr u) nil)) (prog (var1192) (setq var1192 w) lab1191 (cond +((null var1192) (return nil))) (prog (p) (setq p (car var1192)) (s!:cgen ( +car p) (cadr p) (caddr p) (cdddr p))) (setq var1192 (cdr var1192)) (go +lab1191)) (s!:cinit (list (quote dm) (car u) (quote (u !&optional e)) (list g +(quote u) (quote e)))))) (t (cond ((eqcar u (quote putd)) (prog (a1 a2 a3) ( +setq a1 (cadr u)) (setq a2 (caddr u)) (setq a3 (cadddr u)) (cond ((and (eqcar +a1 (quote quote)) (or (equal a2 (quote (quote expr))) (equal a2 (quote ( +quote macro)))) (or (eqcar a3 (quote quote)) (eqcar a3 (quote function))) ( +eqcar (cadr a3) (quote lambda))) (progn (setq a1 (cadr a1)) (setq a2 (cadr a2 +)) (setq a3 (cadr a3)) (setq u (cons (cond ((equal a2 (quote expr)) (quote de +)) (t (quote dm))) (cons a1 (cdr a3)))) (s!:cout1 u loadonly))) (t (s!:cinit +u))))) (t (cond ((and (not (eqcar u (quote c_end))) (not (eqcar u (quote +carcheck)))) (s!:cinit u))))))))))))) + +(fluid (quote (s!:cmod_name))) + +(de c_end nil (prog nil (cond ((null s!:cmod_name) (return nil))) (s!:cend) ( +setq dfprint!* s!:dfprintsave) (setq !*defn nil) (setq !*comp (cdr +s!:cmod_name)) (setq s!:cmod_name nil) (return nil))) + +(put (quote c_end) (quote stat) (quote endstat)) + +(de c_out (u) (prog nil (terpri) (princ "C_OUT ") (prin u) (princ +": IN files; or type in expressions") (terpri) (princ +"When all done, execute C_END;") (terpri) (cond ((not (atom u)) (setq u (car +u)))) (cond ((null (s!:cstart u)) (progn (cond ((neq (posn) 0) (terpri))) ( +princ "+++ Failed to open C output file") (terpri) (return nil)))) (setq +s!:cmod_name (cons u !*comp)) (setq s!:dfprintsave dfprint!*) (setq dfprint!* +(quote s!:cout0)) (setq !*defn t) (setq !*comp nil) (cond ((getd (quote +begin)) (return nil))) (s!:c_supervisor))) + +(put (quote c_out) (quote stat) (quote rlis)) + +(de s!:compile!-file!* (fromfile !&optional tofile verbose !*pwrds) (prog ( +!*comp w save) (cond ((null tofile) (setq tofile fromfile))) (cond (verbose ( +progn (cond ((neq (posn) 0) (terpri))) (princ "+++ Compiling file ") (prin +fromfile) (terpri) (setq save (verbos nil)) (verbos (ilogand save 4))))) ( +cond ((not (start!-module tofile)) (progn (cond ((neq (posn) 0) (terpri))) ( +princ "+++ Failed to open FASL output file") (terpri) (cond (save (verbos +save))) (return nil)))) (setq w (open fromfile (quote input))) (cond (w ( +progn (setq w (rds w)) (s!:fasl_supervisor) (close (rds w)))) (t (progn ( +princ "Failed to open file ") (prin fromfile) (terpri)))) (cond (save (verbos +save))) (start!-module nil) (cond (verbose (progn (cond ((neq (posn) 0) ( +terpri))) (princ "+++ Compilation complete") (terpri)))) (return t))) + +(de compile!-file!* (fromfile !&optional tofile) (s!:compile!-file!* fromfile +tofile t t)) + +(de compd (name type defn) (prog (g !*comp) (setq !*comp t) (cond ((eqcar +defn (quote lambda)) (progn (setq g (dated!-name type)) ( +symbol!-set!-definition g defn) (compile (list g)) (setq defn g)))) (put name +type defn) (return name))) + +(de s!:compile0 (name) (prog (w args defn) (setq defn (getd name)) (cond (( +and (eqcar defn (quote macro)) (eqcar (cdr defn) (quote lambda))) (prog ( +!*comp lx vx bx) (setq lx (cdr defn)) (cond ((not (or (and (equal (length lx) +3) (not (atom (setq bx (caddr lx)))) (equal (cadr lx) (cdr bx))) (and (equal +(length lx) 3) (not (atom (setq bx (caddr lx)))) (not (atom (cadr lx))) ( +eqcar (cdadr lx) (quote !&optional)) (not (atom (setq bx (cdr bx)))) (equal ( +caadr lx) (car bx)) (equal (cddadr lx) (cdr bx))))) (progn (setq w ( +hashtagged!-name name defn)) (symbol!-set!-definition w (cdr defn)) ( +s!:compile0 w) (cond ((equal 1 (length (cadr lx))) (symbol!-set!-env name ( +list (quote (u !&optional env)) (list w (quote u))))) (t (symbol!-set!-env +name (list (quote (u !&optional env)) (list w (quote u) (quote env))))))))))) +(t (cond ((or (not (eqcar defn (quote expr))) (not (eqcar (cdr defn) (quote +lambda)))) (progn (cond (!*pwrds (progn (cond ((neq (posn) 0) (terpri))) ( +princ "+++ ") (prin name) (princ " not compilable") (terpri)))))) (t (progn ( +setq args (cddr defn)) (setq defn (cdr args)) (setq args (car args)) (cond (( +stringp args) (progn (cond (!*pwrds (progn (cond ((neq (posn) 0) (terpri))) ( +princ "+++ ") (prin name) (princ " was already compiled") (terpri)))))) (t ( +progn (cond (!*savedef (put name (quote !*savedef) (cons (quote lambda) (cons +args (s!:fully_macroexpand_list defn)))))) (setq w (s!:compile1 name args +defn nil)) (prog (var1194) (setq var1194 w) lab1193 (cond ((null var1194) ( +return nil))) (prog (p) (setq p (car var1194)) (symbol!-set!-definition (car +p) (cdr p))) (setq var1194 (cdr var1194)) (go lab1193)))))))))))) + +(de s!:fully_macroexpand_list (l) (cond ((atom l) l) (t (prog (var1196 +var1197) (setq var1196 l) lab1195 (cond ((null var1196) (return (reversip +var1197)))) (prog (u) (setq u (car var1196)) (setq var1197 (cons ( +s!:fully_macroexpand u) var1197))) (setq var1196 (cdr var1196)) (go lab1195)) +))) + +(de s!:fully_macroexpand (x) (prog (helper) (cond ((or (atom x) (eqcar x ( +quote quote))) (return x)) (t (cond ((eqcar (car x) (quote lambda)) (return ( +cons (cons (quote lambda) (cons (cadar x) (s!:fully_macroexpand_list (cddar x +)))) (s!:fully_macroexpand_list (cdr x))))) (t (cond ((setq helper (get (car +x) (quote s!:newname))) (return (s!:fully_macroexpand (cons helper (cdr x)))) +) (t (cond ((setq helper (get (car x) (quote s!:expandfn))) (return (funcall +helper x))) (t (cond ((setq helper (macro!-function (car x))) (return ( +s!:fully_macroexpand (funcall helper x)))) (t (return (cons (car x) ( +s!:fully_macroexpand_list (cdr x)))))))))))))))) + +(de s!:expandfunction (u) u) + +(de s!:expandflet (u) (cons (car u) (cons (prog (var1199 var1200) (setq +var1199 (cadr u)) lab1198 (cond ((null var1199) (return (reversip var1200)))) +(prog (b) (setq b (car var1199)) (setq var1200 (cons (s!:expandfletvars b) +var1200))) (setq var1199 (cdr var1199)) (go lab1198)) ( +s!:fully_macroexpand_list (cddr u))))) + +(de s!:expandfletvars (b) (cons (car b) (cons (cadr b) ( +s!:fully_macroexpand_list (cddr b))))) + +(de s!:expandlabels (u) (s!:expandflet u)) + +(de s!:expandmacrolet (u) (s!:expandflet u)) + +(de s!:expandprog (u) (cons (car u) (cons (cadr u) (s!:fully_macroexpand_list +(cddr u))))) + +(de s!:expandtagbody (u) (s!:fully_macroexpand_list u)) + +(de s!:expandprogv (u) (cons (car u) (cons (cadr u) (cons (caddr u) ( +s!:fully_macroexpand_list (cadddr u)))))) + +(de s!:expandblock (u) (cons (car u) (cons (cadr u) ( +s!:fully_macroexpand_list (cddr u))))) + +(de s!:expanddeclare (u) u) + +(de s!:expandlet (u) (cons (car u) (cons (prog (var1202 var1203) (setq +var1202 (cadr u)) lab1201 (cond ((null var1202) (return (reversip var1203)))) +(prog (x) (setq x (car var1202)) (setq var1203 (cons ( +s!:fully_macroexpand_list x) var1203))) (setq var1202 (cdr var1202)) (go +lab1201)) (s!:fully_macroexpand_list (cddr u))))) + +(de s!:expandlet!* (u) (s!:expandlet u)) + +(de s!:expandgo (u) u) + +(de s!:expandreturn!-from (u) (cons (car u) (cons (cadr u) ( +s!:fully_macroexpand_list (cddr u))))) + +(de s!:expandcond (u) (cons (car u) (prog (var1205 var1206) (setq var1205 ( +cdr u)) lab1204 (cond ((null var1205) (return (reversip var1206)))) (prog (x) +(setq x (car var1205)) (setq var1206 (cons (s!:fully_macroexpand_list x) +var1206))) (setq var1205 (cdr var1205)) (go lab1204)))) + +(de s!:expandcase (u) (cons (car u) (cons (s!:fully_macroexpand (cadr u)) ( +prog (var1208 var1209) (setq var1208 (cddr u)) lab1207 (cond ((null var1208) +(return (reversip var1209)))) (prog (x) (setq x (car var1208)) (setq var1209 +(cons (cons (car x) (s!:fully_macroexpand_list (cdr x))) var1209))) (setq +var1208 (cdr var1208)) (go lab1207))))) + +(de s!:expandeval!-when (u) (cons (car u) (cons (cadr u) ( +s!:fully_macroexpand_list (cddr u))))) + +(de s!:expandthe (u) (cons (car u) (cons (cadr u) (s!:fully_macroexpand_list +(cddr u))))) + +(de s!:expandmv!-call (u) (cons (car u) (cons (cadr u) ( +s!:fully_macroexpand_list (cddr u))))) + +(put (quote function) (quote s!:expandfn) (function s!:expandfunction)) + +(put (quote flet) (quote s!:expandfn) (function s!:expandflet)) + +(put (quote labels) (quote s!:expandfn) (function s!:expandlabels)) + +(put (quote macrolet) (quote s!:expandfn) (function s!:expandmacrolet)) + +(put (quote prog) (quote s!:expandfn) (function s!:expandprog)) + +(put (quote tagbody) (quote s!:expandfn) (function s!:expandtagbody)) + +(put (quote progv) (quote s!:expandfn) (function s!:expandprogv)) + +(put (quote !~block) (quote s!:expandfn) (function s!:expandblock)) + +(put (quote declare) (quote s!:expandfn) (function s!:expanddeclare)) + +(put (quote !~let) (quote s!:expandfn) (function s!:expandlet)) + +(put (quote let!*) (quote s!:expandfn) (function s!:expandlet!*)) + +(put (quote go) (quote s!:expandfn) (function s!:expandgo)) + +(put (quote return!-from) (quote s!:expandfn) (function s!:expandreturn!-from +)) + +(put (quote cond) (quote s!:expandfn) (function s!:expandcond)) + +(put (quote case) (quote s!:expandfn) (function s!:expandcase)) + +(put (quote eval!-when) (quote s!:expandfn) (function s!:expandeval!-when)) + +(put (quote the) (quote s!:expandfn) (function s!:expandthe)) + +(put (quote multiple!-value!-call) (quote s!:expandfn) (function +s!:expandmv!-call)) + +(de compile (l) (prog nil (cond ((and (atom l) (not (null l))) (setq l (list +l)))) (prog (var1211) (setq var1211 l) lab1210 (cond ((null var1211) (return +nil))) (prog (name) (setq name (car var1211)) (errorset (list (quote +s!:compile0) (mkquote name)) t t)) (setq var1211 (cdr var1211)) (go lab1210)) +(return l))) + + + +(global (quote (!*fastvector !*unsafecar))) + +(flag (quote (fastvector unsafecar)) (quote switch)) + +(fluid (quote (C_file L_file O_file L_contents Setup_name File_name))) + +(dm c!:printf (u !&optional env) (list (quote c!:printf1) (cadr u) (cons ( +quote list) (cddr u)))) + +(de c!:printf1 (fmt args) (prog (a c) (setq fmt (explode2 fmt)) (prog nil +lab1212 (cond ((null fmt) (return nil))) (progn (setq c (car fmt)) (setq fmt +(cdr fmt)) (cond ((and (equal c (quote !\)) (or (equal (car fmt) (quote !n)) +(equal (car fmt) (quote !N)))) (progn (terpri) (setq fmt (cdr fmt)))) (t ( +cond ((and (equal c (quote !\)) (or (equal (car fmt) (quote !q)) (equal (car +fmt) (quote !Q)))) (progn (princ (quote !")) (setq fmt (cdr fmt)))) (t (cond +((equal c (quote !%)) (progn (setq c (car fmt)) (cond ((null args) (setq a ( +quote missing_arg))) (t (setq a (car args)))) (cond ((or (equal c (quote !v)) +(equal c (quote !V))) (cond ((flagp a (quote c!:live_across_call)) (progn ( +princ "stack[") (princ (minus (get a (quote c!:location)))) (princ "]"))) (t +(princ a)))) (t (cond ((or (equal c (quote !c)) (equal c (quote !C))) ( +c!:safeprin a)) (t (cond ((or (equal c (quote !a)) (equal c (quote !A))) ( +prin a)) (t (cond ((or (equal c (quote !t)) (equal c (quote !T))) (ttab a)) ( +t (cond ((equal c (quote !<)) (progn (setq args (cons nil args)) (cond (( +greaterp (posn) 70) (terpri))))) (t (princ a))))))))))) (cond (args (setq +args (cdr args)))) (setq fmt (cdr fmt)))) (t (princ c)))))))) (go lab1212)))) + +(de c!:safeprin (x) (prog (a b) (setq a (explode x)) (prog nil lab1213 (cond +((null a) (return nil))) (progn (cond ((and (eqcar a (quote !/)) b) (princ +" "))) (princ (car a)) (setq b (eqcar a (quote !*))) (setq a (cdr a))) (go +lab1213)))) + +(de c!:valid_fndef (args body) (cond ((or (memq (quote !&optional) args) ( +memq (quote !&rest) args)) nil) (t (c!:valid_list body)))) + +(de c!:valid_list (x) (cond ((null x) t) (t (cond ((atom x) nil) (t (cond (( +not (c!:valid_expr (car x))) nil) (t (c!:valid_list (cdr x))))))))) + +(de c!:valid_expr (x) (cond ((atom x) t) (t (cond ((not (atom (car x))) ( +progn (cond ((not (c!:valid_list (cdr x))) nil) (t (cond ((not (eqcar (car x) +(quote lambda))) nil) (t (cond ((atom (cdar x)) nil) (t (c!:valid_fndef ( +cadar x) (cddar x)))))))))) (t (cond ((not (idp (car x))) nil) (t (cond (( +eqcar x (quote quote)) t) (t (prog (h) (setq h (get (car x) (quote c!:valid)) +) (cond ((null h) (return (c!:valid_list (cdr x))))) (return (funcall h (cdr +x))))))))))))) + +(de c!:cspecform (x env) (error 0 (list "special form" x))) + +(de c!:valid_specform (x) nil) + +(progn (put (quote and) (quote c!:code) (function c!:cspecform)) (put (quote +catch) (quote c!:code) (function c!:cspecform)) (put (quote compiler!-let) ( +quote c!:code) (function c!:cspecform)) (put (quote cond) (quote c!:code) ( +function c!:cspecform)) (put (quote declare) (quote c!:code) (function +c!:cspecform)) (put (quote de) (quote c!:code) (function c!:cspecform)) (put +(quote eval!-when) (quote c!:code) (function c!:cspecform)) (put (quote flet) +(quote c!:code) (function c!:cspecform)) (put (quote function) (quote +c!:code) (function c!:cspecform)) (put (quote go) (quote c!:code) (function +c!:cspecform)) (put (quote if) (quote c!:code) (function c!:cspecform)) (put +(quote labels) (quote c!:code) (function c!:cspecform)) (put (quote !~let) ( +quote c!:code) (function c!:cspecform)) (put (quote let!*) (quote c!:code) ( +function c!:cspecform)) (put (quote list) (quote c!:code) (function +c!:cspecform)) (put (quote list!*) (quote c!:code) (function c!:cspecform)) ( +put (quote macrolet) (quote c!:code) (function c!:cspecform)) (put (quote +multiple!-value!-call) (quote c!:code) (function c!:cspecform)) (put (quote +multiple!-value!-prog1) (quote c!:code) (function c!:cspecform)) (put (quote +or) (quote c!:code) (function c!:cspecform)) (put (quote prog) (quote c!:code +) (function c!:cspecform)) (put (quote prog!*) (quote c!:code) (function +c!:cspecform)) (put (quote prog1) (quote c!:code) (function c!:cspecform)) ( +put (quote prog2) (quote c!:code) (function c!:cspecform)) (put (quote progn) +(quote c!:code) (function c!:cspecform)) (put (quote progv) (quote c!:code) +(function c!:cspecform)) (put (quote quote) (quote c!:code) (function +c!:cspecform)) (put (quote return) (quote c!:code) (function c!:cspecform)) ( +put (quote return!-from) (quote c!:code) (function c!:cspecform)) (put (quote +setq) (quote c!:code) (function c!:cspecform)) (put (quote tagbody) (quote +c!:code) (function c!:cspecform)) (put (quote the) (quote c!:code) (function +c!:cspecform)) (put (quote throw) (quote c!:code) (function c!:cspecform)) ( +put (quote unless) (quote c!:code) (function c!:cspecform)) (put (quote +unwind!-protect) (quote c!:code) (function c!:cspecform)) (put (quote when) ( +quote c!:code) (function c!:cspecform)) (put (quote catch) (quote c!:valid) ( +function c!:valid_specform)) (put (quote compiler!-let) (quote c!:valid) ( +function c!:valid_specform)) (put (quote cond) (quote c!:valid) (function +c!:valid_specform)) (put (quote declare) (quote c!:valid) (function +c!:valid_specform)) (put (quote de) (quote c!:valid) (function +c!:valid_specform)) (put (quote eval!-when) (quote c!:valid) (function +c!:valid_specform)) (put (quote flet) (quote c!:valid) (function +c!:valid_specform)) (put (quote function) (quote c!:valid) (function +c!:valid_specform)) (put (quote labels) (quote c!:valid) (function +c!:valid_specform)) (put (quote !~let) (quote c!:valid) (function +c!:valid_specform)) (put (quote let!*) (quote c!:valid) (function +c!:valid_specform)) (put (quote macrolet) (quote c!:valid) (function +c!:valid_specform)) (put (quote multiple!-value!-call) (quote c!:valid) ( +function c!:valid_specform)) (put (quote multiple!-value!-prog1) (quote +c!:valid) (function c!:valid_specform)) (put (quote prog) (quote c!:valid) ( +function c!:valid_specform)) (put (quote prog!*) (quote c!:valid) (function +c!:valid_specform)) (put (quote progv) (quote c!:valid) (function +c!:valid_specform)) (put (quote quote) (quote c!:valid) (function +c!:valid_specform)) (put (quote the) (quote c!:valid) (function +c!:valid_specform)) (put (quote throw) (quote c!:valid) (function +c!:valid_specform)) (put (quote unwind!-protect) (quote c!:valid) (function +c!:valid_specform))) + +(fluid (quote (c!:current_procedure c!:current_args c!:current_block +c!:current_contents c!:all_blocks c!:registers c!:stacklocs))) + +(fluid (quote (c!:available c!:used))) + +(setq c!:available (setq c!:used nil)) + +(de c!:reset_gensyms nil (progn (remflag c!:used (quote c!:live_across_call)) +(remflag c!:used (quote c!:visited)) (prog nil lab1214 (cond ((null c!:used) +(return nil))) (progn (remprop (car c!:used) (quote c!:contents)) (remprop ( +car c!:used) (quote c!:why)) (remprop (car c!:used) (quote c!:where_to)) ( +remprop (car c!:used) (quote c!:count)) (remprop (car c!:used) (quote c!:live +)) (remprop (car c!:used) (quote c!:clash)) (remprop (car c!:used) (quote +c!:chosen)) (remprop (car c!:used) (quote c!:location)) (cond ((plist (car +c!:used)) (prog (o) (setq o (wrs nil)) (princ "+++++ ") (prin (car c!:used)) +(princ " ") (prin (plist (car c!:used))) (terpri) (wrs o)))) (setq +c!:available (cons (car c!:used) c!:available)) (setq c!:used (cdr c!:used))) +(go lab1214)))) + +(de c!:my_gensym nil (prog (w) (cond (c!:available (progn (setq w (car +c!:available)) (setq c!:available (cdr c!:available)))) (t (setq w (gensym1 +"v")))) (setq c!:used (cons w c!:used)) (cond ((plist w) (progn (princ +"????? ") (prin w) (princ " => ") (prin (plist w)) (terpri)))) (return w))) + +(de c!:newreg nil (prog (r) (setq r (c!:my_gensym)) (setq c!:registers (cons +r c!:registers)) (return r))) + +(de c!:startblock (s) (progn (setq c!:current_block s) (setq +c!:current_contents nil))) + +(de c!:outop (a b c d) (cond (c!:current_block (setq c!:current_contents ( +cons (list a b c d) c!:current_contents))))) + +(de c!:endblock (why where_to) (cond (c!:current_block (progn (put +c!:current_block (quote c!:contents) c!:current_contents) (put +c!:current_block (quote c!:why) why) (put c!:current_block (quote c!:where_to +) where_to) (setq c!:all_blocks (cons c!:current_block c!:all_blocks)) (setq +c!:current_contents nil) (setq c!:current_block nil))))) + +(de c!:cval_inner (x env) (prog (helper) (setq x (s!:improve x)) (cond ((atom +x) (return (c!:catom x env))) (t (cond ((eqcar (car x) (quote lambda)) ( +return (c!:clambda (cadar x) (cddar x) (cdr x) env))) (t (cond ((setq helper +(get (car x) (quote c!:code))) (return (funcall helper x env))) (t (cond (( +and (setq helper (get (car x) (quote c!:compile_macro))) (setq helper ( +funcall helper x))) (return (c!:cval helper env))) (t (cond ((and (idp (car x +)) (setq helper (macro!-function (car x)))) (return (c!:cval (funcall helper +x) env))) (t (return (c!:ccall (car x) (cdr x) env)))))))))))))) + +(de c!:cval (x env) (prog (r) (setq r (c!:cval_inner x env)) (cond ((and r ( +not (member!*!* r c!:registers))) (error 0 (list r "not a register" x)))) ( +return r))) + +(de c!:clambda (bvl body args env) (prog (w w1 fluids env1 decs) (setq env1 ( +car env)) (setq w (prog (var1216 var1217) (setq var1216 args) lab1215 (cond ( +(null var1216) (return (reversip var1217)))) (prog (a) (setq a (car var1216)) +(setq var1217 (cons (c!:cval a env) var1217))) (setq var1216 (cdr var1216)) +(go lab1215))) (setq w1 (s!:find_local_decs body nil)) (setq localdecs (cons +(car w1) localdecs)) (setq w1 (cdr w1)) (cond ((null w1) (setq body nil)) (t +(cond ((null (cdr w1)) (setq body (car w1))) (t (setq body (cons (quote progn +) w1)))))) (prog (var1219) (setq var1219 bvl) lab1218 (cond ((null var1219) ( +return nil))) (prog (x) (setq x (car var1219)) (cond ((and (not (fluidp x)) ( +not (globalp x)) (c!:local_fluidp x localdecs)) (progn (make!-special x) ( +setq decs (cons x decs)))))) (setq var1219 (cdr var1219)) (go lab1218)) (prog +(var1221) (setq var1221 bvl) lab1220 (cond ((null var1221) (return nil))) ( +prog (v) (setq v (car var1221)) (progn (cond ((globalp v) (prog (oo) (setq oo +(wrs nil)) (princ "+++++ ") (prin v) (princ +" converted from GLOBAL to FLUID") (terpri) (wrs oo) (unglobal (list v)) ( +fluid (list v))))) (cond ((fluidp v) (progn (setq fluids (cons (cons v ( +c!:newreg)) fluids)) (flag (list (cdar fluids)) (quote c!:live_across_call)) +(setq env1 (cons (cons (quote c!:dummy!:name) (cdar fluids)) env1)) (c!:outop +(quote ldrglob) (cdar fluids) v (c!:find_literal v)) (c!:outop (quote +strglob) (car w) v (c!:find_literal v)))) (t (progn (setq env1 (cons (cons v +(c!:newreg)) env1)) (c!:outop (quote movr) (cdar env1) nil (car w))))) (setq +w (cdr w)))) (setq var1221 (cdr var1221)) (go lab1220)) (cond (fluids ( +c!:outop (quote fluidbind) nil nil fluids))) (setq env (cons env1 (append +fluids (cdr env)))) (setq w (c!:cval body env)) (prog (var1223) (setq var1223 +fluids) lab1222 (cond ((null var1223) (return nil))) (prog (v) (setq v (car +var1223)) (c!:outop (quote strglob) (cdr v) (car v) (c!:find_literal (car v)) +)) (setq var1223 (cdr var1223)) (go lab1222)) (unfluid decs) (setq localdecs +(cdr localdecs)) (return w))) + +(de c!:locally_bound (x env) (atsoc x (car env))) + +(flag (quote (nil t)) (quote c!:constant)) + +(fluid (quote (literal_vector))) + +(de c!:find_literal (x) (prog (n w) (setq w literal_vector) (setq n 0) (prog +nil lab1224 (cond ((null (and w (not (equal (car w) x)))) (return nil))) ( +progn (setq n (plus n 1)) (setq w (cdr w))) (go lab1224)) (cond ((null w) ( +setq literal_vector (append literal_vector (list x))))) (return n))) + +(de c!:catom (x env) (prog (v w) (setq v (c!:newreg)) (cond ((and (idp x) (or +(fluidp x) (globalp x))) (c!:outop (quote ldrglob) v x (c!:find_literal x))) +(t (cond ((and (idp x) (setq w (c!:locally_bound x env))) (c!:outop (quote +movr) v nil (cdr w))) (t (cond ((or (null x) (equal x (quote t)) ( +c!:small_number x)) (c!:outop (quote movk1) v nil x)) (t (cond ((or (not (idp +x)) (flagp x (quote c!:constant))) (c!:outop (quote movk) v x ( +c!:find_literal x))) (t (c!:outop (quote ldrglob) v x (c!:find_literal x))))) +))))) (return v))) + +(de c!:cjumpif (x env d1 d2) (prog (helper r) (setq x (s!:improve x)) (cond ( +(and (atom x) (or (not (idp x)) (and (flagp x (quote c!:constant)) (not ( +c!:locally_bound x env))))) (c!:endblock (quote goto) (list (cond (x d1) (t +d2))))) (t (cond ((and (not (atom x)) (setq helper (get (car x) (quote +c!:ctest)))) (return (funcall helper x env d1 d2))) (t (progn (setq r ( +c!:cval x env)) (c!:endblock (list (quote ifnull) r) (list d2 d1))))))))) + +(fluid (quote (c!:current))) + +(de c!:ccall (fn args env) (c!:ccall1 fn args env)) + +(fluid (quote (c!:visited))) + +(de c!:has_calls (a b) (prog (c!:visited) (return (c!:has_calls_1 a b)))) + +(de c!:has_calls_1 (a b) (cond ((or (equal a b) (not (atom a)) (memq a +c!:visited)) nil) (t (prog (has_call) (setq c!:visited (cons a c!:visited)) ( +prog (var1226) (setq var1226 (get a (quote c!:contents))) lab1225 (cond (( +null var1226) (return nil))) (prog (z) (setq z (car var1226)) (cond ((eqcar z +(quote call)) (setq has_call t)))) (setq var1226 (cdr var1226)) (go lab1225) +) (cond (has_call (return (prog (c!:visited) (return (c!:can_reach a b)))))) +(prog (var1228) (setq var1228 (get a (quote c!:where_to))) lab1227 (cond (( +null var1228) (return nil))) (prog (d) (setq d (car var1228)) (cond (( +c!:has_calls_1 d b) (setq has_call t)))) (setq var1228 (cdr var1228)) (go +lab1227)) (return has_call))))) + +(de c!:can_reach (a b) (cond ((equal a b) t) (t (cond ((or (not (atom a)) ( +memq a c!:visited)) nil) (t (progn (setq c!:visited (cons a c!:visited)) ( +c!:any_can_reach (get a (quote c!:where_to)) b))))))) + +(de c!:any_can_reach (l b) (cond ((null l) nil) (t (cond ((c!:can_reach (car +l) b) t) (t (c!:any_can_reach (cdr l) b)))))) + +(de c!:pareval (args env) (prog (tasks tasks1 merge split r) (setq tasks ( +prog (var1230 var1231) (setq var1230 args) lab1229 (cond ((null var1230) ( +return (reversip var1231)))) (prog (a) (setq a (car var1230)) (setq var1231 ( +cons (cons (c!:my_gensym) (c!:my_gensym)) var1231))) (setq var1230 (cdr +var1230)) (go lab1229))) (setq split (c!:my_gensym)) (c!:endblock (quote goto +) (list split)) (prog (var1233) (setq var1233 args) lab1232 (cond ((null +var1233) (return nil))) (prog (a) (setq a (car var1233)) (prog (s) (setq s ( +car tasks)) (setq tasks (cdr tasks)) (c!:startblock (car s)) (setq r (cons ( +c!:cval a env) r)) (c!:endblock (quote goto) (list (cdr s))) (cond ((or t ( +c!:has_calls (car s) (cdr s))) (setq tasks1 (cons s tasks1))) (t (setq merge +(cons s merge)))))) (setq var1233 (cdr var1233)) (go lab1232)) (prog (var1235 +) (setq var1235 tasks1) lab1234 (cond ((null var1235) (return nil))) (prog (z +) (setq z (car var1235)) (setq merge (cons z merge))) (setq var1235 (cdr +var1235)) (go lab1234)) (prog (var1237) (setq var1237 merge) lab1236 (cond (( +null var1237) (return nil))) (prog (v) (setq v (car var1237)) (progn ( +c!:startblock split) (c!:endblock (quote goto) (list (car v))) (setq split ( +cdr v)))) (setq var1237 (cdr var1237)) (go lab1236)) (c!:startblock split) ( +return (reversip r)))) + +(de c!:ccall1 (fn args env) (prog (tasks merge r val) (setq fn (list fn (cdr +env))) (setq val (c!:newreg)) (cond ((null args) (c!:outop (quote call) val +nil fn)) (t (cond ((null (cdr args)) (c!:outop (quote call) val (list ( +c!:cval (car args) env)) fn)) (t (progn (setq r (c!:pareval args env)) ( +c!:outop (quote call) val r fn)))))) (c!:outop (quote reloadenv) (quote env) +nil nil) (return val))) + +(fluid (quote (restart_label reloadenv does_call c!:current_c_name))) + +(de c!:local_fluidp1 (v decs) (and decs (or (and (eqcar (car decs) (quote +special)) (memq v (cdar decs))) (c!:local_fluidp1 v (cdr decs))))) + +(de c!:local_fluidp (v decs) (and decs (or (c!:local_fluidp1 v (car decs)) ( +c!:local_fluidp v (cdr decs))))) + +(fluid (quote (proglabs blockstack localdecs))) + +(de c!:cfndef (c!:current_procedure c!:current_c_name argsbody checksum) ( +prog (env n w c!:current_args c!:current_block restart_label +c!:current_contents c!:all_blocks entrypoint exitpoint args1 c!:registers +c!:stacklocs literal_vector reloadenv does_call blockstack proglabs args body +localdecs) (setq args (car argsbody)) (setq body (cdr argsbody)) (setq w ( +s!:find_local_decs body nil)) (setq body (cdr w)) (cond ((atom body) (setq +body nil)) (t (cond ((atom (cdr body)) (setq body (car body))) (t (setq body +(cons (quote progn) body)))))) (setq localdecs (list (car w))) ( +c!:reset_gensyms) (wrs C_file) (linelength 200) (c!:printf +"\n\n/* Code for %a %<*/\n\n" c!:current_procedure) (c!:find_literal +c!:current_procedure) (setq c!:current_args args) (prog (var1239) (setq +var1239 args) lab1238 (cond ((null var1239) (return nil))) (prog (v) (setq v +(car var1239)) (cond ((or (equal v (quote !&optional)) (equal v (quote !&rest +))) (error 0 "&optional and &rest not supported by this compiler (yet)")) (t +(cond ((globalp v) (prog (oo) (setq oo (wrs nil)) (princ "+++++ ") (prin v) ( +princ " converted from GLOBAL to FLUID") (terpri) (wrs oo) (unglobal (list v) +) (fluid (list v)) (setq n (cons (cons v (c!:my_gensym)) n)))) (t (cond ((or +(fluidp v) (c!:local_fluidp v localdecs)) (setq n (cons (cons v (c!:my_gensym +)) n))))))))) (setq var1239 (cdr var1239)) (go lab1238)) (cond (!*r2i (setq +body (s!:r2i c!:current_procedure args body)))) (setq restart_label ( +c!:my_gensym)) (setq body (list (quote c!:private_tagbody) restart_label body +)) (cond (n (progn (setq body (list (list (quote return) body))) (setq args ( +subla n args)) (prog (var1241) (setq var1241 n) lab1240 (cond ((null var1241) +(return nil))) (prog (v) (setq v (car var1241)) (setq body (cons (list ( +quote setq) (car v) (cdr v)) body))) (setq var1241 (cdr var1241)) (go lab1240 +)) (setq body (cons (quote prog) (cons (prog (var1243 var1244) (setq var1243 +(reverse n)) lab1242 (cond ((null var1243) (return (reversip var1244)))) ( +prog (v) (setq v (car var1243)) (setq var1244 (cons (car v) var1244))) (setq +var1243 (cdr var1243)) (go lab1242)) body)))))) (c!:printf +"static Lisp_Object ") (cond ((or (null args) (geq (length args) 3)) ( +c!:printf "MS_CDECL "))) (c!:printf "%s(Lisp_Object env" c!:current_c_name) ( +cond ((or (null args) (geq (length args) 3)) (c!:printf ", int nargs"))) ( +setq n t) (setq env nil) (prog (var1246) (setq var1246 args) lab1245 (cond (( +null var1246) (return nil))) (prog (x) (setq x (car var1246)) (prog (aa) ( +c!:printf ",") (cond (n (progn (c!:printf "\n ") (setq +n nil))) (t (setq n t))) (setq aa (c!:my_gensym)) (setq env (cons (cons x aa +) env)) (setq c!:registers (cons aa c!:registers)) (setq args1 (cons aa args1 +)) (c!:printf " Lisp_Object %s" aa))) (setq var1246 (cdr var1246)) (go +lab1245)) (cond ((or (null args) (geq (length args) 3)) (c!:printf ", ..."))) +(c!:printf ")\n{\n") (c!:startblock (setq entrypoint (c!:my_gensym))) (setq +exitpoint c!:current_block) (c!:endblock (quote goto) (list (list (c!:cval +body (cons env nil))))) (c!:optimise_flowgraph entrypoint c!:all_blocks env ( +cons (length args) c!:current_procedure) args1) (c!:printf "}\n\n") (wrs +O_file) (setq L_contents (cons (cons c!:current_procedure (cons +literal_vector checksum)) L_contents)) (return nil))) + +(flag (quote (rds deflist flag fluid global remprop remflag unfluid unglobal +dm carcheck C!-end)) (quote eval)) + +(flag (quote (rds)) (quote ignore)) + +(fluid (quote (!*backtrace))) + +(de c!:ccompilesupervisor nil (prog (u w) top (setq u (errorset (quote (read) +) t !*backtrace)) (cond ((atom u) (return nil))) (setq u (car u)) (cond (( +equal u !$eof!$) (return nil))) (cond ((atom u) (go top)) (t (cond ((eqcar u +(quote C!-end)) (return (apply (quote C!-end) nil))) (t (cond ((eqcar u ( +quote rdf)) (progn (setq w (open (setq u (eval (cadr u))) (quote input))) ( +cond (w (progn (terpri) (princ "Reading file ") (print u) (setq w (rds w)) ( +c!:ccompilesupervisor) (princ "End of file ") (print u) (close (rds w)))) (t +(progn (princ "Failed to open file ") (print u)))))) (t (c!:ccmpout1 u))))))) +(go top))) + +(global (quote (c!:char_mappings))) + +(setq c!:char_mappings (quote ((! . !A) (!! . !B) (!# . !C) (!$ . !D) (!% . +!E) (!^ . !F) (!& . !G) (!* . !H) (!( . !I) (!) . !J) (!- . !K) (!+ . !L) (!= + . !M) (!\ . !N) (!| . !O) (!, . !P) (!. . !Q) (!< . !R) (!> . !S) (!: . !T) +(!; . !U) (!/ . !V) (!? . !W) (!~ . !X) (!` . !Y)))) + +(fluid (quote (c!:names_so_far))) + +(de c!:inv_name (n) (prog (r w) (cond ((setq w (assoc n c!:names_so_far)) ( +setq w (plus (cdr w) 1))) (t (setq w 0))) (setq c!:names_so_far (cons (cons n +w) c!:names_so_far)) (setq r (quote (!C !C !"))) (cond ((not (zerop w)) ( +setq r (append (reverse (explodec w)) r)))) (setq r (cons (quote !_) r)) ( +prog (var1248) (setq var1248 (explode2 n)) lab1247 (cond ((null var1248) ( +return nil))) (prog (c) (setq c (car var1248)) (progn (cond ((equal c (quote +_)) (setq r (cons (quote _) r))) (t (cond ((or (liter c) (digit c)) (setq r ( +cons c r))) (t (cond ((setq w (atsoc c c!:char_mappings)) (setq r (cons (cdr +w) r))) (t (setq r (cons (quote !Z) r)))))))))) (setq var1248 (cdr var1248)) +(go lab1247)) (setq r (cons (quote !") r)) (return (compress (reverse r))))) + +(fluid (quote (c!:defnames pending_functions))) + +(de c!:ccmpout1 (u) (prog (pending_functions) (setq pending_functions (list u +)) (prog nil lab1249 (cond ((null pending_functions) (return nil))) (progn ( +setq u (car pending_functions)) (setq pending_functions (cdr +pending_functions)) (c!:ccmpout1a u)) (go lab1249)))) + +(de c!:ccmpout1a (u) (prog (w checksum) (cond ((atom u) (return nil)) (t ( +cond ((eqcar u (quote progn)) (progn (prog (var1251) (setq var1251 (cdr u)) +lab1250 (cond ((null var1251) (return nil))) (prog (v) (setq v (car var1251)) +(c!:ccmpout1a v)) (setq var1251 (cdr var1251)) (go lab1250)) (return nil))) +(t (cond ((eqcar u (quote C!-end)) nil) (t (cond ((or (flagp (car u) (quote +eval)) (and (equal (car u) (quote setq)) (not (atom (caddr u))) (flagp ( +caaddr u) (quote eval)))) (errorset u t !*backtrace))))))))) (cond ((eqcar u +(quote rdf)) (prog nil (setq w (open (setq u (eval (cadr u))) (quote input))) +(cond (w (progn (princ "Reading file ") (print u) (setq w (rds w)) ( +c!:ccompilesupervisor) (princ "End of file ") (print u) (close (rds w)))) (t +(progn (princ "Failed to open file ") (print u)))))) (t (cond ((eqcar u ( +quote de)) (progn (setq u (cdr u)) (setq checksum (md60 u)) (setq c!:defnames +(cons (list (car u) (c!:inv_name (car u)) (length (cadr u)) checksum) +c!:defnames)) (princ "Compiling ") (prin (caar c!:defnames)) (princ " ... ") +(c!:cfndef (caar c!:defnames) (cadar c!:defnames) (cdr u) checksum) (terpri)) +)))))) + +(fluid (quote (!*defn dfprint!* dfprintsave))) + +(de c!:concat (a b) (compress (cons (quote !") (append (explode2 a) (append ( +explode2 b) (quote (!"))))))) + +(de c!:ccompilestart (name setupname dir hdrnow) (prog (o d w) (reset!-gensym +0) (setq c!:registers (setq c!:available (setq c!:used nil))) (setq +File_name (list!-to!-string (explodec name))) (setq Setup_name (explodec +setupname)) (setq Setup_name (subst (quote !_) (quote !-) Setup_name)) (setq +Setup_name (list!-to!-string Setup_name)) (cond (dir (progn (cond ((memq ( +quote win32) lispsystem!*) (setq name (c!:concat dir (c!:concat "\" name)))) +(t (setq name (c!:concat dir (c!:concat "/" name)))))))) (princ "C file = ") +(print name) (setq C_file (open (c!:concat name ".c") (quote output))) (setq +L_file (c!:concat name ".lsp")) (setq L_contents nil) (setq c!:names_so_far +nil) (setq o (reverse (explode (date)))) (prog (i) (setq i 1) lab1252 (cond ( +(minusp (times 1 (difference 5 i))) (return nil))) (progn (setq d (cons (car +o) d)) (setq o (cdr o))) (setq i (plus i 1)) (go lab1252)) (setq d (cons ( +quote !-) d)) (setq o (cdddr (cdddr (cddddr o)))) (setq w o) (setq o (cdddr o +)) (setq d (cons (caddr o) (cons (cadr o) (cons (car o) d)))) (setq d ( +compress (cons (quote !") (cons (cadr w) (cons (car w) (cons (quote !-) d)))) +)) (setq O_file (wrs C_file)) (setq c!:defnames nil) (cond (hdrnow (c!:printf +"\n/* Module: %s %tMachine generated C code %<*/\n\n" setupname 25)) (t ( +c!:printf "\n/* %s.c %tMachine generated C code %<*/\n\n" name 25))) ( +c!:printf "/* Signature: 00000000 %s %<*/\n\n" d) (c!:printf +"#include \n") (c!:printf "#include \n") (c!:printf +"#include \n") (c!:printf "#include \n") (c!:printf +"#include \n") (c!:printf "#include \n") (c!:printf +"#ifndef _cplusplus\n") (c!:printf "#include \n") (c!:printf +"#endif\n\n") (cond (hdrnow (print!-config!-header)) (t (c!:printf +"#include \qconfig.h\q\n\n"))) (print!-csl!-headers) (cond (hdrnow ( +c!:print!-init))) (wrs O_file) (return nil))) + +(de c!:print!-init nil (progn (c!:printf "\n") (c!:printf +"Lisp_Object *C_nilp;\n") (c!:printf "Lisp_Object **C_stackp;\n") (c!:printf +"Lisp_Object * volatile * stacklimitp;\n") (c!:printf "\n") (c!:printf +"void init(Lisp_Object *a, Lisp_Object **b, Lisp_Object * volatile *c)\n") ( +c!:printf "{\n") (c!:printf " C_nilp = a;\n") (c!:printf +" C_stackp = b;\n") (c!:printf " stacklimitp = c;\n") (c!:printf "}\n") +(c!:printf "\n") (c!:printf "#define C_nil (*C_nilp)\n") (c!:printf +"#define C_stack (*C_stackp)\n") (c!:printf +"#define stacklimit (*stacklimitp)\n") (c!:printf "\n"))) + +(de C!-end nil (C!-end1 t)) + +(de C!-end1 (create_lfile) (prog (checksum c1 c2 c3) (wrs C_file) (cond ( +create_lfile (c!:printf "\n\nsetup_type const %s_setup[] =\n{\n" Setup_name)) +(t (c!:printf "\n\nsetup_type_1 const %s_setup[] =\n{\n" Setup_name))) (setq +c!:defnames (reverse c!:defnames)) (prog nil lab1253 (cond ((null +c!:defnames) (return nil))) (prog (name nargs f1 f2 cast fn) (setq name (caar +c!:defnames)) (setq checksum (cadddr (car c!:defnames))) (setq f1 (cadar +c!:defnames)) (setq nargs (caddar c!:defnames)) (setq cast "(n_args *)") ( +cond ((equal nargs 1) (progn (setq f2 (quote !t!o!o_!m!a!n!y_1)) (setq cast +"") (setq fn (quote !w!r!o!n!g_!n!o_1)))) (t (cond ((equal nargs 2) (progn ( +setq f2 f1) (setq f1 (quote !t!o!o_!f!e!w_2)) (setq cast "") (setq fn (quote +!w!r!o!n!g_!n!o_2)))) (t (progn (setq fn f1) (setq f1 (quote +!w!r!o!n!g_!n!o_!n!a)) (setq f2 (quote !w!r!o!n!g_!n!o_!n!b))))))) (cond ( +create_lfile (c!:printf " {\q%s\q,%t%s,%t%s,%t%s%s},\n" name 32 f1 48 f2 +63 cast fn)) (t (prog (c1 c2) (setq c1 (divide checksum (expt 2 31))) (setq +c2 (cdr c1)) (setq c1 (car c1)) (c!:printf +" {\q%s\q, %t%s, %t%s, %t%s%s, %t%s, %t%s},\n" name 24 f1 40 f2 52 cast fn +64 c1 76 c2)))) (setq c!:defnames (cdr c!:defnames))) (go lab1253)) (setq c3 +(setq checksum (md60 L_contents))) (setq c1 (remainder c3 10000000)) (setq +c3 (quotient c3 10000000)) (setq c2 (remainder c3 10000000)) (setq c3 ( +quotient c3 10000000)) (setq checksum (list!-to!-string (append (explodec c3) +(cons (quote ! ) (append (explodec c2) (cons (quote ! ) (explodec c1))))))) +(c!:printf " {NULL, (one_args *)%a, (two_args *)%a, 0}\n};\n\n" Setup_name +checksum) (c!:printf "% (intptr_t)%v) ? lisp_true : nil;\n" r1 r2 r3)) + +(put (quote igreaterp) (quote c!:opcode_printer) (function c!:pigreaterp)) + +(flag (quote (igreaterp)) (quote c!:uses_nil)) + +(de c!:piminus (op r1 r2 r3 depth) (c!:printf +" %v = (Lisp_Object)(2-((int32_t)(%v)));\n" r1 r3)) + +(put (quote iminus) (quote c!:opcode_printer) (function c!:piminus)) + +(de c!:piadd1 (op r1 r2 r3 depth) (c!:printf +" %v = (Lisp_Object)((int32_t)(%v) + 0x10);\n" r1 r3)) + +(put (quote iadd1) (quote c!:opcode_printer) (function c!:piadd1)) + +(de c!:pisub1 (op r1 r2 r3 depth) (c!:printf +" %v = (Lisp_Object)((int32_t)(%v) - 0x10);\n" r1 r3)) + +(put (quote isub1) (quote c!:opcode_printer) (function c!:pisub1)) + +(de c!:piplus2 (op r1 r2 r3 depth) (c!:printf +" %v = (Lisp_Object)(int32_t)((int32_t)%v + (int32_t)%v - TAG_FIXNUM);\n" +r1 r2 r3)) + +(put (quote iplus2) (quote c!:opcode_printer) (function c!:piplus2)) + +(de c!:pidifference (op r1 r2 r3 depth) (c!:printf +" %v = (Lisp_Object)(int32_t)((int32_t)%v - (int32_t)%v + TAG_FIXNUM);\n" +r1 r2 r3)) + +(put (quote idifference) (quote c!:opcode_printer) (function c!:pidifference) +) + +(de c!:pitimes2 (op r1 r2 r3 depth) (c!:printf +" %v = fixnum_of_int((int32_t)(int_of_fixnum(%v) * int_of_fixnum(%v)));\n" +r1 r2 r3)) + +(put (quote itimes2) (quote c!:opcode_printer) (function c!:pitimes2)) + +(de c!:pmodular_plus (op r1 r2 r3 depth) (progn (c!:printf +" { int32_t w = int_of_fixnum(%v) + int_of_fixnum(%v);\n" r2 r3) ( +c!:printf " if (w >= current_modulus) w -= current_modulus;\n") ( +c!:printf " %v = fixnum_of_int(w);\n" r1) (c!:printf " }\n"))) + +(put (quote modular!-plus) (quote c!:opcode_printer) (function +c!:pmodular_plus)) + +(de c!:pmodular_difference (op r1 r2 r3 depth) (progn (c!:printf +" { int32_t w = int_of_fixnum(%v) - int_of_fixnum(%v);\n" r2 r3) ( +c!:printf " if (w < 0) w += current_modulus;\n") (c!:printf +" %v = fixnum_of_int(w);\n" r1) (c!:printf " }\n"))) + +(put (quote modular!-difference) (quote c!:opcode_printer) (function +c!:pmodular_difference)) + +(de c!:pmodular_minus (op r1 r2 r3 depth) (progn (c!:printf +" { int32_t w = int_of_fixnum(%v);\n" r3) (c!:printf +" if (w != 0) w = current_modulus - w;\n") (c!:printf +" %v = fixnum_of_int(w);\n" r1) (c!:printf " }\n"))) + +(put (quote modular!-minus) (quote c!:opcode_printer) (function +c!:pmodular_minus)) + +(de c!:passoc (op r1 r2 r3 depth) (c!:printf +" %v = Lassoc(nil, %v, %v);\n" r1 r2 r3)) + +(put (quote assoc) (quote c!:opcode_printer) (function c!:passoc)) + +(flag (quote (assoc)) (quote c!:uses_nil)) + +(de c!:patsoc (op r1 r2 r3 depth) (c!:printf +" %v = Latsoc(nil, %v, %v);\n" r1 r2 r3)) + +(put (quote atsoc) (quote c!:opcode_printer) (function c!:patsoc)) + +(flag (quote (atsoc)) (quote c!:uses_nil)) + +(de c!:pmember (op r1 r2 r3 depth) (c!:printf +" %v = Lmember(nil, %v, %v);\n" r1 r2 r3)) + +(put (quote member) (quote c!:opcode_printer) (function c!:pmember)) + +(flag (quote (member)) (quote c!:uses_nil)) + +(de c!:pmemq (op r1 r2 r3 depth) (c!:printf " %v = Lmemq(nil, %v, %v);\n" +r1 r2 r3)) + +(put (quote memq) (quote c!:opcode_printer) (function c!:pmemq)) + +(flag (quote (memq)) (quote c!:uses_nil)) + +(de c!:pget (op r1 r2 r3 depth) (c!:printf " %v = get(%v, %v);\n" r1 r2 r3 +)) + +(put (quote get) (quote c!:opcode_printer) (function c!:pget)) + +(de c!:pqgetv (op r1 r2 r3 depth) (progn (c!:printf +" %v = *(Lisp_Object *)((char *)%v + (CELL-TAG_VECTOR) +" r1 r2) ( +c!:printf " ((int32_t)%v/(16/CELL)));\n" r3))) + +(put (quote qgetv) (quote c!:opcode_printer) (function c!:pqgetv)) + +(de c!:pqputv (op r1 r2 r3 depth) (progn (c!:printf +" *(Lisp_Object *)((char *)%v + (CELL-TAG_VECTOR) +" r2) (c!:printf +" ((int32_t)%v/(16/CELL))) = %v;\n" r3 r1))) + +(put (quote qputv) (quote c!:opcode_printer) (function c!:pqputv)) + +(de c!:peq (op r1 r2 r3 depth) (c!:printf +" %v = (%v == %v ? lisp_true : nil);\n" r1 r2 r3)) + +(put (quote eq) (quote c!:opcode_printer) (function c!:peq)) + +(flag (quote (eq)) (quote c!:uses_nil)) + +(de c!:pequal (op r1 r2 r3 depth) (c!:printf +" %v = (equal(%v, %v) ? lisp_true : nil);\n" r1 r2 r3 r2 r3)) + +(put (quote equal) (quote c!:opcode_printer) (function c!:pequal)) + +(flag (quote (equal)) (quote c!:uses_nil)) + +(de c!:pfluidbind (op r1 r2 r3 depth) nil) + +(put (quote fluidbind) (quote c!:opcode_printer) (function c!:pfluidbind)) + +(de c!:pcall (op r1 r2 r3 depth) (prog (w boolfn) (cond ((setq w (get (car r3 +) (quote c!:direct_entrypoint))) (progn (c!:printf " %v = %s(" r1 (cdr w)) +(cond (r2 (progn (c!:printf "%v" (car r2)) (prog (var1269) (setq var1269 ( +cdr r2)) lab1268 (cond ((null var1269) (return nil))) (prog (a) (setq a (car +var1269)) (c!:printf ", %v" a)) (setq var1269 (cdr var1269)) (go lab1268))))) +(c!:printf ");\n"))) (t (cond ((setq w (get (car r3) (quote +c!:direct_predicate))) (progn (setq boolfn t) (c!:printf +" %v = (Lisp_Object)%s(" r1 (cdr w)) (cond (r2 (progn (c!:printf "%v" (car +r2)) (prog (var1271) (setq var1271 (cdr r2)) lab1270 (cond ((null var1271) ( +return nil))) (prog (a) (setq a (car var1271)) (c!:printf ", %v" a)) (setq +var1271 (cdr var1271)) (go lab1270))))) (c!:printf ");\n"))) (t (cond ((equal +(car r3) c!:current_procedure) (progn (setq r2 (c!:fix_nargs r2 +c!:current_args)) (c!:printf " %v = %s(env" r1 c!:current_c_name) (cond (( +or (null r2) (geq (length r2) 3)) (c!:printf ", %s" (length r2)))) (prog ( +var1273) (setq var1273 r2) lab1272 (cond ((null var1273) (return nil))) (prog +(a) (setq a (car var1273)) (c!:printf ", %v" a)) (setq var1273 (cdr var1273) +) (go lab1272)) (c!:printf ");\n"))) (t (cond ((setq w (get (car r3) (quote +c!:c_entrypoint))) (progn (c!:printf " %v = %s(nil" r1 w) (cond ((or (null +r2) (geq (length r2) 3)) (c!:printf ", %s" (length r2)))) (prog (var1275) ( +setq var1275 r2) lab1274 (cond ((null var1275) (return nil))) (prog (a) (setq +a (car var1275)) (c!:printf ", %v" a)) (setq var1275 (cdr var1275)) (go +lab1274)) (c!:printf ");\n"))) (t (prog (nargs) (setq nargs (length r2)) ( +c!:printf " fn = elt(env, %s); % ((int32_t)(%v))" +(car s) (cadr s))) + +(put (quote ifigreaterp) (quote c!:exit_helper) (function c!:pifigreaterp)) + +(de c!:display_flowgraph (s depth dropping_through) (cond ((not (atom s)) ( +progn (c!:printf " ") (c!:pgoto s depth))) (t (cond ((not (flagp s (quote +c!:visited))) (prog (why where_to) (flag (list s) (quote c!:visited)) (cond ( +(or (not dropping_through) (not (equal (get s (quote c!:count)) 1))) ( +c!:printf "\n%s:\n" s))) (prog (var1279) (setq var1279 (reverse (get s (quote +c!:contents)))) lab1278 (cond ((null var1279) (return nil))) (prog (k) (setq +k (car var1279)) (c!:print_opcode k depth)) (setq var1279 (cdr var1279)) (go +lab1278)) (setq why (get s (quote c!:why))) (setq where_to (get s (quote +c!:where_to))) (cond ((and (equal why (quote goto)) (or (not (atom (car +where_to))) (and (not (flagp (car where_to) (quote c!:visited))) (equal (get +(car where_to) (quote c!:count)) 1)))) (c!:display_flowgraph (car where_to) +depth t)) (t (c!:print_exit_condition why where_to depth))))))))) + +(fluid (quote (c!:startpoint))) + +(de c!:branch_chain (s count) (prog (contents why where_to n) (cond ((not ( +atom s)) (return s)) (t (cond ((flagp s (quote c!:visited)) (progn (setq n ( +get s (quote c!:count))) (cond ((null n) (setq n 1)) (t (setq n (plus n 1)))) +(put s (quote c!:count) n) (return s)))))) (flag (list s) (quote c!:visited) +) (setq contents (get s (quote c!:contents))) (setq why (get s (quote c!:why) +)) (setq where_to (prog (var1281 var1282) (setq var1281 (get s (quote +c!:where_to))) lab1280 (cond ((null var1281) (return (reversip var1282)))) ( +prog (z) (setq z (car var1281)) (setq var1282 (cons (c!:branch_chain z count) +var1282))) (setq var1281 (cdr var1281)) (go lab1280))) (prog nil lab1283 ( +cond ((null (and contents (eqcar (car contents) (quote movr)) (equal why ( +quote goto)) (not (atom (car where_to))) (equal (caar where_to) (cadr (car +contents))))) (return nil))) (progn (setq where_to (list (list (cadddr (car +contents))))) (setq contents (cdr contents))) (go lab1283)) (put s (quote +c!:contents) contents) (put s (quote c!:where_to) where_to) (cond ((and (null +contents) (equal why (quote goto))) (progn (remflag (list s) (quote +c!:visited)) (return (car where_to))))) (cond (count (progn (setq n (get s ( +quote c!:count))) (cond ((null n) (setq n 1)) (t (setq n (plus n 1)))) (put s +(quote c!:count) n)))) (return s))) + +(de c!:one_operand (op) (progn (flag (list op) (quote c!:set_r1)) (flag (list +op) (quote c!:read_r3)) (put op (quote c!:code) (function c!:builtin_one)))) + +(de c!:two_operands (op) (progn (flag (list op) (quote c!:set_r1)) (flag ( +list op) (quote c!:read_r2)) (flag (list op) (quote c!:read_r3)) (put op ( +quote c!:code) (function c!:builtin_two)))) + +(prog (var1285) (setq var1285 (quote (car cdr qcar qcdr null not atom numberp +fixp iminusp iminus iadd1 isub1 modular!-minus))) lab1284 (cond ((null +var1285) (return nil))) (prog (n) (setq n (car var1285)) (c!:one_operand n)) +(setq var1285 (cdr var1285)) (go lab1284)) + +(prog (var1287) (setq var1287 (quote (eq equal atsoc memq iplus2 idifference +assoc member itimes2 ilessp igreaterp qgetv get modular!-plus +modular!-difference))) lab1286 (cond ((null var1287) (return nil))) (prog (n) +(setq n (car var1287)) (c!:two_operands n)) (setq var1287 (cdr var1287)) (go +lab1286)) + +(flag (quote (movr movk movk1 ldrglob call reloadenv fastget fastflag)) ( +quote c!:set_r1)) + +(flag (quote (strglob qputv)) (quote c!:read_r1)) + +(flag (quote (qputv fastget fastflag)) (quote c!:read_r2)) + +(flag (quote (movr qputv)) (quote c!:read_r3)) + +(flag (quote (ldrglob strglob nilglob movk call)) (quote c!:read_env)) + +(fluid (quote (fn_used nil_used nilbase_used))) + +(de c!:live_variable_analysis (c!:all_blocks) (prog (changed z) (prog nil +lab1294 (progn (setq changed nil) (prog (var1293) (setq var1293 c!:all_blocks +) lab1292 (cond ((null var1293) (return nil))) (prog (b) (setq b (car var1293 +)) (prog (w live) (prog (var1289) (setq var1289 (get b (quote c!:where_to))) +lab1288 (cond ((null var1289) (return nil))) (prog (x) (setq x (car var1289)) +(cond ((atom x) (setq live (union live (get x (quote c!:live))))) (t (setq +live (union live x))))) (setq var1289 (cdr var1289)) (go lab1288)) (setq w ( +get b (quote c!:why))) (cond ((not (atom w)) (progn (cond ((or (eqcar w ( +quote ifnull)) (eqcar w (quote ifequal))) (setq nil_used t))) (setq live ( +union live (cdr w))) (cond ((and (eqcar (car w) (quote call)) (or (flagp ( +cadar w) (quote c!:direct_predicate)) (and (flagp (cadar w) (quote +c!:c_entrypoint)) (not (flagp (cadar w) (quote c!:direct_entrypoint)))))) ( +setq nil_used t))) (cond ((and (eqcar (car w) (quote call)) (not (equal ( +cadar w) c!:current_procedure)) (not (get (cadar w) (quote +c!:direct_entrypoint))) (not (get (cadar w) (quote c!:c_entrypoint)))) (progn +(setq fn_used t) (setq live (union (quote (env)) live)))))))) (prog (var1291 +) (setq var1291 (get b (quote c!:contents))) lab1290 (cond ((null var1291) ( +return nil))) (prog (s) (setq s (car var1291)) (prog (op r1 r2 r3) (setq op ( +car s)) (setq r1 (cadr s)) (setq r2 (caddr s)) (setq r3 (cadddr s)) (cond (( +equal op (quote movk1)) (progn (cond ((equal r3 nil) (setq nil_used t)) (t ( +cond ((equal r3 (quote t)) (setq nilbase_used t))))))) (t (cond ((and (atom +op) (flagp op (quote c!:uses_nil))) (setq nil_used t))))) (cond ((flagp op ( +quote c!:set_r1)) (cond ((memq r1 live) (setq live (delete r1 live))) (t ( +cond ((equal op (quote call)) nil) (t (setq op (quote nop)))))))) (cond (( +flagp op (quote c!:read_r1)) (setq live (union live (list r1))))) (cond (( +flagp op (quote c!:read_r2)) (setq live (union live (list r2))))) (cond (( +flagp op (quote c!:read_r3)) (setq live (union live (list r3))))) (cond (( +equal op (quote call)) (progn (cond ((or (not (flagp (car r3) (quote +c!:no_errors))) (flagp (car r3) (quote c!:c_entrypoint)) (get (car r3) (quote +c!:direct_predicate))) (setq nil_used t))) (setq does_call t) (cond ((and ( +not (eqcar r3 c!:current_procedure)) (not (get (car r3) (quote +c!:direct_entrypoint))) (not (get (car r3) (quote c!:c_entrypoint)))) (setq +fn_used t))) (cond ((not (flagp (car r3) (quote c!:no_errors))) (flag live ( +quote c!:live_across_call)))) (setq live (union live r2))))) (cond ((flagp op +(quote c!:read_env)) (setq live (union live (quote (env)))))))) (setq +var1291 (cdr var1291)) (go lab1290)) (setq live (sort live (function orderp)) +) (cond ((not (equal live (get b (quote c!:live)))) (progn (put b (quote +c!:live) live) (setq changed t)))))) (setq var1293 (cdr var1293)) (go lab1292 +))) (cond ((null (not changed)) (go lab1294)))) (setq z c!:registers) (setq +c!:registers (setq c!:stacklocs nil)) (prog (var1296) (setq var1296 z) +lab1295 (cond ((null var1296) (return nil))) (prog (r) (setq r (car var1296)) +(cond ((flagp r (quote c!:live_across_call)) (setq c!:stacklocs (cons r +c!:stacklocs))) (t (setq c!:registers (cons r c!:registers))))) (setq var1296 +(cdr var1296)) (go lab1295)))) + +(de c!:insert1 (a b) (cond ((memq a b) b) (t (cons a b)))) + +(de c!:clash (a b) (cond ((equal (flagp a (quote c!:live_across_call)) (flagp +b (quote c!:live_across_call))) (progn (put a (quote c!:clash) (c!:insert1 b +(get a (quote c!:clash)))) (put b (quote c!:clash) (c!:insert1 a (get b ( +quote c!:clash)))))))) + +(de c!:build_clash_matrix (c!:all_blocks) (prog nil (prog (var1304) (setq +var1304 c!:all_blocks) lab1303 (cond ((null var1304) (return nil))) (prog (b) +(setq b (car var1304)) (prog (live w) (prog (var1298) (setq var1298 (get b ( +quote c!:where_to))) lab1297 (cond ((null var1298) (return nil))) (prog (x) ( +setq x (car var1298)) (cond ((atom x) (setq live (union live (get x (quote +c!:live))))) (t (setq live (union live x))))) (setq var1298 (cdr var1298)) ( +go lab1297)) (setq w (get b (quote c!:why))) (cond ((not (atom w)) (progn ( +setq live (union live (cdr w))) (cond ((and (eqcar (car w) (quote call)) (not +(get (cadar w) (quote c!:direct_entrypoint))) (not (get (cadar w) (quote +c!:c_entrypoint)))) (setq live (union (quote (env)) live))))))) (prog ( +var1302) (setq var1302 (get b (quote c!:contents))) lab1301 (cond ((null +var1302) (return nil))) (prog (s) (setq s (car var1302)) (prog (op r1 r2 r3) +(setq op (car s)) (setq r1 (cadr s)) (setq r2 (caddr s)) (setq r3 (cadddr s)) +(cond ((flagp op (quote c!:set_r1)) (cond ((memq r1 live) (progn (setq live +(delete r1 live)) (cond ((equal op (quote reloadenv)) (setq reloadenv t))) ( +prog (var1300) (setq var1300 live) lab1299 (cond ((null var1300) (return nil) +)) (prog (v) (setq v (car var1300)) (c!:clash r1 v)) (setq var1300 (cdr +var1300)) (go lab1299)))) (t (cond ((equal op (quote call)) nil) (t (progn ( +setq op (quote nop)) (rplacd s (cons (car s) (cdr s))) (rplaca s op)))))))) ( +cond ((flagp op (quote c!:read_r1)) (setq live (union live (list r1))))) ( +cond ((flagp op (quote c!:read_r2)) (setq live (union live (list r2))))) ( +cond ((flagp op (quote c!:read_r3)) (setq live (union live (list r3))))) ( +cond ((equal op (quote call)) (setq live (union live r2)))) (cond ((flagp op +(quote c!:read_env)) (setq live (union live (quote (env)))))))) (setq var1302 +(cdr var1302)) (go lab1301)))) (setq var1304 (cdr var1304)) (go lab1303)) ( +return nil))) + +(de c!:allocate_registers (rl) (prog (schedule neighbours allocation) (setq +neighbours 0) (prog nil lab1308 (cond ((null rl) (return nil))) (prog (w x) ( +setq w rl) (prog nil lab1305 (cond ((null (and w (greaterp (length (setq x ( +get (car w) (quote c!:clash)))) neighbours))) (return nil))) (setq w (cdr w)) +(go lab1305)) (cond (w (progn (setq schedule (cons (car w) schedule)) (setq +rl (deleq (car w) rl)) (prog (var1307) (setq var1307 x) lab1306 (cond ((null +var1307) (return nil))) (prog (r) (setq r (car var1307)) (put r (quote +c!:clash) (deleq (car w) (get r (quote c!:clash))))) (setq var1307 (cdr +var1307)) (go lab1306)))) (t (setq neighbours (plus neighbours 1))))) (go +lab1308)) (prog (var1312) (setq var1312 schedule) lab1311 (cond ((null +var1312) (return nil))) (prog (r) (setq r (car var1312)) (prog (poss) (setq +poss allocation) (prog (var1310) (setq var1310 (get r (quote c!:clash))) +lab1309 (cond ((null var1310) (return nil))) (prog (x) (setq x (car var1310)) +(setq poss (deleq (get x (quote c!:chosen)) poss))) (setq var1310 (cdr +var1310)) (go lab1309)) (cond ((null poss) (progn (setq poss (c!:my_gensym)) +(setq allocation (append allocation (list poss))))) (t (setq poss (car poss)) +)) (put r (quote c!:chosen) poss))) (setq var1312 (cdr var1312)) (go lab1311) +) (return allocation))) + +(de c!:remove_nops (c!:all_blocks) (prog (var1322) (setq var1322 +c!:all_blocks) lab1321 (cond ((null var1322) (return nil))) (prog (b) (setq b +(car var1322)) (prog (r) (prog (var1317) (setq var1317 (get b (quote +c!:contents))) lab1316 (cond ((null var1317) (return nil))) (prog (s) (setq s +(car var1317)) (cond ((not (eqcar s (quote nop))) (prog (op r1 r2 r3) (setq +op (car s)) (setq r1 (cadr s)) (setq r2 (caddr s)) (setq r3 (cadddr s)) (cond +((or (flagp op (quote c!:set_r1)) (flagp op (quote c!:read_r1))) (setq r1 ( +get r1 (quote c!:chosen))))) (cond ((flagp op (quote c!:read_r2)) (setq r2 ( +get r2 (quote c!:chosen))))) (cond ((flagp op (quote c!:read_r3)) (setq r3 ( +get r3 (quote c!:chosen))))) (cond ((equal op (quote call)) (setq r2 (prog ( +var1314 var1315) (setq var1314 r2) lab1313 (cond ((null var1314) (return ( +reversip var1315)))) (prog (v) (setq v (car var1314)) (setq var1315 (cons ( +get v (quote c!:chosen)) var1315))) (setq var1314 (cdr var1314)) (go lab1313) +)))) (cond ((not (and (equal op (quote movr)) (equal r1 r3))) (setq r (cons ( +list op r1 r2 r3) r)))))))) (setq var1317 (cdr var1317)) (go lab1316)) (put b +(quote c!:contents) (reversip r)) (setq r (get b (quote c!:why))) (cond (( +not (atom r)) (put b (quote c!:why) (cons (car r) (prog (var1319 var1320) ( +setq var1319 (cdr r)) lab1318 (cond ((null var1319) (return (reversip var1320 +)))) (prog (v) (setq v (car var1319)) (setq var1320 (cons (get v (quote +c!:chosen)) var1320))) (setq var1319 (cdr var1319)) (go lab1318)))))))) (setq +var1322 (cdr var1322)) (go lab1321))) + +(fluid (quote (c!:error_labels))) + +(de c!:find_error_label (why env depth) (prog (w z) (setq z (list why env +depth)) (setq w (assoc!*!* z c!:error_labels)) (cond ((null w) (progn (setq w +(cons z (c!:my_gensym))) (setq c!:error_labels (cons w c!:error_labels))))) +(return (cdr w)))) + +(de c!:assign (u v c) (cond ((flagp u (quote fluid)) (cons (list (quote +strglob) v u (c!:find_literal u)) c)) (t (cons (list (quote movr) u nil v) c) +))) + +(de c!:insert_tailcall (b) (prog (why dest contents fcall res w) (setq why ( +get b (quote c!:why))) (setq dest (get b (quote c!:where_to))) (setq contents +(get b (quote c!:contents))) (prog nil lab1323 (cond ((null (and contents ( +not (eqcar (car contents) (quote call))))) (return nil))) (progn (setq w ( +cons (car contents) w)) (setq contents (cdr contents))) (go lab1323)) (cond ( +(null contents) (return nil))) (setq fcall (car contents)) (setq contents ( +cdr contents)) (setq res (cadr fcall)) (prog nil lab1324 (cond ((null w) ( +return nil))) (progn (cond ((eqcar (car w) (quote reloadenv)) (setq w (cdr w) +)) (t (cond ((and (eqcar (car w) (quote movr)) (equal (cadddr (car w)) res)) +(progn (setq res (cadr (car w))) (setq w (cdr w)))) (t (setq res (setq w nil) +)))))) (go lab1324)) (cond ((null res) (return nil))) (cond ((c!:does_return +res why dest) (cond ((equal (car (cadddr fcall)) c!:current_procedure) (progn +(prog (var1326) (setq var1326 (pair c!:current_args (caddr fcall))) lab1325 +(cond ((null var1326) (return nil))) (prog (p) (setq p (car var1326)) (setq +contents (c!:assign (car p) (cdr p) contents))) (setq var1326 (cdr var1326)) +(go lab1325)) (put b (quote c!:contents) contents) (put b (quote c!:why) ( +quote goto)) (put b (quote c!:where_to) (list restart_label)))) (t (progn ( +setq nil_used t) (put b (quote c!:contents) contents) (put b (quote c!:why) ( +cons (list (quote call) (car (cadddr fcall))) (caddr fcall))) (put b (quote +c!:where_to) nil)))))))) + +(de c!:does_return (res why where_to) (cond ((not (equal why (quote goto))) +nil) (t (cond ((not (atom (car where_to))) (equal res (caar where_to))) (t ( +prog (contents) (setq where_to (car where_to)) (setq contents (reverse (get +where_to (quote c!:contents)))) (setq why (get where_to (quote c!:why))) ( +setq where_to (get where_to (quote c!:where_to))) (prog nil lab1327 (cond (( +null contents) (return nil))) (cond ((eqcar (car contents) (quote reloadenv)) +(setq contents (cdr contents))) (t (cond ((and (eqcar (car contents) (quote +movr)) (equal (cadddr (car contents)) res)) (progn (setq res (cadr (car +contents))) (setq contents (cdr contents)))) (t (setq res (setq contents nil) +))))) (go lab1327)) (cond ((null res) (return nil)) (t (return ( +c!:does_return res why where_to)))))))))) + +(de c!:pushpop (op v) (prog (n w) (cond ((null v) (return nil))) (setq n ( +length v)) (prog nil lab1329 (cond ((null (greaterp n 0)) (return nil))) ( +progn (setq w n) (cond ((greaterp w 6) (setq w 6))) (setq n (difference n w)) +(cond ((equal w 1) (c!:printf " %s(%s);\n" op (car v))) (t (progn ( +c!:printf " %s%d(%s" op w (car v)) (setq v (cdr v)) (prog (i) (setq i +2) lab1328 (cond ((minusp (times 1 (difference w i))) (return nil))) (progn ( +c!:printf ",%s" (car v)) (setq v (cdr v))) (setq i (plus i 1)) (go lab1328)) +(c!:printf ");\n"))))) (go lab1329)))) + +(de c!:optimise_flowgraph (c!:startpoint c!:all_blocks env argch args) (prog +(w n locs stacks c!:error_labels fn_used nil_used nilbase_used) (prog ( +var1331) (setq var1331 c!:all_blocks) lab1330 (cond ((null var1331) (return +nil))) (prog (b) (setq b (car var1331)) (c!:insert_tailcall b)) (setq var1331 +(cdr var1331)) (go lab1330)) (setq c!:startpoint (c!:branch_chain +c!:startpoint nil)) (remflag c!:all_blocks (quote c!:visited)) ( +c!:live_variable_analysis c!:all_blocks) (c!:build_clash_matrix c!:all_blocks +) (cond ((and c!:error_labels env) (setq reloadenv t))) (prog (var1335) (setq +var1335 env) lab1334 (cond ((null var1335) (return nil))) (prog (u) (setq u +(car var1335)) (prog (var1333) (setq var1333 env) lab1332 (cond ((null +var1333) (return nil))) (prog (v) (setq v (car var1333)) (c!:clash (cdr u) ( +cdr v))) (setq var1333 (cdr var1333)) (go lab1332))) (setq var1335 (cdr +var1335)) (go lab1334)) (setq locs (c!:allocate_registers c!:registers)) ( +setq stacks (c!:allocate_registers c!:stacklocs)) (flag stacks (quote +c!:live_across_call)) (c!:remove_nops c!:all_blocks) (setq c!:startpoint ( +c!:branch_chain c!:startpoint nil)) (remflag c!:all_blocks (quote c!:visited) +) (setq c!:startpoint (c!:branch_chain c!:startpoint t)) (remflag +c!:all_blocks (quote c!:visited)) (cond (does_call (setq nil_used t))) (cond +(nil_used (c!:printf " Lisp_Object nil = C_nil;\n")) (t (cond ( +nilbase_used (c!:printf " nil_as_base\n"))))) (cond (locs (progn ( +c!:printf " Lisp_Object %s" (car locs)) (prog (var1337) (setq var1337 (cdr +locs)) lab1336 (cond ((null var1337) (return nil))) (prog (v) (setq v (car +var1337)) (c!:printf ", %s" v)) (setq var1337 (cdr var1337)) (go lab1336)) ( +c!:printf ";\n")))) (cond (fn_used (c!:printf " Lisp_Object fn;\n"))) ( +cond (nil_used (c!:printf " CSL_IGNORE(nil);\n")) (t (cond (nilbase_used ( +progn (c!:printf "#ifndef NILSEG_EXTERNS\n") (c!:printf +" CSL_IGNORE(nil);\n") (c!:printf "#endif\n")))))) (cond ((or (equal (car +argch) 0) (geq (car argch) 3)) (c!:printf +" argcheck(nargs, %s, \q%s\q);\n" (car argch) (cdr argch)))) (c!:printf +"#ifdef DEBUG\n") (c!:printf +" if (check_env(env)) return aerror(\qenv for %s\q);\n" (cdr argch)) ( +c!:printf "#endif\n") (cond (does_call (progn (c!:printf +" if (stack >= stacklimit)\n") (c!:printf " {\n") (c!:pushpop (quote +push) args) (c!:printf +" env = reclaim(env, \qstack\q, GC_STACK, 0);\n") (c!:pushpop (quote +pop) (reverse args)) (c!:printf " nil = C_nil;\n") (c!:printf +" if (exception_pending()) return nil;\n") (c!:printf " }\n")))) ( +cond (reloadenv (c!:printf " push(env);\n")) (t (c!:printf +" CSL_IGNORE(env);\n"))) (setq n 0) (cond (stacks (progn (c!:printf +"%>; + return list(n, 'opcodes, 'allocated) +end; + +s!:opcodelist := nil; + +fluid '(s!:env_alist); + +symbolic procedure s!:vecof l; + begin + scalar w; + w := assoc(l, s!:env_alist); + if w then return cdr w; + w := s!:vecof1 l; + s!:env_alist := (l . w) . s!:env_alist; + return w + end; + +symbolic procedure s!:vecof1 l; + begin + scalar v, n; + v := mkvect sub1 length l; + n := 0; + for each x in l do << + putv(v, n, x); + n := n+1 >>; + return v + end; + +<< put('batchp, 's!:builtin0, 0); + put('date, 's!:builtin0, 1); + put('eject, 's!:builtin0, 2); + put('error1, 's!:builtin0, 3); + put('gctime, 's!:builtin0, 4); +% put('gensym, 's!:builtin0, 5); + put('lposn, 's!:builtin0, 6); +% put('next!-random, 's!:builtin0, 7); + put('posn, 's!:builtin0, 8); + put('read, 's!:builtin0, 9); + put('readch, 's!:builtin0, 10); + put('terpri, 's!:builtin0, 11); +!#if (not common!-lisp!-mode) + put('time, 's!:builtin0, 12); +!#endif + put('tyi, 's!:builtin0, 13); +% load!-spid is not for use by an ordinary programmer - it is used in the +% compilation of unwind!-protect. + put('load!-spid, 's!:builtin0, 14); + + put('abs, 's!:builtin1, 0); + put('add1, 's!:builtin1, 1); +!#if common!-lisp!-mode + put('!1!+, 's!:builtin1, 1); +!#endif +!#if (not common!-lisp!-mode) + put('atan, 's!:builtin1, 2); +!#endif + put('apply0, 's!:builtin1, 3); + put('atom, 's!:builtin1, 4); + put('boundp, 's!:builtin1, 5); + put('char!-code, 's!:builtin1, 6); + put('close, 's!:builtin1, 7); + put('codep, 's!:builtin1, 8); +!#if (not common!-lisp!-mode) + put('compress, 's!:builtin1, 9); +!#endif + put('constantp, 's!:builtin1, 10); + put('digit, 's!:builtin1, 11); + put('endp, 's!:builtin1, 12); + put('eval, 's!:builtin1, 13); + put('evenp, 's!:builtin1, 14); + put('evlis, 's!:builtin1, 15); + put('explode, 's!:builtin1, 16); + put('explode2lc, 's!:builtin1, 17); + put('explode2, 's!:builtin1, 18); + put('explodec, 's!:builtin1, 18); + put('fixp, 's!:builtin1, 19); +!#if (not common!-lisp!-mode) + put('float, 's!:builtin1, 20); +!#endif + put('floatp, 's!:builtin1, 21); + put('symbol!-specialp, 's!:builtin1, 22); + put('gc, 's!:builtin1, 23); + put('gensym1, 's!:builtin1, 24); + put('getenv, 's!:builtin1, 25); + put('symbol!-globalp, 's!:builtin1, 26); + put('iadd1, 's!:builtin1, 27); + put('symbolp, 's!:builtin1, 28); + put('iminus, 's!:builtin1, 29); + put('iminusp, 's!:builtin1, 30); + put('indirect, 's!:builtin1, 31); + put('integerp, 's!:builtin1, 32); +!#if (not common!-lisp!-mode) + put('intern, 's!:builtin1, 33); +!#endif + put('isub1, 's!:builtin1, 34); + put('length, 's!:builtin1, 35); + put('lengthc, 's!:builtin1, 36); + put('linelength, 's!:builtin1, 37); + put('liter, 's!:builtin1, 38); + put('load!-module, 's!:builtin1, 39); + put('lognot, 's!:builtin1, 40); +!#if (not common!-lisp!-mode) + put('macroexpand, 's!:builtin1, 41); + put('macroexpand!-1, 's!:builtin1, 42); +!#endif + put('macro!-function, 's!:builtin1, 43); + put('make!-bps, 's!:builtin1, 44); + put('make!-global, 's!:builtin1, 45); + put('make!-simple!-string, 's!:builtin1, 46); + put('make!-special, 's!:builtin1, 47); + put('minus, 's!:builtin1, 48); + put('minusp, 's!:builtin1, 49); + put('mkvect, 's!:builtin1, 50); + put('modular!-minus, 's!:builtin1, 51); + put('modular!-number, 's!:builtin1, 52); + put('modular!-reciprocal, 's!:builtin1, 53); + put('null, 's!:builtin1, 54); + put('oddp, 's!:builtin1, 55); + put('onep, 's!:builtin1, 56); + put('pagelength, 's!:builtin1, 57); + put('pairp, 's!:builtin1, 58); + put('plist, 's!:builtin1, 59); + put('plusp, 's!:builtin1, 60); +!#if (not common!-lisp!-mode) + put('prin, 's!:builtin1, 61); + put('princ, 's!:builtin1, 62); + put('print, 's!:builtin1, 63); + put('printc, 's!:builtin1, 64); +!#endif +% put('random, 's!:builtin1, 65); +% put('rational, 's!:builtin1, 66); +% put('load, 's!:builtin1, 67); + put('rds, 's!:builtin1, 68); + put('remd, 's!:builtin1, 69); +!#if (not common!-lisp!-mode) + put('reverse, 's!:builtin1, 70); +!#endif + put('reversip, 's!:builtin1, 71); + put('seprp, 's!:builtin1, 72); + put('set!-small!-modulus, 's!:builtin1, 73); + put('spaces, 's!:builtin1, 74); + put('xtab, 's!:builtin1, 74); % = spaces? + put('special!-char, 's!:builtin1, 75); + put('special!-form!-p, 's!:builtin1, 76); + put('spool, 's!:builtin1, 77); + put('stop, 's!:builtin1, 78); +!#if (not common!-lisp!-mode) + put('stringp, 's!:builtin1, 79); +!#endif + put('sub1, 's!:builtin1, 80); +!#if common!-lisp!-mode + put('!1!-, 's!:builtin1, 80); +!#endif + put('symbol!-env, 's!:builtin1, 81); + put('symbol!-function, 's!:builtin1, 82); + put('symbol!-name, 's!:builtin1, 83); + put('symbol!-value, 's!:builtin1, 84); + put('system, 's!:builtin1, 85); +!#if (not common!-lisp!-mode) + put('fix, 's!:builtin1, 86); +!#endif + put('ttab, 's!:builtin1, 87); + put('tyo, 's!:builtin1, 88); +!#if (not common!-lisp!-mode) + put('remob, 's!:builtin1, 89); +!#endif + put('unmake!-global, 's!:builtin1, 90); + put('unmake!-special, 's!:builtin1, 91); + put('upbv, 's!:builtin1, 92); +!#if (not common!-lisp!-mode) + put('vectorp, 's!:builtin1, 93); +!#else + put('simple!-vectorp, 's!:builtin1, 93); +!#endif + put('verbos, 's!:builtin1, 94); + put('wrs, 's!:builtin1, 95); + put('zerop, 's!:builtin1, 96); +% car, cdr etc will pretty-well always turn into single byte operations +% rather than the builtin calls listed here. So the next few lines are +% probably redundant. + put('car, 's!:builtin1, 97); + put('cdr, 's!:builtin1, 98); + put('caar, 's!:builtin1, 99); + put('cadr, 's!:builtin1, 100); + put('cdar, 's!:builtin1, 101); + put('cddr, 's!:builtin1, 102); + put('qcar, 's!:builtin1, 103); + put('qcdr, 's!:builtin1, 104); + put('qcaar, 's!:builtin1, 105); + put('qcadr, 's!:builtin1, 106); + put('qcdar, 's!:builtin1, 107); + put('qcddr, 's!:builtin1, 108); + put('ncons, 's!:builtin1, 109); + put('numberp, 's!:builtin1, 110); +% is!-spid and spid!-to!-nil are NOT for direct use by ordinary programmers. +% They are part of the support for &optional arguments. + put('is!-spid, 's!:builtin1, 111); + put('spid!-to!-nil, 's!:builtin1, 112); +!#if common!-lisp!-mode + put('mv!-list!*, 's!:builtin1, 113); +!#endif + put('append, 's!:builtin2, 0); + put('ash, 's!:builtin2, 1); +!#if (not common!-lisp!-mode) + put('assoc, 's!:builtin2, 2); +!#endif + put('assoc!*!*, 's!:builtin2, 2); + put('atsoc, 's!:builtin2, 3); + put('deleq, 's!:builtin2, 4); +!#if (not common!-lisp!-mode) + put('delete, 's!:builtin2, 5); + put('divide, 's!:builtin2, 6); +!#endif + put('eqcar, 's!:builtin2, 7); + put('eql, 's!:builtin2, 8); +!#if (not common!-lisp!-mode) + put('eqn, 's!:builtin2, 9); +!#endif + put('expt, 's!:builtin2, 10); + put('flag, 's!:builtin2, 11); + put('flagpcar, 's!:builtin2, 12); +!#if (not common!-lisp!-mode) + put('gcdn, 's!:builtin2, 13); +!#endif + put('geq, 's!:builtin2, 14); + put('getv, 's!:builtin2, 15); + put('greaterp, 's!:builtin2, 16); + put('idifference, 's!:builtin2, 17); + put('igreaterp, 's!:builtin2, 18); + put('ilessp, 's!:builtin2, 19); + put('imax, 's!:builtin2, 20); + put('imin, 's!:builtin2, 21); + put('iplus2, 's!:builtin2, 22); + put('iquotient, 's!:builtin2, 23); + put('iremainder, 's!:builtin2, 24); + put('irightshift, 's!:builtin2, 25); + put('itimes2, 's!:builtin2, 26); +!#if (not common!-lisp!-mode) +% put('lcm, 's!:builtin2, 27); +!#endif + put('leq, 's!:builtin2, 28); + put('lessp, 's!:builtin2, 29); +% put('make!-random!-state, 's!:builtin2, 30); + put('max2, 's!:builtin2, 31); +!#if (not common!-lisp!-mode) + put('member, 's!:builtin2, 32); +!#endif + put('member!*!*, 's!:builtin2, 32); + put('memq, 's!:builtin2, 33); + put('min2, 's!:builtin2, 34); + put('mod, 's!:builtin2, 35); + put('modular!-difference, 's!:builtin2, 36); + put('modular!-expt, 's!:builtin2, 37); + put('modular!-plus, 's!:builtin2, 38); + put('modular!-quotient, 's!:builtin2, 39); + put('modular!-times, 's!:builtin2, 40); + put('nconc, 's!:builtin2, 41); + put('neq, 's!:builtin2, 42); + put('orderp, 's!:builtin2, 43); +% put('ordp, 's!:builtin2, 43); % alternative name +!#if (not common!-lisp!-mode) + put('quotient, 's!:builtin2, 44); +!#endif + put('remainder, 's!:builtin2, 45); + put('remflag, 's!:builtin2, 46); + put('remprop, 's!:builtin2, 47); + put('rplaca, 's!:builtin2, 48); + put('rplacd, 's!:builtin2, 49); + put('schar, 's!:builtin2, 50); + put('set, 's!:builtin2, 51); + put('smemq, 's!:builtin2, 52); + put('subla, 's!:builtin2, 53); + put('sublis, 's!:builtin2, 54); + put('symbol!-set!-definition, 's!:builtin2, 55); + put('symbol!-set!-env, 's!:builtin2, 56); + put('times2, 's!:builtin2, 57); + put('xcons, 's!:builtin2, 58); + put('equal, 's!:builtin2, 59); + put('eq, 's!:builtin2, 60); + put('cons, 's!:builtin2, 61); + put('list2, 's!:builtin2, 62); +!#if (not common!-lisp!-mode) + put('get, 's!:builtin2, 63); +!#endif + put('qgetv, 's!:builtin2, 64); + put('flagp, 's!:builtin2, 65); + put('apply1, 's!:builtin2, 66); + put('difference, 's!:builtin2, 67); + put('plus2, 's!:builtin2, 68); + put('times2, 's!:builtin2, 69); + put('equalcar, 's!:builtin2, 70); + put('iequal, 's!:builtin2, 71); + put('nreverse, 's!:builtin2, 72); + + put('bps!-putv, 's!:builtin3, 0); + put('errorset, 's!:builtin3, 1); + put('list2!*, 's!:builtin3, 2); + put('list3, 's!:builtin3, 3); + put('putprop, 's!:builtin3, 4); + put('putv, 's!:builtin3, 5); + put('putv!-char, 's!:builtin3, 6); + put('subst, 's!:builtin3, 7); + put('apply2, 's!:builtin3, 8); + put('acons, 's!:builtin3, 9); + nil >>; + + +% Hex printing, for use when displaying assembly code + +symbolic procedure s!:prinhex1 n; + princ schar("0123456789abcdef", logand(n, 15)); + +symbolic procedure s!:prinhex2 n; + << s!:prinhex1 truncate(n, 16); + s!:prinhex1 n >>; + +symbolic procedure s!:prinhex4 n; + << s!:prinhex2 truncate(n, 256); + s!:prinhex2 n >>; + +% +% The rather elaborate scheme here is to allow for the possibility that the +% horrid user may have defined one of these variables before loading in +% the compiler - I do not want to clobber the user's settings. +% + +flag('(comp plap pgwd pwrds notailcall ord nocompile + carcheckflag savedef carefuleq r2i + native_code save_native strip_native), 'switch); % for RLISP + +if not boundp '!*comp then << % compile automatically on "de" + fluid '(!*comp); + !*comp := t >>; + +if not boundp '!*nocompile then << % do not compile when fasling + fluid '(!*nocompile); + !*nocompile := nil >>; + +if not boundp '!*plap then << % print generated bytecodes + fluid '(!*plap); + !*plap := nil >>; + +if not boundp '!*pgwd then << % equivalent to *plap here + fluid '(!*pgwd); + !*pgwd := nil >>; + +if not boundp '!*pwrds then << % display size of generated code + fluid '(!*pwrds); + !*pwrds := t >>; + +if not boundp '!*notailcall then << % disable an optimisation + fluid '(!*notailcall); + !*notailcall := nil >>; + +if not boundp '!*ord then << % disable an optimisation wrt evaluation order + fluid '(!*ord); + !*ord := nil >>; + +if not boundp '!*savedef then << % keep interpretable definition on p-list + fluid '(!*savedef); + !*savedef := nil >>; + +if not boundp '!*carcheckflag then << % safety/speed control + fluid '(!*carcheckflag); + !*carcheckflag := t >>; + +if not boundp '!*carefuleq then << % force EQ to be function call + fluid '(!*carefuleq); % to permit checking of (EQ number number) + !*carefuleq := (boundp 'lispsystem!* and + not null (member('jlisp, lispsystem!*))) or + (boundp '!*features!* and + not null (member('!:jlisp, !*features!*))) >>; + +if not boundp '!*r2i then << % apply Recursion to Iteration conversions + fluid '(!*r2i); + !*r2i := t >>; + +% If this flag is set then I will generate C code for the functions that +% I compile as well as the usual bytecoded stuff for the FASL file. +% Making it all link up is a slight delicacy! + +if not boundp '!*native_code then << % Compile via C + fluid '(!*native_code); +% By default I will leave compilation into native code switched off +% at this level. When I build an image I will adjust the switch +% to set a more carefully selected application-specific default. + !*native_code := nil >>; + +if not boundp '!*save_native then << % Do not delete the C code (for debugging) + fluid '(!*save_native); + !*save_native := nil >>; + +if not boundp '!*strip_native then << % strip symbols from C code + fluid '(!*strip_native); + !*strip_native := t >>; % At least on Windows not stripping uses a LOT of space + +global '(s!:native_file); + +fluid '(s!:current_function s!:current_label s!:current_block s!:current_size + s!:current_procedure s!:other_defs s!:lexical_env s!:has_closure + s!:recent_literals s!:used_lexicals s!:a_reg_values s!:current_count); + +% +% s!:current_procedure is a list of basic blocks, with the entry-point +% implicit at the first block (that is to say at the END of the list +% while I am building it).. Each block is represented as a list +% (label exit-condn size . byte-list) +% where the exit-condn can (at various stages during compilation) be +% nil drop through +% (exit) one-byte exit opcodes +% (jump