From c4d8dec2eec9c0eb7ae6639ecc0dd607a97b37b7 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Sat, 13 Oct 2007 13:02:58 +0000 Subject: Remove more pamphlets --- src/interp/Makefile.in | 58 +- src/interp/Makefile.pamphlet | 62 +- src/interp/axext_l.lisp | 203 +++ src/interp/axext_l.lisp.pamphlet | 230 --- src/interp/bits.lisp | 2 + src/interp/boot-pkg.lisp | 2 + src/interp/bootlex.lisp | 2 + src/interp/cfuns.lisp | 103 ++ src/interp/cfuns.lisp.pamphlet | 123 -- src/interp/comp.lisp | 2 + src/interp/daase.lisp | 1762 +++++++++++++++++++ src/interp/daase.lisp.pamphlet | 2037 ---------------------- src/interp/debug.lisp | 1215 +++++++++++++ src/interp/debug.lisp.pamphlet | 1244 ------------- src/interp/def.lisp | 2 + src/interp/fname.lisp | 2 + src/interp/fnewmeta.lisp | 991 +++++++++++ src/interp/fnewmeta.lisp.pamphlet | 1012 ----------- src/interp/foam_l.lisp | 909 ++++++++++ src/interp/foam_l.lisp.pamphlet | 945 ---------- src/interp/ggreater.lisp | 2 + src/interp/hash.lisp | 123 ++ src/interp/hash.lisp.pamphlet | 147 -- src/interp/interp-proclaims.lisp | 3391 ------------------------------------ src/interp/intint.lisp | 148 ++ src/interp/intint.lisp.pamphlet | 168 -- src/interp/macros.lisp | 926 ++++++++++ src/interp/macros.lisp.pamphlet | 993 ----------- src/interp/metalex.lisp | 2 + src/interp/monitor.lisp | 474 +++++ src/interp/monitor.lisp.pamphlet | 806 --------- src/interp/newaux.lisp | 212 +++ src/interp/newaux.lisp.pamphlet | 252 --- src/interp/nlib.lisp | 437 +++++ src/interp/nlib.lisp.pamphlet | 468 ----- src/interp/nocompil.lisp | 77 + src/interp/nocompil.lisp.pamphlet | 98 -- src/interp/nspadaux.lisp | 2 + src/interp/obey.lisp | 2 + src/interp/parsing.lisp | 2 + src/interp/patches.lisp | 398 +++++ src/interp/patches.lisp.pamphlet | 423 ----- src/interp/postprop.lisp | 2 + src/interp/preparse.lisp | 399 +++++ src/interp/preparse.lisp.pamphlet | 420 ----- src/interp/property.lisp | 603 +++++++ src/interp/property.lisp.pamphlet | 639 ------- src/interp/setq.lisp | 469 +++++ src/interp/setq.lisp.pamphlet | 495 ------ src/interp/sfsfun-l.lisp | 71 + src/interp/sfsfun-l.lisp.pamphlet | 91 - src/interp/sockio.lisp | 243 +++ src/interp/sockio.lisp.pamphlet | 263 --- src/interp/spad.lisp | 580 ++++++ src/interp/spad.lisp.pamphlet | 608 ------- src/interp/spaderror.lisp | 115 ++ src/interp/spaderror.lisp.pamphlet | 141 -- src/interp/union.lisp | 2 + src/interp/unlisp.lisp | 1106 ++++++++++++ src/interp/unlisp.lisp.pamphlet | 1134 ------------ src/interp/util.lisp | 1118 ++++++++++++ src/interp/util.lisp.pamphlet | 1557 ----------------- src/interp/vmlisp.lisp | 1939 +++++++++++++++++++++ src/interp/vmlisp.lisp.pamphlet | 2015 --------------------- 64 files changed, 14657 insertions(+), 19810 deletions(-) create mode 100644 src/interp/axext_l.lisp delete mode 100644 src/interp/axext_l.lisp.pamphlet create mode 100644 src/interp/cfuns.lisp delete mode 100644 src/interp/cfuns.lisp.pamphlet create mode 100644 src/interp/daase.lisp delete mode 100644 src/interp/daase.lisp.pamphlet create mode 100644 src/interp/debug.lisp delete mode 100644 src/interp/debug.lisp.pamphlet create mode 100644 src/interp/fnewmeta.lisp delete mode 100644 src/interp/fnewmeta.lisp.pamphlet create mode 100644 src/interp/foam_l.lisp delete mode 100644 src/interp/foam_l.lisp.pamphlet create mode 100644 src/interp/hash.lisp delete mode 100644 src/interp/hash.lisp.pamphlet delete mode 100644 src/interp/interp-proclaims.lisp create mode 100644 src/interp/intint.lisp delete mode 100644 src/interp/intint.lisp.pamphlet create mode 100644 src/interp/macros.lisp delete mode 100644 src/interp/macros.lisp.pamphlet create mode 100644 src/interp/monitor.lisp delete mode 100644 src/interp/monitor.lisp.pamphlet create mode 100644 src/interp/newaux.lisp delete mode 100644 src/interp/newaux.lisp.pamphlet create mode 100644 src/interp/nlib.lisp delete mode 100644 src/interp/nlib.lisp.pamphlet create mode 100644 src/interp/nocompil.lisp delete mode 100644 src/interp/nocompil.lisp.pamphlet create mode 100644 src/interp/patches.lisp delete mode 100644 src/interp/patches.lisp.pamphlet create mode 100644 src/interp/preparse.lisp delete mode 100644 src/interp/preparse.lisp.pamphlet create mode 100644 src/interp/property.lisp delete mode 100644 src/interp/property.lisp.pamphlet create mode 100644 src/interp/setq.lisp delete mode 100644 src/interp/setq.lisp.pamphlet create mode 100644 src/interp/sfsfun-l.lisp delete mode 100644 src/interp/sfsfun-l.lisp.pamphlet create mode 100644 src/interp/sockio.lisp delete mode 100644 src/interp/sockio.lisp.pamphlet create mode 100644 src/interp/spad.lisp delete mode 100644 src/interp/spad.lisp.pamphlet create mode 100644 src/interp/spaderror.lisp delete mode 100644 src/interp/spaderror.lisp.pamphlet create mode 100644 src/interp/unlisp.lisp delete mode 100644 src/interp/unlisp.lisp.pamphlet create mode 100644 src/interp/util.lisp delete mode 100644 src/interp/util.lisp.pamphlet create mode 100644 src/interp/vmlisp.lisp delete mode 100644 src/interp/vmlisp.lisp.pamphlet (limited to 'src') diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index 827626b3..9d742924 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -21,29 +21,11 @@ LISPSYS= $(axiom_build_bindir)/lisp BOOTSYS= $(axiom_build_bindir)/bootsys DEPSYS = ./depsys -depsys_lisp_compiled_sources += parsing.lisp metalex.lisp bootlex.lisp \ - newaux.lisp preparse.lisp postprop.lisp def.lisp \ - fnewmeta.lisp - -depsys_lisp_sources = $(depsys_lisp_noncompiled_sources) \ - $(depsys_lisp_compiled_sources) - -depsys_boot_sources = postpar.boot parse.boot clam.boot slam.boot \ - g-boot.boot g-error.boot c-util.boot g-util.boot -DEP= spaderror.lisp debug.lisp \ - spad.lisp \ - setq.lisp property.lisp \ - unlisp.lisp foam_l.lisp \ - axext_l.lisp - -depsys_lisp_macro_sources = vmlisp.lisp ggreater.lisp hash.lisp \ - union.lisp nlib.lisp macros.lisp \ - comp.lisp spaderror.lisp debug.lisp \ - spad.lisp bits.lisp setq.lisp property.lisp \ - unlisp.lisp foam_l.lisp axext_l.lisp - -depsys_lisp_noncompiled_sources += $(depsys_lisp_macro_sources) -depsys_lisp_SOURCES = $(addsuffix .pamphlet, $(depsys_lisp_sources)) +DEP= $(srcdir)/spaderror.lisp $(srcdir)/debug.lisp \ + $(srcdir)/spad.lisp \ + $(srcdir)/setq.lisp $(srcdir)/property.lisp \ + $(srcdir)/unlisp.lisp $(srcdir)/foam_l.lisp \ + $(srcdir)/axext_l.lisp LOADSYS= $(axiom_build_bindir)/lisp$(EXEEXT) SAVESYS= interpsys$(EXEEXT) AXIOMSYS= $(axiom_target_bindir)/AXIOMsys$(EXEEXT) @@ -108,36 +90,6 @@ OBJS= vmlisp.$(FASLEXT) hash.$(FASLEXT) \ $(BROBJS) interpsys_modules = $(patsubst %.$(FASLEXT), "%", $(OBJS)) - -AXIOMsys_noncompiled_lisp_sources = nocompil.lisp \ - postprop.lisp property.lisp setq.lisp - -AXIOMsys_compiled_lisp_sources = bits.lisp \ - bootlex.lisp cfuns.lisp comp.lisp construc.lisp daase.lisp \ - debug.lisp def.lisp fname.lisp fnewmeta.lisp ggreater.lisp \ - hash.lisp macros.lisp metalex.lisp monitor.lisp newaux.lisp \ - nlib.lisp nspadaux.lisp parsing.lisp \ - patches.lisp preparse.lisp \ - sockio.lisp spad.lisp spaderror.lisp \ - union.lisp util.lisp vmlisp.lisp obey.lisp \ - unlisp.lisp intint.lisp sfsfun-l.lisp \ - axext_l.lisp foam_l.lisp - -AXIOMsys_boot_sources = astr.boot alql.boot buildom.boot cattable.boot \ - cformat.boot clam.boot clammed.boot compat.boot compress.boot \ - cparse.boot cstream.boot database.boot dq.boot format.boot \ - g-boot.boot g-cndata.boot g-error.boot g-opt.boot g-timer.boot \ - g-util.boot hypertex.boot i-analy.boot i-code.boot i-coerce.boot \ - i-coerfn.boot i-eval.boot i-funsel.boot i-intern.boot i-map.boot \ - i-output.boot i-resolv.boot i-spec1.boot i-spec2.boot \ - i-syscmd.boot i-toplev.boot i-util.boot incl.boot int-top.boot \ - intfile.boot lisplib.boot macex.boot match.boot msg.boot \ - msgdb.boot newfort.boot nrunfast.boot nrungo.boot nrunopt.boot \ - nruntime.boot osyscmd.boot packtran.boot pathname.boot \ - pf2sex.boot pile.boot posit.boot ptrees.boot \ - record.boot rulesets.boot scan.boot serror.boot server.boot \ - setvars.boot sfsfun.boot simpbool.boot slam.boot template.boot \ - termrw.boot trace.boot fortcall.boot INOBJS= varini.$(FASLEXT) \ setvart.$(FASLEXT) intint.$(FASLEXT) \ xrun.$(FASLEXT) interop.$(FASLEXT) \ diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 54889009..9843fcc5 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -247,19 +247,6 @@ The [[depsys]] image is made of the following Lisp source files \end{description} -% -<>= -depsys_lisp_compiled_sources += parsing.lisp metalex.lisp bootlex.lisp \ - newaux.lisp preparse.lisp postprop.lisp def.lisp \ - fnewmeta.lisp - -depsys_lisp_sources = $(depsys_lisp_noncompiled_sources) \ - $(depsys_lisp_compiled_sources) - -depsys_boot_sources = postpar.boot parse.boot clam.boot slam.boot \ - g-boot.boot g-error.boot c-util.boot g-util.boot -@ - The {\bf DEP} variable contains the list of files that will be loaded into {\bf DEPSYS}. Notice that these files are loaded in interpreted form. We are not concerned about @@ -268,20 +255,11 @@ We do, however, care about the macros as these will be expanded in later compiles. All macros are assumed to be in this list of files. <>= -DEP= spaderror.lisp debug.lisp \ - spad.lisp \ - setq.lisp property.lisp \ - unlisp.lisp foam_l.lisp \ - axext_l.lisp - -depsys_lisp_macro_sources = vmlisp.lisp ggreater.lisp hash.lisp \ - union.lisp nlib.lisp macros.lisp \ - comp.lisp spaderror.lisp debug.lisp \ - spad.lisp bits.lisp setq.lisp property.lisp \ - unlisp.lisp foam_l.lisp axext_l.lisp - -depsys_lisp_noncompiled_sources += $(depsys_lisp_macro_sources) -depsys_lisp_SOURCES = $(addsuffix .pamphlet, $(depsys_lisp_sources)) +DEP= $(srcdir)/spaderror.lisp $(srcdir)/debug.lisp \ + $(srcdir)/spad.lisp \ + $(srcdir)/setq.lisp $(srcdir)/property.lisp \ + $(srcdir)/unlisp.lisp $(srcdir)/foam_l.lisp \ + $(srcdir)/axext_l.lisp @ Once we've compile all of the Common Lisp files we fire up @@ -381,36 +359,6 @@ OBJS= vmlisp.$(FASLEXT) hash.$(FASLEXT) \ $(BROBJS) interpsys_modules = $(patsubst %.$(FASLEXT), "%", $(OBJS)) - -AXIOMsys_noncompiled_lisp_sources = nocompil.lisp \ - postprop.lisp property.lisp setq.lisp - -AXIOMsys_compiled_lisp_sources = bits.lisp \ - bootlex.lisp cfuns.lisp comp.lisp construc.lisp daase.lisp \ - debug.lisp def.lisp fname.lisp fnewmeta.lisp ggreater.lisp \ - hash.lisp macros.lisp metalex.lisp monitor.lisp newaux.lisp \ - nlib.lisp nspadaux.lisp parsing.lisp \ - patches.lisp preparse.lisp \ - sockio.lisp spad.lisp spaderror.lisp \ - union.lisp util.lisp vmlisp.lisp obey.lisp \ - unlisp.lisp intint.lisp sfsfun-l.lisp \ - axext_l.lisp foam_l.lisp - -AXIOMsys_boot_sources = astr.boot alql.boot buildom.boot cattable.boot \ - cformat.boot clam.boot clammed.boot compat.boot compress.boot \ - cparse.boot cstream.boot database.boot dq.boot format.boot \ - g-boot.boot g-cndata.boot g-error.boot g-opt.boot g-timer.boot \ - g-util.boot hypertex.boot i-analy.boot i-code.boot i-coerce.boot \ - i-coerfn.boot i-eval.boot i-funsel.boot i-intern.boot i-map.boot \ - i-output.boot i-resolv.boot i-spec1.boot i-spec2.boot \ - i-syscmd.boot i-toplev.boot i-util.boot incl.boot int-top.boot \ - intfile.boot lisplib.boot macex.boot match.boot msg.boot \ - msgdb.boot newfort.boot nrunfast.boot nrungo.boot nrunopt.boot \ - nruntime.boot osyscmd.boot packtran.boot pathname.boot \ - pf2sex.boot pile.boot posit.boot ptrees.boot \ - record.boot rulesets.boot scan.boot serror.boot server.boot \ - setvars.boot sfsfun.boot simpbool.boot slam.boot template.boot \ - termrw.boot trace.boot fortcall.boot @ Before we save the {\bf SAVESYS} image we need to run some diff --git a/src/interp/axext_l.lisp b/src/interp/axext_l.lisp new file mode 100644 index 00000000..27bad9cc --- /dev/null +++ b/src/interp/axext_l.lisp @@ -0,0 +1,203 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + +;; File containing primitives needed by exextend in order to interop with axiom +;; This file could do with some declares + +(in-package "FOAM-USER") + +;; tacky but means we can run programs + +(defun H-integer (l e) + (|AXL-LiteralToInteger| l)) + +(defun H-string (l e) + (|AXL-LiteralToString| l)) + +(defun H-error (l e) + (|AXL-error| l)) + +(eval-when (load eval) + (defconstant |G-axclique_string_305639517| (cons #'H-String nil)) + (defconstant |G-axclique_integer_685864888| (cons #'H-integer nil)) + (defconstant |G-axclique_error_011667951| (cons #'H-error nil))) + +;; Literals should be null-terminated strings + +;; SingleInteger + +(defmacro |AXL-LiteralToSingleInteger| (l) + `(parse-integer ,l :junk-allowed t)) + +(defmacro |AXL-LiteralToInteger| (l) + `(parse-integer ,l :junk-allowed t)) + +(defmacro |AXL-LiteralToDoubleFloat| (l) + `(read-from-string ,l nil (|DFlo0|) + :preserve-whitespace t)) + +(defmacro |AXL-LiteralToString| (l) + `(subseq ,l 0 (- (length ,l) 1))) + +(defmacro |AXL-SingleIntegerToInteger| (si) + `(coerce (the |SInt| ,si) |BInt|)) + +(defmacro |AXL-StringToFloat| (s) + `(boot::|string2Float| ,s)) + +(defmacro |AXL-IntegerIsNonNegative| (i) + `(not (< ,i 0))) + +(defmacro |AXL-IntegerIsPositive| (i) + `(< 0 (the |BInt| ,i))) + +(defmacro |AXL-plusInteger| (a b) + `(the |BInt| (+ (the |BInt| ,a) + (the |BInt| ,b)))) + +(defmacro |AXL-minusInteger| (a b) + `(the |BInt| (- (the |BInt| ,a) + (the |BInt| ,b)))) + +(defmacro |AXL-timesInteger| (a b) + `(the |BInt| (* (the |BInt| ,a) + (the |BInt| ,b)))) + +(defmacro |AXL-eqInteger| (a b) + `(= (the |BInt| ,a) + (the |BInt| ,b))) + +(defmacro |AXL-ltInteger| (a b) + `(< (the |BInt| ,a) + (the |BInt| ,b))) + +(defmacro |AXL-leInteger| (a b) + `(<= (the |BInt| ,a) + (the |BInt| ,b))) + +(defmacro |AXL-gtInteger| (a b) + `(> (the |BInt| ,a) + (the |BInt| ,b))) + +(defmacro |AXL-geInteger| (a b) + `(>= (the |BInt| ,a) + (the |BInt| ,b))) + +(defmacro |AXL-plusSingleInteger| (a b) + `(the |SInt| (+ (the |SInt| ,a) + (the |SInt| ,b)))) + +(defmacro |AXL-minusSingleInteger| (a b) + `(the |SInt| (- (the |SInt| ,a) + (the |SInt| ,b)))) + +(defmacro |AXL-timesSingleInteger| (a b) + `(the |SInt| (* (the |SInt| ,a) + (the |SInt| ,b)))) + +(defmacro |AXL-eqSingleInteger| (a b) + `(= (the |SInt| ,a) + (the |SInt| ,b))) + +(defmacro |AXL-ltSingleInteger| (a b) + `(< (the |SInt| ,a) + (the |SInt| ,b))) + +(defmacro |AXL-leSingleInteger| (a b) + `(<= (the |SInt| ,a) + (the |SInt| ,b))) + +(defmacro |AXL-gtSingleInteger| (a b) + `(> (the |SInt| ,a) + (the |SInt| ,b))) + +(defmacro |AXL-geSingleInteger| (a b) + `(>= (the |SInt| ,a) + (the |SInt| ,b))) + +(defmacro |AXL-incSingleInteger| (i) + `(the |SInt| (+ (the |SInt| ,i) 1))) + +(defmacro |AXL-decSingleInteger| (i) + `(- (the |SInt| ,i) + (the |SInt| 1))) + +(defmacro |AXL-onefnSingleInteger| () '(the |SInt| 1)) +(defmacro |AXL-zerofnSingleInteger| () '(the |SInt| 0)) + +(defmacro |AXL-cons| (x y) + `(cons ,x ,y)) + +(defmacro |AXL-nilfn| () nil) + +(defmacro |AXL-car| (x) `(car ,x)) + +(defmacro |AXL-cdr| (x) `(cdr ,x)) + +(defmacro |AXL-null?| (x) `(null ,x)) + +(defmacro |AXL-rplaca| (x y) `(rplaca ,x ,y)) + +(defmacro |AXL-rplacd| (x y) `(rplacd ,x ,y)) + +(defmacro |AXL-error| (msg) `(error ,msg)) + +;; arrays +;; 0 based! +(defmacro |AXL-arrayRef| (arr i) + `(|AElt| ,arr ,i)) + +(defmacro |AXL-arraySet| (arr i v) + `(setf (|AElt| ,arr ,i) ,v)) + +(defmacro |AXL-arrayToList| (x) + `(coerce ,x 'list)) + +(defmacro |AXL-arraySize| (x) + `(length ,x)) + +(defmacro |AXL-arrayNew| (n) + `(make-array ,n)) + +(defmacro |AXL-arrayCopy| (x) + `(copy-seq ,x)) + +;; Vectors + + +;; Testing + +(defun |AXL-spitSInt| (x) + (print x)) + diff --git a/src/interp/axext_l.lisp.pamphlet b/src/interp/axext_l.lisp.pamphlet deleted file mode 100644 index 3d03127c..00000000 --- a/src/interp/axext_l.lisp.pamphlet +++ /dev/null @@ -1,230 +0,0 @@ -%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/axext\_l.lisp} Pamphlet} -\author{Timothy Daly} - -\begin{document} -\maketitle - -\begin{abstract} -\end{abstract} - - -\tableofcontents -\eject - -\section{License} - -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -;; File containing primitives needed by exextend in order to interop with axiom -;; This file could do with some declares - -(in-package "FOAM-USER") - -;; tacky but means we can run programs - -(defun H-integer (l e) - (|AXL-LiteralToInteger| l)) - -(defun H-string (l e) - (|AXL-LiteralToString| l)) - -(defun H-error (l e) - (|AXL-error| l)) - -(eval-when (load eval) - (defconstant |G-axclique_string_305639517| (cons #'H-String nil)) - (defconstant |G-axclique_integer_685864888| (cons #'H-integer nil)) - (defconstant |G-axclique_error_011667951| (cons #'H-error nil))) - -;; Literals should be null-terminated strings - -;; SingleInteger - -(defmacro |AXL-LiteralToSingleInteger| (l) - `(parse-integer ,l :junk-allowed t)) - -(defmacro |AXL-LiteralToInteger| (l) - `(parse-integer ,l :junk-allowed t)) - -(defmacro |AXL-LiteralToDoubleFloat| (l) - `(read-from-string ,l nil (|DFlo0|) - :preserve-whitespace t)) - -(defmacro |AXL-LiteralToString| (l) - `(subseq ,l 0 (- (length ,l) 1))) - -(defmacro |AXL-SingleIntegerToInteger| (si) - `(coerce (the |SInt| ,si) |BInt|)) - -(defmacro |AXL-StringToFloat| (s) - `(boot::|string2Float| ,s)) - -(defmacro |AXL-IntegerIsNonNegative| (i) - `(not (< ,i 0))) - -(defmacro |AXL-IntegerIsPositive| (i) - `(< 0 (the |BInt| ,i))) - -(defmacro |AXL-plusInteger| (a b) - `(the |BInt| (+ (the |BInt| ,a) - (the |BInt| ,b)))) - -(defmacro |AXL-minusInteger| (a b) - `(the |BInt| (- (the |BInt| ,a) - (the |BInt| ,b)))) - -(defmacro |AXL-timesInteger| (a b) - `(the |BInt| (* (the |BInt| ,a) - (the |BInt| ,b)))) - -(defmacro |AXL-eqInteger| (a b) - `(= (the |BInt| ,a) - (the |BInt| ,b))) - -(defmacro |AXL-ltInteger| (a b) - `(< (the |BInt| ,a) - (the |BInt| ,b))) - -(defmacro |AXL-leInteger| (a b) - `(<= (the |BInt| ,a) - (the |BInt| ,b))) - -(defmacro |AXL-gtInteger| (a b) - `(> (the |BInt| ,a) - (the |BInt| ,b))) - -(defmacro |AXL-geInteger| (a b) - `(>= (the |BInt| ,a) - (the |BInt| ,b))) - -(defmacro |AXL-plusSingleInteger| (a b) - `(the |SInt| (+ (the |SInt| ,a) - (the |SInt| ,b)))) - -(defmacro |AXL-minusSingleInteger| (a b) - `(the |SInt| (- (the |SInt| ,a) - (the |SInt| ,b)))) - -(defmacro |AXL-timesSingleInteger| (a b) - `(the |SInt| (* (the |SInt| ,a) - (the |SInt| ,b)))) - -(defmacro |AXL-eqSingleInteger| (a b) - `(= (the |SInt| ,a) - (the |SInt| ,b))) - -(defmacro |AXL-ltSingleInteger| (a b) - `(< (the |SInt| ,a) - (the |SInt| ,b))) - -(defmacro |AXL-leSingleInteger| (a b) - `(<= (the |SInt| ,a) - (the |SInt| ,b))) - -(defmacro |AXL-gtSingleInteger| (a b) - `(> (the |SInt| ,a) - (the |SInt| ,b))) - -(defmacro |AXL-geSingleInteger| (a b) - `(>= (the |SInt| ,a) - (the |SInt| ,b))) - -(defmacro |AXL-incSingleInteger| (i) - `(the |SInt| (+ (the |SInt| ,i) 1))) - -(defmacro |AXL-decSingleInteger| (i) - `(- (the |SInt| ,i) - (the |SInt| 1))) - -(defmacro |AXL-onefnSingleInteger| () '(the |SInt| 1)) -(defmacro |AXL-zerofnSingleInteger| () '(the |SInt| 0)) - -(defmacro |AXL-cons| (x y) - `(cons ,x ,y)) - -(defmacro |AXL-nilfn| () nil) - -(defmacro |AXL-car| (x) `(car ,x)) - -(defmacro |AXL-cdr| (x) `(cdr ,x)) - -(defmacro |AXL-null?| (x) `(null ,x)) - -(defmacro |AXL-rplaca| (x y) `(rplaca ,x ,y)) - -(defmacro |AXL-rplacd| (x y) `(rplacd ,x ,y)) - -(defmacro |AXL-error| (msg) `(error ,msg)) - -;; arrays -;; 0 based! -(defmacro |AXL-arrayRef| (arr i) - `(|AElt| ,arr ,i)) - -(defmacro |AXL-arraySet| (arr i v) - `(setf (|AElt| ,arr ,i) ,v)) - -(defmacro |AXL-arrayToList| (x) - `(coerce ,x 'list)) - -(defmacro |AXL-arraySize| (x) - `(length ,x)) - -(defmacro |AXL-arrayNew| (n) - `(make-array ,n)) - -(defmacro |AXL-arrayCopy| (x) - `(copy-seq ,x)) - -;; Vectors - - -;; Testing - -(defun |AXL-spitSInt| (x) - (print x)) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/bits.lisp b/src/interp/bits.lisp index d6f26708..efff9357 100644 --- a/src/interp/bits.lisp +++ b/src/interp/bits.lisp @@ -1,5 +1,7 @@ ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are diff --git a/src/interp/boot-pkg.lisp b/src/interp/boot-pkg.lisp index 596b2c15..3d4dc57c 100644 --- a/src/interp/boot-pkg.lisp +++ b/src/interp/boot-pkg.lisp @@ -1,5 +1,7 @@ ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are diff --git a/src/interp/bootlex.lisp b/src/interp/bootlex.lisp index 35be2eaa..6fae9513 100644 --- a/src/interp/bootlex.lisp +++ b/src/interp/bootlex.lisp @@ -1,5 +1,7 @@ ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are diff --git a/src/interp/cfuns.lisp b/src/interp/cfuns.lisp new file mode 100644 index 00000000..5e0ab54d --- /dev/null +++ b/src/interp/cfuns.lisp @@ -0,0 +1,103 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + +(in-package "BOOT") + +#+(and :Lucid (not :ibm/370)) +(progn +; (system:define-foreign-function :c '|findString| :fixnum) + (system:define-foreign-function :c '|addtopath| :fixnum) + (system:define-foreign-function :c '|chdir| :fixnum) + (system:define-foreign-function :c '|writeablep| :fixnum) + (system:define-foreign-function :c '|directoryp| :fixnum) + (system:define-foreign-function :c '|copyEnvValue| :fixnum) + ) + +#+KCL +(progn + (defentry |directoryp| (string) (int "directoryp")) + (defentry |writeablep| (string) (int "writeablep")) +; (defentry |findString| (string string) (int "findString")) + ) + +#+:CCL +(defun |directoryp| (fn) + (cond ((not (probe-file fn)) -1) + ((directoryp fn) 1) + (t 0))) + + + +; (defun |findStringInFile| (str p) +; (|findString| (namestring p) str) ) + + +(defun |getEnv| (var-name) (system::getenv var-name)) + +;;stolen from AXIOM-XL src/strops.c +#+(AND KCL (NOT ELF)) +(Clines +"MYHASH(s)" +"char *s;" +"{" +" register unsigned int h = 0;" +" register int c;" +"" +" while ((c = *s++) != 0) {" +" h ^= (h << 8);" +" h += ((c) + 200041);" +" h &= 0x3FFFFFFF;" +" }" +" return h;" +"}" +) +#+(AND KCL (NOT ELF)) +(defentry |hashString| (string) (int "MYHASH")) +#+(AND KCL ELF) +(defun |hashString| (string) (system:|hashString| string)) + +#+(AND KCL (NOT ELF)) +(Clines +"int MYCOMBINE(i,j)" +"int i,j;" +"{" +"return ( (((((unsigned int)j) & 16777215) << 6)+((unsigned int)i)) % 1073741789);" +"}" +) +#+(AND KCL (NOT ELF)) +(defentry |hashCombine| (int int) (int "MYCOMBINE")) +#+(AND KCL ELF) +(defun |hashCombine| (x y) (system:|hashCombine| x y)) + + diff --git a/src/interp/cfuns.lisp.pamphlet b/src/interp/cfuns.lisp.pamphlet deleted file mode 100644 index d9bf72d5..00000000 --- a/src/interp/cfuns.lisp.pamphlet +++ /dev/null @@ -1,123 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp cfuns.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -(in-package "BOOT") - -#+(and :Lucid (not :ibm/370)) -(progn -; (system:define-foreign-function :c '|findString| :fixnum) - (system:define-foreign-function :c '|addtopath| :fixnum) - (system:define-foreign-function :c '|chdir| :fixnum) - (system:define-foreign-function :c '|writeablep| :fixnum) - (system:define-foreign-function :c '|directoryp| :fixnum) - (system:define-foreign-function :c '|copyEnvValue| :fixnum) - ) - -#+KCL -(progn - (defentry |directoryp| (string) (int "directoryp")) - (defentry |writeablep| (string) (int "writeablep")) -; (defentry |findString| (string string) (int "findString")) - ) - -#+:CCL -(defun |directoryp| (fn) - (cond ((not (probe-file fn)) -1) - ((directoryp fn) 1) - (t 0))) - - - -; (defun |findStringInFile| (str p) -; (|findString| (namestring p) str) ) - - -(defun |getEnv| (var-name) (system::getenv var-name)) - -;;stolen from AXIOM-XL src/strops.c -#+(AND KCL (NOT ELF)) -(Clines -"MYHASH(s)" -"char *s;" -"{" -" register unsigned int h = 0;" -" register int c;" -"" -" while ((c = *s++) != 0) {" -" h ^= (h << 8);" -" h += ((c) + 200041);" -" h &= 0x3FFFFFFF;" -" }" -" return h;" -"}" -) -#+(AND KCL (NOT ELF)) -(defentry |hashString| (string) (int "MYHASH")) -#+(AND KCL ELF) -(defun |hashString| (string) (system:|hashString| string)) - -#+(AND KCL (NOT ELF)) -(Clines -"int MYCOMBINE(i,j)" -"int i,j;" -"{" -"return ( (((((unsigned int)j) & 16777215) << 6)+((unsigned int)i)) % 1073741789);" -"}" -) -#+(AND KCL (NOT ELF)) -(defentry |hashCombine| (int int) (int "MYCOMBINE")) -#+(AND KCL ELF) -(defun |hashCombine| (x y) (system:|hashCombine| x y)) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/comp.lisp b/src/interp/comp.lisp index 66d56e7a..2c88d43f 100644 --- a/src/interp/comp.lisp +++ b/src/interp/comp.lisp @@ -1,5 +1,7 @@ ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp new file mode 100644 index 00000000..3d6b715c --- /dev/null +++ b/src/interp/daase.lisp @@ -0,0 +1,1762 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + +;; In order to understand this program you need to understand some details +;; of the structure of the databases it reads. Axiom has 5 databases, +;; the interp.daase, operation.daase, category.daase, compress.daase, and +;; browse.daase. The compress.daase is special and does not follow the +;; normal database format. +;; +;; This documentation refers to KAF files which are random access files. +;; NRLIB files are KAF files (look for NRLIB/index.KAF) +;; The format of a random access file is +;; \begin{verbatim} +;; byte-offset-of-key-table +;; first-entry +;; second-entry +;; ... +;; last-entry +;; ((key1 . first-entry-byte-address) +;; (key2 . second-entry-byte-address) +;; ... +;; (keyN . last-entry-byte-address)) +;; \end{verbatim} +;; The key table is a standard lisp alist. +;; +;; To open a database you fetch the first number, seek to that location, +;; and (read) which returns the key-data alist. To look up data you +;; index into the key-data alist, find the ith-entry-byte-address, +;; seek to that address, and (read). +;; +;; For instance, see src/share/algebra/USERS.DAASE/index.KAF +;; +;; One existing optimization is that if the data is a simple thing like a +;; symbol then the nth-entry-byte-address is replaced by immediate data. +;; +;; Another existing one is a compression algorithm applied to the +;; data so that the very long names don't take up so much space. +;; We could probably remove the compression algorithm as 64k is no +;; longer considered 'huge'. The database-abbreviation routine +;; handles this on read and write-compress handles this on write. +;; The squeeze routine is used to compress the keys, the unsqueeze +;; routine uncompresses them. Making these two routines disappear +;; should remove all of the compression. +;; +;; Indeed, a faster optimization is to simply read the whole database +;; into the image before it is saved. The system would be easier to +;; understand and the interpreter would be faster. +;; +;; The system uses another optimization: database contains a stamp +;; (consisting of offset to the main list and build time). Before +;; saving the image selected data is fetched to memory. When the +;; saved image starts it checks if the stamp of saved data matches +;; in-core data -- in case of agreement in-core data is used. +;; Parts of the datatabase which was not pre-loaded is still +;; (lazily) fetched from the filesystem. +;; +;; Database files are very similar to KAF files except that there +;; is an optimization (currently broken) which makes the first +;; item a pair of two numbers. The first number in the pair is +;; the offset of the key-value table, the second is a time stamp. +;; If the time stamp in the database matches the time stamp in +;; the image the database is not needed (since the internal hash +;; tables already contain all of the information). When the database +;; is built the time stamp is saved in both the gcl image and the +;; database. + + +;;TTT 7/2/97 +; Regarding the 'ancestors field for a category: At database build +; time there exists a *ancestors-hash* hash table that gets filled +; with CATEGORY (not domain) ancestor information. This later provides +; the information that goes into interp.daase This *ancestors-hash* +; does not exist at normal runtime (it can be made by a call to +; genCategoryTable). Note that the ancestor information in +; *ancestors-hash* (and hence interp.daase) involves #1, #2, etc +; instead of R, Coef, etc. The latter thingies appear in all +; .NRLIB/index.KAF files. So we need to be careful when we )lib +; categories and update the ancestor info. + + +; This file contains the code to build, open and access the .DAASE +; files this file contains the code to )library NRLIBS and asy files + +; There is a major issue about the data that resides in these +; databases. the fundamental problem is that the system requires more +; information to build the databases than it needs to run the +; interpreter. in particular, MODEMAP.DAASE is constructed using +; properties like "modemaps" but the interpreter will never ask for +; this information. + +; So, the design is as follows: +; first, the MODEMAP.DAASE needs to be built. this is done by doing +; a )library on ALL of the NRLIB files that are going into the system. +; this will bring in "modemap" information and add it to the +; *modemaps-hash* hashtable. +; next, database build proceeds, accessing the "modemap" property +; from the hashtables. once this completes this information is never +; used again. +; next, the interp.daase database is built. this contains only the +; information necessary to run the interpreter. note that during the +; running of the interpreter users can extend the system by do a +; )library on a new NRLIB file. this will cause fields such as "modemap" +; to be read and hashed. + +; In the old system each constructor (e.g. LIST) had one library directory +; (e.g. LIST.NRLIB). this directory contained a random access file called +; the index.KAF file. the interpreter needed this KAF file at runtime for +; two entries, the operationAlist and the ConstructorModemap. +; during the redesign for the new compiler we decided to merge all of +; these .NRLIB/index.KAF files into one database, INTERP.DAASE. +; requests to get information from this database are intended to be +; cached so that multiple references do not cause additional disk i/o. +; this database is left open at all times as it is used frequently by +; the interpreter. one minor complication is that newly compiled files +; need to override information that exists in this database. +; The design calls for constructing a random read (KAF format) file +; that is accessed by functions that cache their results. when the +; database is opened the list of constructor-index pairs is hashed +; by constructor name. a request for information about a constructor +; causes the information to replace the index in the hash table. since +; the index is a number and the data is a non-numeric sexpr there is +; no source of confusion about when the data needs to be read. +; +; The format of this new database is as follows: +; +;first entry: +; an integer giving the byte offset to the constructor alist +; at the bottom of the file +;second and subsequent entries (one per constructor) +; (operationAlist) +; (constructorModemap) +; .... +;last entry: (pointed at by the first entry) +; an alist of (constructor . index) e.g. +; ( (PI offset-of-operationAlist offset-of-constructorModemap) +; (NNI offset-of-operationAlist offset-of-constructorModemap) +; ....) +; This list is read at open time and hashed by the car of each item. + +; the system has been changed to use the property list of the +; symbols rather than hash tables. since we already hashed once +; to get the symbol we need only an offset to get the property +; list. this also has the advantage that eq hash tables no longer +; need to be moved during garbage collection. +; there are 3 potential speedups that could be done. the best +; would be to use the value cell of the symbol rather than the +; property list but i'm unable to determine all uses of the +; value cell at the present time. +; a second speedup is to guarantee that the property list is +; a single item, namely the database structure. this removes +; an assoc but leaves one open to breaking the system if someone +; adds something to the property list. this was not done because +; of the danger mentioned. +; a third speedup is to make the getdatabase call go away, either +; by making it a macro or eliding it entirely. this was not done +; because we want to keep the flexibility of changing the database +; forms. + +; the new design does not use hash tables. the database structure +; contains an entry for each item that used to be in a hash table. +; initially the structure contains file-position pointers and +; these are replaced by real data when they are first looked up. +; the database structure is kept on the property list of the +; constructor, thus, (get '|DenavitHartenbergMatrix| 'database) +; will return the database structure object. + +; each operation has a property on its symbol name called 'operation +; which is a list of all of the signatures of operations with that name. + +; -- tim daly + +(in-package "BOOT") + +(defstruct database + abbreviation ; interp. + ancestors ; interp. + constructor ; interp. + constructorcategory ; interp. + constructorkind ; interp. + constructormodemap ; interp. + cosig ; interp. + defaultdomain ; interp. + modemaps ; interp. + niladic ; interp. + object ; interp. + operationalist ; interp. + documentation ; browse. + constructorform ; browse. + attributes ; browse. + predicates ; browse. + sourcefile ; browse. + parents ; browse. + users ; browse. + dependents ; browse. + spare ; superstition + ) ; database structure + +; there are only a small number of domains that have default domains. +; rather than keep this slot in every domain we maintain a list here. + +(defvar *defaultdomain-list* '( + (|MultisetAggregate| |Multiset|) + (|FunctionSpace| |Expression|) + (|AlgebraicallyClosedFunctionSpace| |Expression|) + (|ThreeSpaceCategory| |ThreeSpace|) + (|DequeueAggregate| |Dequeue|) + (|ComplexCategory| |Complex|) + (|LazyStreamAggregate| |Stream|) + (|AssociationListAggregate| |AssociationList|) + (|QuaternionCategory| |Quaternion|) + (|PriorityQueueAggregate| |Heap|) + (|PointCategory| |Point|) + (|PlottableSpaceCurveCategory| |Plot3D|) + (|PermutationCategory| |Permutation|) + (|StringCategory| |String|) + (|FileNameCategory| |FileName|) + (|OctonionCategory| |Octonion|))) + +; this hash table is used to answer the question "does domain x +; have category y?". this is answered by constructing a pair of +; (x . y) and doing an equal hash into this table. + +(defvar *operation-hash* nil "given an operation name, what are its modemaps?") +(defvar *hasCategory-hash* nil "answers x has y category questions") + +(defvar *miss* nil "print out cache misses on getdatabase calls") + + ; note that constructorcategory information need only be kept for + ; items of type category. this will be fixed in the next iteration + ; when the need for the various caches are reviewed + + ; note that the *modemaps-hash* information does not need to be kept + ; for system files. these are precomputed and kept in modemap.daase + ; however, for user-defined files these are needed. + ; currently these are added to the database for 2 reasons: + ; there is a still-unresolved issue of user database extensions + ; this information is used during database build time + + + +; this are the streams for the databases. they are always open. +; there is an optimization for speeding up system startup. if the +; database is opened and the ..-stream-stamp* variable matches the +; position information in the database then the database is NOT +; read in and is assumed to match the in-core version + +(defvar *compressvector* nil "a vector of things to compress in the databases") +(defvar *compressVectorLength* 0 "length of the compress vector") +(defvar *compress-stream* nil "an stream containing the compress vector") +(defvar *compress-stream-stamp* 0 "*compress-stream* (position . time)") + +(defvar *interp-stream* nil "an open stream to the interpreter database") +(defvar *interp-stream-stamp* 0 "*interp-stream* (position . time)") + +; this is indexed by operation, not constructor +(defvar *operation-stream* nil "the stream to operation.daase") +(defvar *operation-stream-stamp* 0 "*operation-stream* (position . time)") + +(defvar *browse-stream* nil "an open stream to the browser database") +(defvar *browse-stream-stamp* 0 "*browse-stream* (position . time)") + +; this is indexed by (domain . category) +(defvar *category-stream* nil "an open stream to the category table") +(defvar *category-stream-stamp* 0 "*category-stream* (position . time)") + +(defvar *allconstructors* nil "a list of all the constructors in the system") +(defvar *allOperations* nil "a list of all the operations in the system") + +(defvar *asharpflags* "-O -laxiom -Fasy -Flsp" "library compiler flags") + +(defun asharp (file &optional (flags *asharpflags*)) + "call the asharp compiler" + (system::system + (concatenate 'string (|systemRootDirectory|) "/compiler/bin/axiomxl " + flags " " file))) + +(defun resethashtables () + "set all -hash* to clean values. used to clean up core before saving system" + (setq *hascategory-hash* (make-hash-table :test #'equal)) + (setq *operation-hash* (make-hash-table)) + (setq *allconstructors* nil) + (setq *compressvector* nil) + (setq *compress-stream-stamp* '(0 . 0)) + (compressopen) + (setq *interp-stream-stamp* '(0 . 0)) + (interpopen) + (setq *operation-stream-stamp* '(0 . 0)) + (operationopen) + (setq *browse-stream-stamp* '(0 . 0)) + (browseopen) + (setq *category-stream-stamp* '(0 . 0)) + (categoryopen) ;note: this depends on constructorform in browse.daase +#-:CCL (initial-getdatabase) + (close *interp-stream*) + (close *operation-stream*) + (close *category-stream*) + (close *browse-stream*) +#+:AKCL (gbc t) +) + +(defun initial-getdatabase () + "fetch data we want in the saved system" + (let (hascategory constructormodemapAndoperationalist operation constr) + (format t "Initial getdatabase~%") + (setq hascategory '( + (|Equation| . |Ring|) + (|Expression| . |CoercibleTo|) (|Expression| . |CommutativeRing|) + (|Expression| . |IntegralDomain|) (|Expression| . |Ring|) + (|Float| . |RetractableTo|) + (|Fraction| . |Algebra|) (|Fraction| . |CoercibleTo|) + (|Fraction| . |OrderedSet|) (|Fraction| . |RetractableTo|) + (|Integer| . |Algebra|) (|Integer| . |CoercibleTo|) + (|Integer| . |ConvertibleTo|) (|Integer| . |LinearlyExplicitRingOver|) + (|Integer| . |RetractableTo|) + (|List| . |CoercibleTo|) (|List| . |FiniteLinearAggregate|) + (|List| . |OrderedSet|) + (|Polynomial| . |CoercibleTo|) (|Polynomial| . |CommutativeRing|) + (|Polynomial| . |ConvertibleTo|) (|Polynomial| . |OrderedSet|) + (|Polynomial| . |RetractableTo|) + (|Symbol| . |CoercibleTo|) (|Symbol| . |ConvertibleTo|) + (|Variable| . |CoercibleTo|))) + (dolist (pair hascategory) (getdatabase pair 'hascategory)) + (setq constructormodemapAndoperationalist '( + |BasicOperator| |Boolean| + |CardinalNumber| |Color| |Complex| + |Database| + |Equation| |EquationFunctions2| |Expression| + |Float| |Fraction| |FractionFunctions2| + |Integer| |IntegralDomain| + |Kernel| + |List| + |Matrix| |MappingPackage1| + |Operator| |OutputForm| + |NonNegativeInteger| + |ParametricPlaneCurve| |ParametricSpaceCurve| |Point| |Polynomial| + |PolynomialFunctions2| |PositiveInteger| + |Ring| + |SetCategory| |SegmentBinding| |SegmentBindingFunctions2| |DoubleFloat| + |SparseMultivariatePolynomial| |SparseUnivariatePolynomial| |Segment| + |String| |Symbol| + |UniversalSegment| + |Variable| |Vector|)) + (dolist (con constructormodemapAndoperationalist) + (getdatabase con 'constructormodemap) + (getdatabase con 'operationalist)) + (setq operation '( + |+| |-| |*| |/| |**| |coerce| |convert| |elt| |equation| + |float| |sin| |cos| |map| |SEGMENT|)) + (dolist (op operation) (getdatabase op 'operation)) + (setq constr '( ;these are sorted least-to-most freq. delete early ones first + |Factored| |SparseUnivariatePolynomialFunctions2| |TableAggregate&| + |RetractableTo&| |RecursiveAggregate&| |UserDefinedPartialOrdering| + |None| |UnivariatePolynomialCategoryFunctions2| |IntegerPrimesPackage| + |SetCategory&| |IndexedExponents| |QuotientFieldCategory&| |Polynomial| + |EltableAggregate&| |PartialDifferentialRing&| |Set| + |UnivariatePolynomialCategory&| |FlexibleArray| + |SparseMultivariatePolynomial| |PolynomialCategory&| + |DifferentialExtension&| |IndexedFlexibleArray| |AbelianMonoidRing&| + |FiniteAbelianMonoidRing&| |DivisionRing&| |FullyLinearlyExplicitRingOver&| + |IndexedVector| |IndexedOneDimensionalArray| |LocalAlgebra| |Localize| + |Boolean| |Field&| |Vector| |IndexedDirectProductObject| |Aggregate&| + |PolynomialRing| |FreeModule| |IndexedDirectProductAbelianGroup| + |IndexedDirectProductAbelianMonoid| |SingletonAsOrderedSet| + |SparseUnivariatePolynomial| |Fraction| |Collection&| |HomogeneousAggregate&| + |RepeatedSquaring| |IntegerNumberSystem&| |AbelianSemiGroup&| + |AssociationList| |OrderedRing&| |SemiGroup&| |Symbol| + |UniqueFactorizationDomain&| |EuclideanDomain&| |IndexedAggregate&| + |GcdDomain&| |IntegralDomain&| |DifferentialRing&| |Monoid&| |Reference| + |UnaryRecursiveAggregate&| |OrderedSet&| |AbelianGroup&| |Algebra&| + |Module&| |Ring&| |StringAggregate&| |AbelianMonoid&| + |ExtensibleLinearAggregate&| |PositiveInteger| |StreamAggregate&| + |IndexedString| |IndexedList| |ListAggregate&| |LinearAggregate&| + |Character| |String| |NonNegativeInteger| |SingleInteger| + |OneDimensionalArrayAggregate&| |FiniteLinearAggregate&| |PrimitiveArray| + |Integer| |List| |OutputForm|)) + (dolist (con constr) + (let ((c (concatenate 'string + (|systemRootDirectory|) "/algebra/" + (string (getdatabase con 'abbreviation)) ".o"))) + (format t " preloading ~a.." c) + (if (probe-file c) + (progn + (put con 'loaded c) + (load c) + (format t "loaded.~%")) + (format t "skipped.~%")))) + (format t "~%"))) + +; format of an entry in interp.daase: +; (constructor-name +; operationalist +; constructormodemap +; modemaps -- this should not be needed. eliminate it. +; object -- the name of the object file to load for this con. +; constructorcategory -- note that this info is the cadar of the +; constructormodemap for domains and packages so it is stored +; as NIL for them. it is valid for categories. +; niladic -- t or nil directly +; unused +; cosig -- kept directly +; constructorkind -- kept directly +; defaultdomain -- a short list, for %i +; ancestors -- used to compute new category updates +; ) +(defun interpOpen () + "open the interpreter database and hash the keys" + (let (constructors pos stamp dbstruct) + (setq *interp-stream* (open (DaaseName "interp.daase" nil))) + (setq stamp (read *interp-stream*)) + (unless (equal stamp *interp-stream-stamp*) + (format t " Re-reading interp.daase") + (setq *interp-stream-stamp* stamp) + (setq pos (car stamp)) + (file-position *interp-stream* pos) + (setq constructors (read *interp-stream*)) + (dolist (item constructors) + (setq item (unsqueeze item)) + (setq *allconstructors* (adjoin (first item) *allconstructors*)) + (setq dbstruct (make-database)) + (setf (get (car item) 'database) dbstruct) + (setf (database-operationalist dbstruct) (second item)) + (setf (database-constructormodemap dbstruct) (third item)) + (setf (database-modemaps dbstruct) (fourth item)) + (setf (database-object dbstruct) (fifth item)) + (setf (database-constructorcategory dbstruct) (sixth item)) + (setf (database-niladic dbstruct) (seventh item)) + (setf (database-abbreviation dbstruct) (eighth item)) + (setf (get (eighth item) 'abbreviationfor) (first item)) ;invert + (setf (database-cosig dbstruct) (ninth item)) + (setf (database-constructorkind dbstruct) (tenth item)) + (setf (database-ancestors dbstruct) (nth 11 item)))) + (format t "~&"))) + +; this is an initialization function for the constructor database +; it sets up 2 hash tables, opens the database and hashes the index values + +; there is a slight asymmetry in this code. sourcefile information for +; system files is only the filename and extension. for user files it +; contains the full pathname. when the database is first opened the +; sourcefile slot contains system names. the lookup function +; has to prefix the $spadroot information if the directory-namestring is +; null (we don't know the real root at database build time). +; a object-hash table is set up to look up nrlib and ao information. +; this slot is empty until a user does a )library call. we remember +; the location of the nrlib or ao file for the users local library +; at that time. a NIL result from this probe means that the +; library is in the system-specified place. when we get into multiple +; library locations this will also contain system files. + + +; format of an entry in browse.daase: +; ( constructorname +; sourcefile +; constructorform +; documentation +; attributes +; predicates +; ) + +(defun browseOpen () + "open the constructor database and hash the keys" + (let (constructors pos stamp dbstruct) + (setq *browse-stream* (open (DaaseName "browse.daase" nil))) + (setq stamp (read *browse-stream*)) + (unless (equal stamp *browse-stream-stamp*) + (format t " Re-reading browse.daase") + (setq *browse-stream-stamp* stamp) + (setq pos (car stamp)) + (file-position *browse-stream* pos) + (setq constructors (read *browse-stream*)) + (dolist (item constructors) + (setq item (unsqueeze item)) + (unless (setq dbstruct (get (car item) 'database)) + (format t "browseOpen:~%") + (format t "the browse database contains a contructor ~a~%" item) + (format t "that is not in the interp.daase file. we cannot~%") + (format t "get the database structure for this constructor and~%") + (warn "will create a new one~%") + (setf (get (car item) 'database) (setq dbstruct (make-database))) + (setq *allconstructors* (adjoin item *allconstructors*))) + (setf (database-sourcefile dbstruct) (second item)) + (setf (database-constructorform dbstruct) (third item)) + (setf (database-documentation dbstruct) (fourth item)) + (setf (database-attributes dbstruct) (fifth item)) + (setf (database-predicates dbstruct) (sixth item)) + (setf (database-parents dbstruct) (seventh item)))) + (format t "~&"))) + +(defun categoryOpen () + "open category.daase and hash the keys" + (let (pos keys stamp) + (setq *category-stream* (open (DaaseName "category.daase" nil))) + (setq stamp (read *category-stream*)) + (unless (equal stamp *category-stream-stamp*) + (format t " Re-reading category.daase") + (setq *category-stream-stamp* stamp) + (setq pos (car stamp)) + (file-position *category-stream* pos) + (setq keys (read *category-stream*)) + (setq *hasCategory-hash* (make-hash-table :test #'equal)) + (dolist (item keys) + (setq item (unsqueeze item)) + (setf (gethash (first item) *hasCategory-hash*) (second item)))) + (format t "~&"))) + +(defun operationOpen () + "read operation database and hash the keys" + (let (operations pos stamp) + (setq *operation-stream* (open (DaaseName "operation.daase" nil))) + (setq stamp (read *operation-stream*)) + (unless (equal stamp *operation-stream-stamp*) + (format t " Re-reading operation.daase") + (setq *operation-stream-stamp* stamp) + (setq pos (car stamp)) + (file-position *operation-stream* pos) + (setq operations (read *operation-stream*)) + (dolist (item operations) + (setq item (unsqueeze item)) + (setf (gethash (car item) *operation-hash*) (cdr item)))) + (format t "~&"))) + +(defun addoperations (constructor oldmaps) + "add ops from a )library domain to *operation-hash*" + (declare (special *operation-hash*)) + (dolist (map oldmaps) ; out with the old + (let (oldop op) + (setq op (car map)) + (setq oldop (getdatabase op 'operation)) + (setq oldop (lisp::delete (cdr map) oldop :test #'equal)) + (setf (gethash op *operation-hash*) oldop))) + (dolist (map (getdatabase constructor 'modemaps)) ; in with the new + (let (op newmap) + (setq op (car map)) + (setq newmap (getdatabase op 'operation)) + (setf (gethash op *operation-hash*) (cons (cdr map) newmap))))) + +(defun showdatabase (constructor) + (format t "~&~a: ~a~%" 'constructorkind + (getdatabase constructor 'constructorkind)) + (format t "~a: ~a~%" 'cosig + (getdatabase constructor 'cosig)) + (format t "~a: ~a~%" 'operation + (getdatabase constructor 'operation)) + (format t "~a: ~%" 'constructormodemap) + (pprint (getdatabase constructor 'constructormodemap)) + (format t "~&~a: ~%" 'constructorcategory) + (pprint (getdatabase constructor 'constructorcategory)) + (format t "~&~a: ~%" 'operationalist) + (pprint (getdatabase constructor 'operationalist)) + (format t "~&~a: ~%" 'modemaps) + (pprint (getdatabase constructor 'modemaps)) + (format t "~a: ~a~%" 'hascategory + (getdatabase constructor 'hascategory)) + (format t "~a: ~a~%" 'object + (getdatabase constructor 'object)) + (format t "~a: ~a~%" 'niladic + (getdatabase constructor 'niladic)) + (format t "~a: ~a~%" 'abbreviation + (getdatabase constructor 'abbreviation)) + (format t "~a: ~a~%" 'constructor? + (getdatabase constructor 'constructor?)) + (format t "~a: ~a~%" 'constructor + (getdatabase constructor 'constructor)) + (format t "~a: ~a~%" 'defaultdomain + (getdatabase constructor 'defaultdomain)) + (format t "~a: ~a~%" 'ancestors + (getdatabase constructor 'ancestors)) + (format t "~a: ~a~%" 'sourcefile + (getdatabase constructor 'sourcefile)) + (format t "~a: ~a~%" 'constructorform + (getdatabase constructor 'constructorform)) + (format t "~a: ~a~%" 'constructorargs + (getdatabase constructor 'constructorargs)) + (format t "~a: ~a~%" 'attributes + (getdatabase constructor 'attributes)) + (format t "~a: ~%" 'predicates) + (pprint (getdatabase constructor 'predicates)) + (format t "~a: ~a~%" 'documentation + (getdatabase constructor 'documentation)) + (format t "~a: ~a~%" 'parents + (getdatabase constructor 'parents))) + +(defun setdatabase (constructor key value) + (let (struct) + (when (symbolp constructor) + (unless (setq struct (get constructor 'database)) + (setq struct (make-database)) + (setf (get constructor 'database) struct)) + (case key + (abbreviation + (setf (database-abbreviation struct) value) + (when (symbolp value) + (setf (get value 'abbreviationfor) constructor))) + (constructorkind + (setf (database-constructorkind struct) value)))))) + +(defun deldatabase (constructor key) + (when (symbolp constructor) + (case key + (abbreviation + (setf (get constructor 'abbreviationfor) nil))))) + +(defun getdatabase (constructor key) + (declare (special *miss*)) + (when (eq *miss* t) (format t "getdatabase call: ~20a ~a~%" constructor key)) + (let (data table stream ignore struct) + (declare (ignore ignore)) + (when (or (symbolp constructor) + (and (eq key 'hascategory) (pairp constructor))) + (case key +; note that abbreviation, constructorkind and cosig are heavy hitters +; thus they occur first in the list of things to check + (abbreviation + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-abbreviation struct)))) + (constructorkind + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-constructorkind struct)))) + (cosig + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-cosig struct)))) + (operation + (setq stream *operation-stream*) + (setq data (gethash constructor *operation-hash*))) + (constructormodemap + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-constructormodemap struct)))) + (constructorcategory + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-constructorcategory struct)) + (when (null data) ;domain or package then subfield of constructormodemap + (setq data (cadar (getdatabase constructor 'constructormodemap)))))) + (operationalist + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-operationalist struct)))) + (modemaps + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-modemaps struct)))) + (hascategory + (setq table *hasCategory-hash*) + (setq stream *category-stream*) + (setq data (gethash constructor table))) + (object + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-object struct)))) + (asharp? + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-object struct)))) + (niladic + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-niladic struct)))) + (constructor? + (when (setq struct (get constructor 'database)) + (setq data (when (database-operationalist struct) t)))) + (superdomain ; only 2 superdomains in the world + (case constructor + (|NonNegativeInteger| + (setq data '((|Integer|) (IF (< |#1| 0) |false| |true|)))) + (|PositiveInteger| + (setq data '((|NonNegativeInteger|) (< 0 |#1|)))))) + (constructor + (when (setq data (get constructor 'abbreviationfor)))) + (defaultdomain + (setq data (cadr (assoc constructor *defaultdomain-list*)))) + (ancestors + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-ancestors struct)))) + (sourcefile + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-sourcefile struct)))) + (constructorform + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-constructorform struct)))) + (constructorargs + (setq data (cdr (getdatabase constructor 'constructorform)))) + (attributes + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-attributes struct)))) + (predicates + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-predicates struct)))) + (documentation + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-documentation struct)))) + (parents + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-parents struct)))) + (users + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-users struct)))) + (dependents + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-dependents struct)))) + (otherwise (warn "~%(GETDATABASE ~a ~a) failed~%" constructor key))) + (when (numberp data) ;fetch the real data + (when *miss* (format t "getdatabase miss: ~20a ~a~%" key constructor)) + (file-position stream data) + (setq data (unsqueeze (read stream))) + (case key ; cache the result of the database read + (operation (setf (gethash constructor *operation-hash*) data)) + (hascategory (setf (gethash constructor *hascategory-hash*) data)) + (constructorkind (setf (database-constructorkind struct) data)) + (cosig (setf (database-cosig struct) data)) + (constructormodemap (setf (database-constructormodemap struct) data)) + (constructorcategory (setf (database-constructorcategory struct) data)) + (operationalist (setf (database-operationalist struct) data)) + (modemaps (setf (database-modemaps struct) data)) + (object (setf (database-object struct) data)) + (niladic (setf (database-niladic struct) data)) + (abbreviation (setf (database-abbreviation struct) data)) + (constructor (setf (database-constructor struct) data)) + (ancestors (setf (database-ancestors struct) data)) + (constructorform (setf (database-constructorform struct) data)) + (attributes (setf (database-attributes struct) data)) + (predicates (setf (database-predicates struct) data)) + (documentation (setf (database-documentation struct) data)) + (parents (setf (database-parents struct) data)) + (users (setf (database-users struct) data)) + (dependents (setf (database-dependents struct) data)) + (sourcefile (setf (database-sourcefile struct) data)))) + (case key ; fixup the special cases + (sourcefile + (when (and data (string= (directory-namestring data) "") + (string= (pathname-type data) "spad")) + (setq data + (concatenate 'string (|systemRootDirectory|) "/../../src/algebra/" data)))) + (asharp? ; is this asharp code? + (if (consp data) + (setq data (cdr data)) + (setq data nil))) + (object ; fix up system object pathname + (if (consp data) + (setq data + (if (string= (directory-namestring (car data)) "") + (concatenate 'string (|systemRootDirectory|) "/algebra/" (car data) ".o") + (car data))) + (when (and data (string= (directory-namestring data) "")) + (setq data (concatenate 'string (|systemRootDirectory|) "/algebra/" data ".o"))))))) + data)) + +; )library top level command -- soon to be obsolete + +(defun |with| (args) + (|library| args)) + +;; Current directory +;; Contributed by Juergen Weiss. +#+:cmu +(defun get-current-directory () + (namestring (extensions::default-directory))) + +#+(or :akcl :gcl) +(defun get-current-directory () + (namestring (truename ""))) + + +; )library top level command + +(defun |library| (args) + (declare (special |$options|)) + (declare (special |$newConlist|)) + (setq original-directory (get-current-directory)) + (setq |$newConlist| nil) + (localdatabase args |$options|) +#+:CCL + (dolist (a args) (check-module-exists a)) + (|extendLocalLibdb| |$newConlist|) + (system::chdir original-directory) + (tersyscommand)) + +;; check-module-exists looks to see if a module exists in one of the current +;; libraries and, if not, compiles it. If the output-library exists but has not +;; been opened then it opens it first. +#+:CCL +(defun check-module-exists (module) + (prog (|$options| mdate) + (if (and (not output-library) (filep (or |$outputLibraryName| "user.lib"))) + (seq (setq |$outputLibraryName| + (if |$outputLibraryName| (truename |$outputLibraryName|) + (make-pathname :directory (get-current-directory) + :name "user.lib"))) + (|openOutputLibrary| |$outputLibraryName|))) + (setq mdate (modulep module)) + (setq |$options| '((|nolibrary| nil) (|quiet| nil))) + (|sayMSG| (format nil " Checking for module ~s." (namestring module))) + (let* ((fn (concatenate 'string (namestring module) ".lsp")) + (fdate (filedate fn)) ) + (if (and fdate (or (null mdate) (datelessp mdate fdate))) + (|compileAsharpLispCmd| (list fn)) + (let* ((fn (concatenate 'string (namestring module) ".NRLIB")) + (fdate (filedate fn)) ) + (if (and fdate (or (null mdate) (datelessp mdate fdate))) + (|compileSpadLispCmd| (list fn)))))))) + +; localdatabase tries to find files in the order of: +; NRLIB/index.KAF +; .asy +; .ao, then asharp to .asy + +(defun localdatabase (filelist options &optional (make-database? nil)) + "read a local filename and update the hash tables" + (labels ( + (processOptions (options) + (let (only dir noexpose) + (when (setq only (assoc '|only| options)) + (setq options (lisp::delete only options :test #'equal)) + (setq only (cdr only))) + (when (setq dir (assoc '|dir| options)) + (setq options (lisp::delete dir options :test #'equal)) + (setq dir (second dir)) + (when (null dir) + (|sayKeyedMsg| 'S2IU0002 nil) )) + (when (setq noexpose (assoc '|noexpose| options)) + (setq options (lisp::delete noexpose options :test #'equal)) + (setq noexpose 't) ) + (when options + (format t " Ignoring unknown )library option: ~a~%" options)) + (values only dir noexpose))) + (processDir (dirarg thisdir) + (let (allfiles skipasos) + (system:chdir (string dirarg)) + (setq allfiles (directory "*")) + (system:chdir thisdir) + (values + (mapcan #'(lambda (f) + (when (string-equal (pathname-type f) "NRLIB") + (list (concatenate 'string (namestring f) "/" + *index-filename*)))) allfiles) + (mapcan #'(lambda (f) + (when (string= (pathname-type f) "asy") + (push (pathname-name f) skipasos) + (list (namestring f)))) allfiles) + (mapcan #'(lambda (f) + (when (and (string= (pathname-type f) "ao") + (not (member (pathname-name f) skipasos :test #'string=))) + (list (namestring f)))) + allfiles) + ;; At the moment we will only look for user.lib: others are taken care + ;; of by localasy and localnrlib. +#+:CCL + (mapcan #'(lambda (f) + (when (and (string= (pathname-type f) "lib") (string= (pathname-name f) "user")) + (list (namestring f)))) + allfiles) +#-:CCL nil + )))) + (let (thisdir nrlibs asos asys libs object only dir key + (|$forceDatabaseUpdate| t) noexpose) + (declare (special |$forceDatabaseUpdate|)) + (setq thisdir (namestring (truename "."))) + (setq noexpose nil) + (multiple-value-setq (only dir noexpose) (processOptions options)) + ;don't force exposure during database build + (if make-database? (setq noexpose t)) + (when dir (multiple-value-setq (nrlibs asys asos libs) (processDir dir thisdir))) + (dolist (file filelist) + (let ((filename (pathname-name file)) + (namedir (directory-namestring file))) + (unless namedir (setq thisdir (concatenate 'string thisdir "/"))) + (cond + ((setq file (probe-file + (concatenate 'string namedir filename ".NRLIB/" + *index-filename*))) + (push (namestring file) nrlibs)) + ((setq file (probe-file + (concatenate 'string namedir filename ".asy"))) + (push (namestring file) asys)) + ((setq file (probe-file + (concatenate 'string namedir filename ".ao"))) + (push (namestring file) asos)) + ('else (format t " )library cannot find the file ~a.~%" filename))))) +#+:CCL + (dolist (file libs) (|addInputLibrary| (truename file))) + (dolist (file (nreverse nrlibs)) + (setq key (pathname-name (first (last (pathname-directory file))))) + (setq object (concatenate 'string (directory-namestring file) "code")) + (localnrlib key file object make-database? noexpose)) + (dolist (file (nreverse asys)) + (setq object + (concatenate 'string (directory-namestring file) (pathname-name file))) + (localasy (|astran| file) object only make-database? noexpose)) + (dolist (file (nreverse asos)) + (setq object + (concatenate 'string (directory-namestring file) (pathname-name file))) + (asharp file) + (setq file (|astran| (concatenate 'string (pathname-name file) ".asy"))) + (localasy file object only make-database? noexpose)) + (HCLEAR |$ConstructorCache|)))) + +(defun localasy (asy object only make-database? noexpose) + "given an alist from the asyfile and the objectfile update the database" + (labels ( + (fetchdata (alist index) + (cdr (assoc index alist :test #'string=)))) + (let (cname kind key alist (systemdir? nil) oldmaps asharp-name dbstruct abbrev) +#+:CCL + ;; Open the library + (let (lib) + (if (filep (setq lib (make-pathname :name object :type "lib")) ) + (setq input-libraries (cons (open-library (truename lib)) input-libraries)))) + (set-file-getter object) ; sets the autoload property for G-object + (dolist (domain asy) + (setq key (first domain)) + (setq alist (rest domain)) + (setq asharp-name + (foam::axiomxl-global-name (pathname-name object) key + (lassoc '|typeCode| alist))) + (if (< (length alist) 4) ;we have a naked function object + (let ((opname key) + (modemap (car (LASSOC '|modemaps| alist))) ) + (setq oldmaps (getdatabase opname 'operation)) + (setf (gethash opname *operation-hash*) + (adjoin (subst asharp-name opname (cdr modemap)) + oldmaps :test #'equal)) + (asharpMkAutoloadFunction object asharp-name)) + (when (if (null only) (not (eq key '%%)) (member key only)) + (setq *allOperations* nil) ; force this to recompute + (setq oldmaps (getdatabase key 'modemaps)) + (setq dbstruct (make-database)) + (setf (get key 'database) dbstruct) + (setq *allconstructors* (adjoin key *allconstructors*)) + (setf (database-constructorform dbstruct) + (fetchdata alist "constructorForm")) + (setf (database-constructorkind dbstruct) + (fetchdata alist "constructorKind")) + (setf (database-constructormodemap dbstruct) + (fetchdata alist "constructorModemap")) + (unless (setf (database-abbreviation dbstruct) + (fetchdata alist "abbreviation")) + (setf (database-abbreviation dbstruct) key)) ; default + (setq abbrev (database-abbreviation dbstruct)) + (setf (get abbrev 'abbreviationfor) key) + (setf (database-constructorcategory dbstruct) + (fetchdata alist "constructorCategory")) + (setf (database-attributes dbstruct) + (fetchdata alist "attributes")) + (setf (database-sourcefile dbstruct) + (fetchdata alist "sourceFile")) + (setf (database-operationalist dbstruct) + (fetchdata alist "operationAlist")) + (setf (database-modemaps dbstruct) + (fetchdata alist "modemaps")) + (setf (database-documentation dbstruct) + (fetchdata alist "documentation")) + (setf (database-predicates dbstruct) + (fetchdata alist "predicates")) + (setf (database-niladic dbstruct) + (fetchdata alist "NILADIC")) + (addoperations key oldmaps) + (setq cname (|opOf| (database-constructorform dbstruct))) + (setq kind (database-constructorkind dbstruct)) + (if (null noexpose) (|setExposeAddConstr| (cons cname nil))) + (unless make-database? + (|updateDatabase| key cname systemdir?) ;makes many hashtables??? + (|installConstructor| cname kind) + ;; following can break category database build + (if (eq kind '|category|) + (setf (database-ancestors dbstruct) + (fetchdata alist "ancestors"))) + (if (eq kind '|domain|) + (dolist (pair (cdr (assoc "ancestors" alist :test #'string=))) + (setf (gethash (cons cname (caar pair)) *hascategory-hash*) + (cdr pair)))) + (if |$InteractiveMode| (setq |$CategoryFrame| |$EmptyEnvironment|))) + (setf (database-cosig dbstruct) + (cons nil (mapcar #'|categoryForm?| + (cddar (database-constructormodemap dbstruct))))) + (setf (database-object dbstruct) (cons object asharp-name)) + (if (eq kind '|category|) + (asharpMkAutoLoadCategory object cname asharp-name + (database-cosig dbstruct)) + (asharpMkAutoLoadFunctor object cname asharp-name + (database-cosig dbstruct))) + (|sayKeyedMsg| 'S2IU0001 (list cname object)))))))) + +(defun localnrlib (key nrlib object make-database? noexpose) + "given a string pathname of an index.KAF and the object update the database" + (labels ( + (fetchdata (alist in index) + (let (pos) + (setq pos (third (assoc index alist :test #'string=))) + (when pos + (file-position in pos) + (read in))))) + (let (alist kind (systemdir? nil) pos constructorform oldmaps abbrev dbstruct) + (with-open-file (in nrlib) + (file-position in (read in)) + (setq alist (read in)) + (setq pos (third (assoc "constructorForm" alist :test #'string=))) + (file-position in pos) + (setq constructorform (read in)) + (setq key (car constructorform)) + (setq oldmaps (getdatabase key 'modemaps)) + (setq dbstruct (make-database)) + (setq *allconstructors* (adjoin key *allconstructors*)) + (setf (get key 'database) dbstruct) ; store the struct, side-effect it... + (setf (database-constructorform dbstruct) constructorform) + (setq *allOperations* nil) ; force this to recompute + (setf (database-object dbstruct) object) + (setq abbrev + (intern (pathname-name (first (last (pathname-directory object)))))) + (setf (database-abbreviation dbstruct) abbrev) + (setf (get abbrev 'abbreviationfor) key) + (setf (database-operationalist dbstruct) nil) + (setf (database-operationalist dbstruct) + (fetchdata alist in "operationAlist")) + (setf (database-constructormodemap dbstruct) + (fetchdata alist in "constructorModemap")) + (setf (database-modemaps dbstruct) (fetchdata alist in "modemaps")) + (setf (database-sourcefile dbstruct) (fetchdata alist in "sourceFile")) + (when make-database? + (setf (database-sourcefile dbstruct) + (file-namestring (database-sourcefile dbstruct)))) + (setf (database-constructorkind dbstruct) + (setq kind (fetchdata alist in "constructorKind"))) + (setf (database-constructorcategory dbstruct) + (fetchdata alist in "constructorCategory")) + (setf (database-documentation dbstruct) + (fetchdata alist in "documentation")) + (setf (database-attributes dbstruct) + (fetchdata alist in "attributes")) + (setf (database-predicates dbstruct) + (fetchdata alist in "predicates")) + (setf (database-niladic dbstruct) + (when (fetchdata alist in "NILADIC") t)) + (addoperations key oldmaps) + (unless make-database? + (if (eq kind '|category|) + (setf (database-ancestors dbstruct) + (SUBLISLIS |$FormalMapVariableList| (cdr constructorform) (fetchdata alist in "ancestors")))) + (|updateDatabase| key key systemdir?) ;makes many hashtables??? + (|installConstructor| key kind) ;used to be key cname ... + (|updateCategoryTable| key kind) + (if |$InteractiveMode| (setq |$CategoryFrame| |$EmptyEnvironment|))) + (setf (database-cosig dbstruct) + (cons nil (mapcar #'|categoryForm?| + (cddar (database-constructormodemap dbstruct))))) + (remprop key 'loaded) + (if (null noexpose) (|setExposeAddConstr| (cons key nil))) + #-:CCL + (setf (symbol-function key) ; sets the autoload property for cname + #'(lambda (&rest args) + (unless (get key 'loaded) + (|startTimingProcess| '|load|) + (|loadLibNoUpdate| key key object)) ; used to be cname key + (apply key args))) + #+:CCL + (let (lib) + (if (filep (setq lib (make-pathname :name object :type "lib")) ) + (setq input-libraries (cons (open-library (truename lib)) input-libraries))) + (|unloadOneConstructor| (get abbrev 'abbreviationfor) abbrev) ) + (|sayKeyedMsg| 'S2IU0001 (list key object)))))) + + +; making new databases consists of: +; 1) reset all of the system hash tables +; *) set up Union, Record and Mapping +; 2) map )library across all of the system files (fills the databases) +; 3) loading some normally autoloaded files +; 4) making some database entries that are computed (like ancestors) +; 5) writing out the databases +; 6) write out 'warm' data to be loaded into the image at build time +; note that this process should be done in a clean image +; followed by a rebuild of the system image to include +; the new index pointers (e.g. *interp-stream-stamp*) +; the system will work without a rebuild but it needs to +; re-read the databases on startup. rebuilding the system +; will cache the information into the image and the databases +; are opened but not read, saving considerable startup time. +; also note that the order the databases are written out is +; critical. interp.daase depends on prior computations and has +; to be written out last. + +(defun make-databases (ext dirlist) + (labels ( + ;; these are types which have no library object associated with them. + ;; we store some constructed data to make them perform like library + ;; objects, the *operationalist-hash* key entry is used by allConstructors + (withSpecialConstructors () + ; note: if item is not in *operationalist-hash* it will not be written + ; Category + (setf (get '|Category| 'database) + (make-database :operationalist nil :niladic t)) + (push '|Category| *allconstructors*) + ; UNION + (setf (get '|Union| 'database) + (make-database :operationalist nil :constructorkind '|domain|)) + (push '|Union| *allconstructors*) + ; RECORD + (setf (get '|Record| 'database) + (make-database :operationalist nil :constructorkind '|domain|)) + (push '|Record| *allconstructors*) + ; MAPPING + (setf (get '|Mapping| 'database) + (make-database :operationalist nil :constructorkind '|domain|)) + (push '|Mapping| *allconstructors*) + ; ENUMERATION + (setf (get '|Enumeration| 'database) + (make-database :operationalist nil :constructorkind '|domain|)) + (push '|Enumeration| *allconstructors*) + ) + (final-name (root) + (format nil "~a.daase~a" root ext)) + ) + (let (d) + (declare (special |$constructorList|)) + (do-symbols (symbol) + (when (get symbol 'database) + (setf (get symbol 'database) nil))) + (setq *hascategory-hash* (make-hash-table :test #'equal)) + (setq *operation-hash* (make-hash-table)) + (setq *allconstructors* nil) + (setq *compressvector* nil) + (withSpecialConstructors) + (localdatabase nil + (list (list '|dir| (namestring (truename "./")) )) + 'make-database) + (dolist (dir dirlist) + (localdatabase nil + (list (list '|dir| + (namestring (probe-file + (format nil "./~a" + dir))))) + 'make-database)) +#+:AKCL (|mkTopicHashTable|) + (setq |$constructorList| nil) ;; affects buildLibdb + (|buildLibdb|) + (|dbSplitLibdb|) +; (|dbAugmentConstructorDataTable|) + (|mkUsersHashTable|) + (|saveUsersHashTable|) + (|mkDependentsHashTable|) + (|saveDependentsHashTable|) +; (|buildGloss|) + (write-compress) + (write-browsedb) + (write-operationdb) + ; note: genCategoryTable creates a new *hascategory-hash* table + ; this smashes the existing table and regenerates it. + ; write-categorydb does getdatabase calls to write the new information + (write-categorydb) + (dolist (con (|allConstructors|)) + (let (dbstruct) + (when (setq dbstruct (get con 'database)) + (setf (database-cosig dbstruct) + (cons nil (mapcar #'|categoryForm?| + (cddar (database-constructormodemap dbstruct))))) + (when (and (|categoryForm?| con) + (= (length (setq d (|domainsOf| (list con) NIL NIL))) 1)) + (setq d (caar d)) + (when (= (length d) (length (|getConstructorForm| con))) + (format t " ~a has a default domain of ~a~%" con (car d)) + (setf (database-defaultdomain dbstruct) (car d))))))) + ; note: genCategoryTable creates *ancestors-hash*. write-interpdb + ; does gethash calls into it rather than doing a getdatabase call. + (write-interpdb) +#+:AKCL (write-warmdata) + (create-initializers) + (when (probe-file (final-name "compress")) + (delete-file (final-name "compress"))) + (rename-file "compress.build" (final-name "compress")) + (when (probe-file (final-name "interp")) + (delete-file (final-name "interp"))) + (rename-file "interp.build" (final-name "interp")) + (when (probe-file (final-name "operation")) + (delete-file (final-name "operation"))) + (rename-file "operation.build" (final-name "operation")) + (when (probe-file (final-name "browse")) + (delete-file (final-name "browse"))) + (rename-file "browse.build" + (final-name "browse")) + (when (probe-file (final-name "category")) + (delete-file (final-name "category"))) + (rename-file "category.build" + (final-name "category"))))) + +(defun DaaseName (name erase?) + (let (daase filename) + (if (setq daase (|systemAlgebraDirectory|)) + (progn + (setq filename (concatenate 'string daase name)) + (format t " Using local database ~a.." filename)) + (setq filename (concatenate 'string + (|systemRootDirectory|) + "/algebra/" + name))) + (when erase? (system::system (concatenate 'string "rm -f " filename))) + filename)) + +;; rewrite this so it works in mnt +;;(defun DaaseName (name erase?) +;; (let (daase filename) +;; (declare (special $spadroot)) +;; (if (setq daase (|getEnv| "DAASE")) +;; (progn +;; (setq filename (concatenate 'string daase "/algebra/" name)) +;; (format t " Using local database ~a.." filename)) +;; (setq filename (concatenate 'string $spadroot "/algebra/" name))) +;; (when erase? (system::system (concatenate 'string "rm -f " filename))) +;; filename)) + + +(defun compressOpen () + (let (lst stamp pos) + (setq *compress-stream* + (open (DaaseName "compress.daase" nil) :direction :input)) + (setq stamp (read *compress-stream*)) + (unless (equal stamp *compress-stream-stamp*) + (format t " Re-reading compress.daase") + (setq *compress-stream-stamp* stamp) + (setq pos (car stamp)) + (file-position *compress-stream* pos) + (setq lst (read *compress-stream*)) + (setq *compressVectorLength* (car lst)) + (setq *compressvector* + (make-array (car lst) :initial-contents (cdr lst)))))) + +(defun write-compress () + (let (compresslist masterpos out) + (close *compress-stream*) + (setq out (open "compress.build" :direction :output)) + (princ " " out) + (finish-output out) + (setq masterpos (file-position out)) + (setq compresslist + (append (|allConstructors|) (|allOperations|) *attributes*)) + (push "algebra" compresslist) + (push "failed" compresslist) + (push 'signature compresslist) + (push '|ofType| compresslist) + (push '|Join| compresslist) + (push 'and compresslist) + (push '|nobranch| compresslist) + (push 'category compresslist) + (push '|category| compresslist) + (push '|domain| compresslist) + (push '|package| compresslist) + (push 'attribute compresslist) + (push '|isDomain| compresslist) + (push '|ofCategory| compresslist) + (push '|Union| compresslist) + (push '|Record| compresslist) + (push '|Mapping| compresslist) + (push '|Enumeration| compresslist) + (setq *compressVectorLength* (length compresslist)) + (setq *compressvector* + (make-array *compressVectorLength* :initial-contents compresslist)) + (print (cons (length compresslist) compresslist) out) + (finish-output out) + (file-position out 0) + (print (cons masterpos (get-universal-time)) out) + (finish-output out) + (close out))) + +(defun write-interpdb () + "build interp.daase from hash tables" + (declare (special *ancestors-hash*)) + (let (opalistpos modemapspos cmodemappos master masterpos obj *print-pretty* + concategory categorypos kind niladic cosig abbrev defaultdomain + ancestors ancestorspos out) + (declare (special *print-pretty*)) + (print "building interp.daase") + (setq out (open "interp.build" :direction :output)) + (princ " " out) + (finish-output out) + (dolist (constructor (|allConstructors|)) + (let (struct) + (setq struct (get constructor 'database)) + (setq opalistpos (file-position out)) + (print (squeeze (database-operationalist struct)) out) + (finish-output out) + (setq cmodemappos (file-position out)) + (print (squeeze (database-constructormodemap struct)) out) + (finish-output out) + (setq modemapspos (file-position out)) + (print (squeeze (database-modemaps struct)) out) + (finish-output out) + (if (consp (database-object struct)) ; if asharp code ... + (setq obj + (cons (pathname-name (car (database-object struct))) + (cdr (database-object struct)))) + (setq obj + (pathname-name + (first (last (pathname-directory (database-object struct))))))) + (setq concategory (squeeze (database-constructorcategory struct))) + (if concategory ; if category then write data else write nil + (progn + (setq categorypos (file-position out)) + (print concategory out) + (finish-output out)) + (setq categorypos nil)) + (setq niladic (database-niladic struct)) + (setq abbrev (database-abbreviation struct)) + (setq cosig (database-cosig struct)) + (setq kind (database-constructorkind struct)) + (setq defaultdomain (database-defaultdomain struct)) + (setq ancestors (squeeze (gethash constructor *ancestors-hash*))) ;cattable.boot + (if ancestors + (progn + (setq ancestorspos (file-position out)) + (print ancestors out) + (finish-output out)) + (setq ancestorspos nil)) + (push (list constructor opalistpos cmodemappos modemapspos + obj categorypos niladic abbrev cosig kind defaultdomain + ancestorspos) master))) + (finish-output out) + (setq masterpos (file-position out)) + (print (mapcar #'squeeze master) out) + (finish-output out) + (file-position out 0) + (print (cons masterpos (get-universal-time)) out) + (finish-output out) + (close out))) + +(defun write-browsedb () + "make browse.daase from hash tables" + (let (master masterpos src formpos docpos attpos predpos *print-pretty* out) + (declare (special *print-pretty*)) + (print "building browse.daase") + (setq out (open "browse.build" :direction :output)) + (princ " " out) + (finish-output out) + (dolist (constructor (|allConstructors|)) + (let (struct) + (setq struct (get constructor 'database)) + ; sourcefile is small. store the string directly + (setq src (database-sourcefile struct)) + (setq formpos (file-position out)) + (print (squeeze (database-constructorform struct)) out) + (finish-output out) + (setq docpos (file-position out)) + (print (database-documentation struct) out) + (finish-output out) + (setq attpos (file-position out)) + (print (squeeze (database-attributes struct)) out) + (finish-output out) + (setq predpos (file-position out)) + (print (squeeze (database-predicates struct)) out) + (finish-output out) + (push (list constructor src formpos docpos attpos predpos) master))) + (finish-output out) + (setq masterpos (file-position out)) + (print (mapcar #'squeeze master) out) + (finish-output out) + (file-position out 0) + (print (cons masterpos (get-universal-time)) out) + (finish-output out) + (close out))) + +(defun write-categorydb () + "make category.daase from scratch. contains the *hasCategory-hash* table" + (let (out master pos *print-pretty*) + (declare (special *print-pretty*)) + (print "building category.daase") + (|genCategoryTable|) + (setq out (open "category.build" :direction :output)) + (princ " " out) + (finish-output out) + (maphash #'(lambda (key value) + (if (or (null value) (eq value t)) + (setq pos value) + (progn + (setq pos (file-position out)) + (print (squeeze value) out) + (finish-output out))) + (push (list key pos) master)) + *hasCategory-hash*) + (setq pos (file-position out)) + (print (mapcar #'squeeze master) out) + (finish-output out) + (file-position out 0) + (print (cons pos (get-universal-time)) out) + (finish-output out) + (close out))) + +(defun unsqueeze (expr) + (cond ((atom expr) + (cond ((and (numberp expr) (<= expr 0)) + (svref *compressVector* (- expr))) + (t expr))) + (t (rplaca expr (unsqueeze (car expr))) + (rplacd expr (unsqueeze (cdr expr))) + expr))) + +(defun squeeze (expr) + (let (leaves pos (bound (length *compressvector*))) + (labels ( + (flat (expr) + (when (and (numberp expr) (< expr 0) (>= expr bound)) + (print expr) + (break "squeeze found a negative number")) + (if (atom expr) + (unless (or (null expr) + (and (symbolp expr) (char= (schar (symbol-name expr) 0) #\*))) + (setq leaves (adjoin expr leaves))) + (progn + (flat (car expr)) + (flat (cdr expr)))))) + (setq leaves nil) + (flat expr) + (dolist (leaf leaves) + (when (setq pos (position leaf *compressvector*)) + (nsubst (- pos) leaf expr))) + expr))) + +(defun write-operationdb () + (let (pos master out) + (declare (special leaves)) + (setq out (open "operation.build" :direction :output)) + (princ " " out) + (finish-output out) + (maphash #'(lambda (key value) + (setq pos (file-position out)) + (print (squeeze value) out) + (finish-output out) + (push (cons key pos) master)) + *operation-hash*) + (finish-output out) + (setq pos (file-position out)) + (print (mapcar #'squeeze master) out) + (file-position out 0) + (print (cons pos (get-universal-time)) out) + (finish-output out) + (close out))) + +(defun write-warmdata () + "write out information to be loaded into the image at build time" + (declare (special |$topicHash|)) + (with-open-file (out "warm.data" :direction :output) + (format out "(in-package \"BOOT\")~%") + (format out "(setq |$topicHash| (make-hash-table))~%") + (maphash #'(lambda (k v) + (format out "(setf (gethash '|~a| |$topicHash|) ~a)~%" k v)) |$topicHash|))) + +(defun |allConstructors| () + (declare (special *allconstructors*)) + *allconstructors*) + +(defun |allOperations| () + (declare (special *allOperations*)) + (unless *allOperations* + (maphash #'(lambda (k v) (declare (ignore v)) (push k *allOperations*)) + *operation-hash*)) + *allOperations*) + +; the variable NOPfuncall is a funcall-able object that is a dummy +; initializer for libaxiom asharp domains. +(defvar NOPfuncall (cons 'identity nil)) + +(defun create-initializers () +;; since libaxiom is now built with -name=axiom following unnecessary +;; (dolist (con (|allConstructors|)) +;; (let ((sourcefile (getdatabase con 'sourcefile))) +;; (if sourcefile +;; (set (foam::axiomxl-file-init-name (pathname-name sourcefile)) +;; NOPfuncall)))) + (set (foam::axiomxl-file-init-name "axiom") NOPfuncall) +;; (set (foam::axiomxl-file-init-name "axclique") NOPfuncall) + (set (foam::axiomxl-file-init-name "filecliq") NOPfuncall) + (set (foam::axiomxl-file-init-name "attrib") NOPfuncall) +;; following needs to happen inside restart since $AXIOM may change + (let ((asharprootlib (strconc (|systemRootDirectory|) "/aldor/lib/"))) + (set-file-getter (strconc asharprootlib "runtime")) + (set-file-getter (strconc asharprootlib "lang")) + (set-file-getter (strconc asharprootlib "attrib")) + (set-file-getter (strconc asharprootlib "axlit")) + (set-file-getter (strconc asharprootlib "minimach")) + (set-file-getter (strconc asharprootlib "axextend")))) + + + +;--------------------------------------------------------------------- + +; how the magic works: +; when a )library is done on a new compiler file we set up multiple +; functions (refered to as autoloaders). there is an autoloader +; stored in the symbol-function of the G-filename (e.g. G-basic) +; (see set-file-getter function) +; and an autoloader stored in the symbol-function of every domain +; in the basic.as file ( asharpMkAutoloadFunctor ) +; When a domain is needed the autoloader for the domain is executed. +; this autoloader invokes file-getter-name to get the name of the +; file (eg basic) and evaluates the name. the FIRST time this is done +; for a file the file will be loaded by its autoloader, then it will +; return the file object. every other time the file is already +; loaded and the file object is returned directly. +; Once the file object is gotten getconstructor is called to get the +; domain. the FIRST time this is done for the domain the autoloader +; invokes the file object. every other time the domain already +; exists. +;(defvar *this-file* "no-file") + +(defmacro |CCall| (fun &rest args) + (let ((ccc (gensym)) (cfun (gensym)) (cenv (gensym))) + `(let ((,ccc ,fun)) + (let ((,cfun (|ClosFun| ,ccc)) + (,cenv (|ClosEnv| ,ccc))) + (funcall ,cfun ,@args ,cenv ))))) + +(defmacro |ClosFun| (x) `(car ,x)) +(defmacro |ClosEnv| (x) `(cdr ,x)) + +(defun file-runner (name) + (declare (special foam-user::|G-domainPrepare!|)) + (|CCall| foam-user::|G-domainPrepare!| (|CCall| name))) + +(defun getConstructor (file-fn asharp-name) + (|CCall| file-fn) +; (eval (cdr (assoc file-id (get name 'asharp-name) :test #'equal)))) + (eval asharp-name)) + +(defun getop (dom op type) + (declare (special foam-user::|G-domainGetExport!|)) + (|CCall| foam-user::|G-domainGetExport!| dom + (|hashString| (symbol-name op)) type)) + +; the asharp compiler will allow both constant domains and domains +; which are functions. localasy sets the autoload property so that +; the symbol-function contains a function that, when invoked with +; the correct number of args will return a domain. + +; this function is called if we are given a new compiler domain +; which is a function. the symbol-function of the domain is set +; to call the function with the correct number of arguments. + +(defun wrapDomArgs (obj type?) + (cond ((not type?) obj) + (t (|makeOldAxiomDispatchDomain| obj)))) + +;; CCL doesn't have closures, so we use an intermediate function in +;; asharpMkAutoLoadFunctor. +#+:CCL +(defun mkFunctorStub (func cosig cname) + (setf (symbol-function cname) + (if (vectorp (car func)) + `(lambda () ',func) ;; constant domain + `(lambda (&rest args2) + (apply ',(|ClosFun| func) + (nconc + (mapcar #'wrapDomArgs args2 ',(cdr cosig)) + (list ',(|ClosEnv| func)))))))) + +#+:CCL +(defun asharpMkAutoLoadFunctor (file cname asharp-name cosig) + (setf (symbol-function cname) + `(lambda (&rest args) + (mkFunctorStub + (getconstructor (eval (file-getter-name ',file)) ',asharp-name) + ',cosig ',cname) + (apply ',cname args)))) + +#-:CCL +(defun asharpMkAutoLoadFunctor (file cname asharp-name cosig) + (setf (symbol-function cname) + #'(lambda (&rest args) + (let ((func (getconstructor (eval (file-getter-name file)) asharp-name))) + (setf (symbol-function cname) + (if (vectorp (car func)) + #'(lambda () func) ;; constant domain + #'(lambda (&rest args) + (apply (|ClosFun| func) + (nconc + (mapcar #'wrapDomArgs args (cdr cosig)) + (list (|ClosEnv| func))))))) + (apply cname args))))) + +;; CCL doesn't have closures, so we use an intermediate function in +;; asharpMkAutoLoadCategory. +#+:CCL +(defun mkCategoryStub (func cosig packname) + (setf (symbol-function packname) + (if (vectorp (car func)) + `(lambda (self) ;; constant category + (|CCall| (elt ',(car func) 5) ',(cdr func) (wrapDomArgs self t))) + `(lambda (self &rest args) + (let ((precat + (apply (|ClosFun| ',func) + (nconc + (mapcar #'wrapDomArgs args ',(cdr cosig)) + (list (|ClosEnv| ',func)))))) + (|CCall| (elt (car precat) 5) (cdr precat) (wrapDomArgs self t))))) +)) + +#+:CCL +(defun asharpMkAutoLoadCategory (file cname asharp-name cosig) + (asharpMkAutoLoadFunctor file cname asharp-name cosig) + (let ((packname (INTERN (STRCONC cname "&")))) + (setf (symbol-function packname) + `(lambda (self &rest args) + (mkCategoryStub + (getconstructor (eval (file-getter-name ',file)) ',asharp-name) + ',cosig ',packname) + (apply ',packname self args))))) + +#-:CCL +(defun asharpMkAutoLoadCategory (file cname asharp-name cosig) + (asharpMkAutoLoadFunctor file cname asharp-name cosig) + (let ((packname (INTERN (STRCONC cname '"&")))) + (setf (symbol-function packname) + #'(lambda (self &rest args) + (let ((func (getconstructor (eval (file-getter-name file)) asharp-name))) + (setf (symbol-function packname) + (if (vectorp (car func)) + #'(lambda (self) + (|CCall| (elt (car func) 5) (cdr func) (wrapDomArgs self t))) ;; constant category + #'(lambda (self &rest args) + (let ((precat + (apply (|ClosFun| func) + (nconc + (mapcar #'wrapDomArgs args (cdr cosig)) + (list (|ClosEnv| func)))))) + (|CCall| (elt (car precat) 5) (cdr precat) (wrapDomArgs self t)))))) + (apply packname self args)))))) + +#+:CCL +(defun asharpMkAutoLoadFunction (file asharpname) + (set asharpname + (cons + `(lambda (&rest l) + (let ((args (butlast l)) + (func (getconstructor (eval (file-getter-name ',file)) ',asharpname))) + (apply (car func) (append args (list (cdr func)))))) + ()))) + +#-:CCL +(defun asharpMkAutoLoadFunction (file asharpname) + (set asharpname + (cons + #'(lambda (&rest l) + (let ((args (butlast l)) + (func (getconstructor (eval (file-getter-name file)) asharpname))) + (apply (car func) (append args (list (cdr func)))))) + ()))) + +; this function will return the internal name of the file object getter + +(defun file-getter-name (filename) + (foam::axiomxl-file-init-name (pathname-name filename))) + +;;need to initialize |G-filename| to a function which loads file +;; and then returns the new value of |G-filename| + +(defun set-file-getter (filename) + (let ((getter-name (file-getter-name filename))) + (set getter-name + (cons #'init-file-getter (cons getter-name filename))))) + +(defun init-file-getter (env) + (let ((getter-name (car env)) + (filename (cdr env))) +#-:CCL + (load filename) +#+:CCL + (load-module filename) + (|CCall| (eval getter-name)))) + +(defun set-lib-file-getter (filename cname) + (let ((getter-name (file-getter-name filename))) + (set getter-name + (cons #'init-lib-file-getter (cons getter-name cname))))) + +(defun init-lib-file-getter (env) + (let* ((getter-name (car env)) + (cname (cdr env)) + (filename (getdatabase cname 'object))) +#-:CCL + (load filename) +#+:CCL + (load-module (pathname-name filename)) + (|CCall| (eval getter-name)))) + +;; following 2 functions are called by file-exports and file-imports macros +(defun foam::process-import-entry (entry) + (let* ((asharpname (car entry)) + (stringname (cadr entry)) + (hcode (caddr entry)) + (libname (cadddr entry)) + (bootname (intern stringname 'boot))) + (declare (ignore libname)) + (if (and (eq hcode 'foam-user::|initializer|) (not (boundp asharpname))) + (error (format nil "AxiomXL file ~s is missing!" stringname))) + (unless (or (not (numberp hcode)) (zerop hcode) (boundp asharpname)) + (when (|constructor?| bootname) + (set asharpname + (if (getdatabase bootname 'niladic) + (|makeLazyOldAxiomDispatchDomain| (list bootname)) + (cons '|runOldAxiomFunctor| bootname)))) + (when (|attribute?| bootname) + (set asharpname (|makeLazyOldAxiomDispatchDomain| bootname)))))) + + + +;(defun foam::process-export-entry (entry) +; (let* ((asharpname (car entry)) +; (stringname (cadr entry)) +; (hcode (caddr entry)) +; (libname (cadddr entry)) +; (bootname (intern stringname 'boot))) +; (declare (ignore libname)) +; (when (numberp hcode) +; (setf (get bootname 'asharp-name) +; (cons (cons *this-file* asharpname) +; (get bootname 'asharp-name))) +; ))) + + + + + + + diff --git a/src/interp/daase.lisp.pamphlet b/src/interp/daase.lisp.pamphlet deleted file mode 100644 index 018e6758..00000000 --- a/src/interp/daase.lisp.pamphlet +++ /dev/null @@ -1,2037 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp daase.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{Database structure} -In order to understand this program you need to understand some details -of the structure of the databases it reads. Axiom has 5 databases, -the interp.daase, operation.daase, category.daase, compress.daase, and -browse.daase. The compress.daase is special and does not follow the -normal database format. - -\subsection{KAF File Format} -This documentation refers to KAF files which are random access files. -NRLIB files are KAF files (look for NRLIB/index.KAF) -The format of a random access file is -\begin{verbatim} -byte-offset-of-key-table -first-entry -second-entry -... -last-entry -((key1 . first-entry-byte-address) - (key2 . second-entry-byte-address) - ... - (keyN . last-entry-byte-address)) -\end{verbatim} -The key table is a standard lisp alist. - -To open a database you fetch the first number, seek to that location, -and (read) which returns the key-data alist. To look up data you -index into the key-data alist, find the ith-entry-byte-address, -seek to that address, and (read). - -For instance, see src/share/algebra/USERS.DAASE/index.KAF - -One existing optimization is that if the data is a simple thing like a -symbol then the nth-entry-byte-address is replaced by immediate data. - -Another existing one is a compression algorithm applied to the -data so that the very long names don't take up so much space. -We could probably remove the compression algorithm as 64k is no -longer considered 'huge'. The database-abbreviation routine -handles this on read and write-compress handles this on write. -The squeeze routine is used to compress the keys, the unsqueeze -routine uncompresses them. Making these two routines disappear -should remove all of the compression. - -Indeed, a faster optimization is to simply read the whole database -into the image before it is saved. The system would be easier to -understand and the interpreter would be faster. - -The system uses another optimization: database contains a stamp -(consisting of offset to the main list and build time). Before -saving the image selected data is fetched to memory. When the -saved image starts it checks if the stamp of saved data matches -in-core data -- in case of agreement in-core data is used. -Parts of the datatabase which was not pre-loaded is still -(lazily) fetched from the filesystem. - -\subsection{Database Files} - -Database files are very similar to KAF files except that there -is an optimization (currently broken) which makes the first -item a pair of two numbers. The first number in the pair is -the offset of the key-value table, the second is a time stamp. -If the time stamp in the database matches the time stamp in -the image the database is not needed (since the internal hash -tables already contain all of the information). When the database -is built the time stamp is saved in both the gcl image and the -database. - -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -;;TTT 7/2/97 -; Regarding the 'ancestors field for a category: At database build -; time there exists a *ancestors-hash* hash table that gets filled -; with CATEGORY (not domain) ancestor information. This later provides -; the information that goes into interp.daase This *ancestors-hash* -; does not exist at normal runtime (it can be made by a call to -; genCategoryTable). Note that the ancestor information in -; *ancestors-hash* (and hence interp.daase) involves #1, #2, etc -; instead of R, Coef, etc. The latter thingies appear in all -; .NRLIB/index.KAF files. So we need to be careful when we )lib -; categories and update the ancestor info. - - -; This file contains the code to build, open and access the .DAASE -; files this file contains the code to )library NRLIBS and asy files - -; There is a major issue about the data that resides in these -; databases. the fundamental problem is that the system requires more -; information to build the databases than it needs to run the -; interpreter. in particular, MODEMAP.DAASE is constructed using -; properties like "modemaps" but the interpreter will never ask for -; this information. - -; So, the design is as follows: -; first, the MODEMAP.DAASE needs to be built. this is done by doing -; a )library on ALL of the NRLIB files that are going into the system. -; this will bring in "modemap" information and add it to the -; *modemaps-hash* hashtable. -; next, database build proceeds, accessing the "modemap" property -; from the hashtables. once this completes this information is never -; used again. -; next, the interp.daase database is built. this contains only the -; information necessary to run the interpreter. note that during the -; running of the interpreter users can extend the system by do a -; )library on a new NRLIB file. this will cause fields such as "modemap" -; to be read and hashed. - -; In the old system each constructor (e.g. LIST) had one library directory -; (e.g. LIST.NRLIB). this directory contained a random access file called -; the index.KAF file. the interpreter needed this KAF file at runtime for -; two entries, the operationAlist and the ConstructorModemap. -; during the redesign for the new compiler we decided to merge all of -; these .NRLIB/index.KAF files into one database, INTERP.DAASE. -; requests to get information from this database are intended to be -; cached so that multiple references do not cause additional disk i/o. -; this database is left open at all times as it is used frequently by -; the interpreter. one minor complication is that newly compiled files -; need to override information that exists in this database. -; The design calls for constructing a random read (KAF format) file -; that is accessed by functions that cache their results. when the -; database is opened the list of constructor-index pairs is hashed -; by constructor name. a request for information about a constructor -; causes the information to replace the index in the hash table. since -; the index is a number and the data is a non-numeric sexpr there is -; no source of confusion about when the data needs to be read. -; -; The format of this new database is as follows: -; -;first entry: -; an integer giving the byte offset to the constructor alist -; at the bottom of the file -;second and subsequent entries (one per constructor) -; (operationAlist) -; (constructorModemap) -; .... -;last entry: (pointed at by the first entry) -; an alist of (constructor . index) e.g. -; ( (PI offset-of-operationAlist offset-of-constructorModemap) -; (NNI offset-of-operationAlist offset-of-constructorModemap) -; ....) -; This list is read at open time and hashed by the car of each item. - -; the system has been changed to use the property list of the -; symbols rather than hash tables. since we already hashed once -; to get the symbol we need only an offset to get the property -; list. this also has the advantage that eq hash tables no longer -; need to be moved during garbage collection. -; there are 3 potential speedups that could be done. the best -; would be to use the value cell of the symbol rather than the -; property list but i'm unable to determine all uses of the -; value cell at the present time. -; a second speedup is to guarantee that the property list is -; a single item, namely the database structure. this removes -; an assoc but leaves one open to breaking the system if someone -; adds something to the property list. this was not done because -; of the danger mentioned. -; a third speedup is to make the getdatabase call go away, either -; by making it a macro or eliding it entirely. this was not done -; because we want to keep the flexibility of changing the database -; forms. - -; the new design does not use hash tables. the database structure -; contains an entry for each item that used to be in a hash table. -; initially the structure contains file-position pointers and -; these are replaced by real data when they are first looked up. -; the database structure is kept on the property list of the -; constructor, thus, (get '|DenavitHartenbergMatrix| 'database) -; will return the database structure object. - -; each operation has a property on its symbol name called 'operation -; which is a list of all of the signatures of operations with that name. - -; -- tim daly - -(in-package "BOOT") - -(defstruct database - abbreviation ; interp. - ancestors ; interp. - constructor ; interp. - constructorcategory ; interp. - constructorkind ; interp. - constructormodemap ; interp. - cosig ; interp. - defaultdomain ; interp. - modemaps ; interp. - niladic ; interp. - object ; interp. - operationalist ; interp. - documentation ; browse. - constructorform ; browse. - attributes ; browse. - predicates ; browse. - sourcefile ; browse. - parents ; browse. - users ; browse. - dependents ; browse. - spare ; superstition - ) ; database structure - -; there are only a small number of domains that have default domains. -; rather than keep this slot in every domain we maintain a list here. - -(defvar *defaultdomain-list* '( - (|MultisetAggregate| |Multiset|) - (|FunctionSpace| |Expression|) - (|AlgebraicallyClosedFunctionSpace| |Expression|) - (|ThreeSpaceCategory| |ThreeSpace|) - (|DequeueAggregate| |Dequeue|) - (|ComplexCategory| |Complex|) - (|LazyStreamAggregate| |Stream|) - (|AssociationListAggregate| |AssociationList|) - (|QuaternionCategory| |Quaternion|) - (|PriorityQueueAggregate| |Heap|) - (|PointCategory| |Point|) - (|PlottableSpaceCurveCategory| |Plot3D|) - (|PermutationCategory| |Permutation|) - (|StringCategory| |String|) - (|FileNameCategory| |FileName|) - (|OctonionCategory| |Octonion|))) - -; this hash table is used to answer the question "does domain x -; have category y?". this is answered by constructing a pair of -; (x . y) and doing an equal hash into this table. - -(defvar *operation-hash* nil "given an operation name, what are its modemaps?") -(defvar *hasCategory-hash* nil "answers x has y category questions") - -(defvar *miss* nil "print out cache misses on getdatabase calls") - - ; note that constructorcategory information need only be kept for - ; items of type category. this will be fixed in the next iteration - ; when the need for the various caches are reviewed - - ; note that the *modemaps-hash* information does not need to be kept - ; for system files. these are precomputed and kept in modemap.daase - ; however, for user-defined files these are needed. - ; currently these are added to the database for 2 reasons: - ; there is a still-unresolved issue of user database extensions - ; this information is used during database build time - - - -; this are the streams for the databases. they are always open. -; there is an optimization for speeding up system startup. if the -; database is opened and the ..-stream-stamp* variable matches the -; position information in the database then the database is NOT -; read in and is assumed to match the in-core version - -(defvar *compressvector* nil "a vector of things to compress in the databases") -(defvar *compressVectorLength* 0 "length of the compress vector") -(defvar *compress-stream* nil "an stream containing the compress vector") -(defvar *compress-stream-stamp* 0 "*compress-stream* (position . time)") - -(defvar *interp-stream* nil "an open stream to the interpreter database") -(defvar *interp-stream-stamp* 0 "*interp-stream* (position . time)") - -; this is indexed by operation, not constructor -(defvar *operation-stream* nil "the stream to operation.daase") -(defvar *operation-stream-stamp* 0 "*operation-stream* (position . time)") - -(defvar *browse-stream* nil "an open stream to the browser database") -(defvar *browse-stream-stamp* 0 "*browse-stream* (position . time)") - -; this is indexed by (domain . category) -(defvar *category-stream* nil "an open stream to the category table") -(defvar *category-stream-stamp* 0 "*category-stream* (position . time)") - -(defvar *allconstructors* nil "a list of all the constructors in the system") -(defvar *allOperations* nil "a list of all the operations in the system") - -(defvar *asharpflags* "-O -laxiom -Fasy -Flsp" "library compiler flags") - -(defun asharp (file &optional (flags *asharpflags*)) - "call the asharp compiler" - (system::system - (concatenate 'string (|systemRootDirectory|) "/compiler/bin/axiomxl " - flags " " file))) - -(defun resethashtables () - "set all -hash* to clean values. used to clean up core before saving system" - (setq *hascategory-hash* (make-hash-table :test #'equal)) - (setq *operation-hash* (make-hash-table)) - (setq *allconstructors* nil) - (setq *compressvector* nil) - (setq *compress-stream-stamp* '(0 . 0)) - (compressopen) - (setq *interp-stream-stamp* '(0 . 0)) - (interpopen) - (setq *operation-stream-stamp* '(0 . 0)) - (operationopen) - (setq *browse-stream-stamp* '(0 . 0)) - (browseopen) - (setq *category-stream-stamp* '(0 . 0)) - (categoryopen) ;note: this depends on constructorform in browse.daase -#-:CCL (initial-getdatabase) - (close *interp-stream*) - (close *operation-stream*) - (close *category-stream*) - (close *browse-stream*) -#+:AKCL (gbc t) -) - -(defun initial-getdatabase () - "fetch data we want in the saved system" - (let (hascategory constructormodemapAndoperationalist operation constr) - (format t "Initial getdatabase~%") - (setq hascategory '( - (|Equation| . |Ring|) - (|Expression| . |CoercibleTo|) (|Expression| . |CommutativeRing|) - (|Expression| . |IntegralDomain|) (|Expression| . |Ring|) - (|Float| . |RetractableTo|) - (|Fraction| . |Algebra|) (|Fraction| . |CoercibleTo|) - (|Fraction| . |OrderedSet|) (|Fraction| . |RetractableTo|) - (|Integer| . |Algebra|) (|Integer| . |CoercibleTo|) - (|Integer| . |ConvertibleTo|) (|Integer| . |LinearlyExplicitRingOver|) - (|Integer| . |RetractableTo|) - (|List| . |CoercibleTo|) (|List| . |FiniteLinearAggregate|) - (|List| . |OrderedSet|) - (|Polynomial| . |CoercibleTo|) (|Polynomial| . |CommutativeRing|) - (|Polynomial| . |ConvertibleTo|) (|Polynomial| . |OrderedSet|) - (|Polynomial| . |RetractableTo|) - (|Symbol| . |CoercibleTo|) (|Symbol| . |ConvertibleTo|) - (|Variable| . |CoercibleTo|))) - (dolist (pair hascategory) (getdatabase pair 'hascategory)) - (setq constructormodemapAndoperationalist '( - |BasicOperator| |Boolean| - |CardinalNumber| |Color| |Complex| - |Database| - |Equation| |EquationFunctions2| |Expression| - |Float| |Fraction| |FractionFunctions2| - |Integer| |IntegralDomain| - |Kernel| - |List| - |Matrix| |MappingPackage1| - |Operator| |OutputForm| - |NonNegativeInteger| - |ParametricPlaneCurve| |ParametricSpaceCurve| |Point| |Polynomial| - |PolynomialFunctions2| |PositiveInteger| - |Ring| - |SetCategory| |SegmentBinding| |SegmentBindingFunctions2| |DoubleFloat| - |SparseMultivariatePolynomial| |SparseUnivariatePolynomial| |Segment| - |String| |Symbol| - |UniversalSegment| - |Variable| |Vector|)) - (dolist (con constructormodemapAndoperationalist) - (getdatabase con 'constructormodemap) - (getdatabase con 'operationalist)) - (setq operation '( - |+| |-| |*| |/| |**| |coerce| |convert| |elt| |equation| - |float| |sin| |cos| |map| |SEGMENT|)) - (dolist (op operation) (getdatabase op 'operation)) - (setq constr '( ;these are sorted least-to-most freq. delete early ones first - |Factored| |SparseUnivariatePolynomialFunctions2| |TableAggregate&| - |RetractableTo&| |RecursiveAggregate&| |UserDefinedPartialOrdering| - |None| |UnivariatePolynomialCategoryFunctions2| |IntegerPrimesPackage| - |SetCategory&| |IndexedExponents| |QuotientFieldCategory&| |Polynomial| - |EltableAggregate&| |PartialDifferentialRing&| |Set| - |UnivariatePolynomialCategory&| |FlexibleArray| - |SparseMultivariatePolynomial| |PolynomialCategory&| - |DifferentialExtension&| |IndexedFlexibleArray| |AbelianMonoidRing&| - |FiniteAbelianMonoidRing&| |DivisionRing&| |FullyLinearlyExplicitRingOver&| - |IndexedVector| |IndexedOneDimensionalArray| |LocalAlgebra| |Localize| - |Boolean| |Field&| |Vector| |IndexedDirectProductObject| |Aggregate&| - |PolynomialRing| |FreeModule| |IndexedDirectProductAbelianGroup| - |IndexedDirectProductAbelianMonoid| |SingletonAsOrderedSet| - |SparseUnivariatePolynomial| |Fraction| |Collection&| |HomogeneousAggregate&| - |RepeatedSquaring| |IntegerNumberSystem&| |AbelianSemiGroup&| - |AssociationList| |OrderedRing&| |SemiGroup&| |Symbol| - |UniqueFactorizationDomain&| |EuclideanDomain&| |IndexedAggregate&| - |GcdDomain&| |IntegralDomain&| |DifferentialRing&| |Monoid&| |Reference| - |UnaryRecursiveAggregate&| |OrderedSet&| |AbelianGroup&| |Algebra&| - |Module&| |Ring&| |StringAggregate&| |AbelianMonoid&| - |ExtensibleLinearAggregate&| |PositiveInteger| |StreamAggregate&| - |IndexedString| |IndexedList| |ListAggregate&| |LinearAggregate&| - |Character| |String| |NonNegativeInteger| |SingleInteger| - |OneDimensionalArrayAggregate&| |FiniteLinearAggregate&| |PrimitiveArray| - |Integer| |List| |OutputForm|)) - (dolist (con constr) - (let ((c (concatenate 'string - (|systemRootDirectory|) "/algebra/" - (string (getdatabase con 'abbreviation)) ".o"))) - (format t " preloading ~a.." c) - (if (probe-file c) - (progn - (put con 'loaded c) - (load c) - (format t "loaded.~%")) - (format t "skipped.~%")))) - (format t "~%"))) - -; format of an entry in interp.daase: -; (constructor-name -; operationalist -; constructormodemap -; modemaps -- this should not be needed. eliminate it. -; object -- the name of the object file to load for this con. -; constructorcategory -- note that this info is the cadar of the -; constructormodemap for domains and packages so it is stored -; as NIL for them. it is valid for categories. -; niladic -- t or nil directly -; unused -; cosig -- kept directly -; constructorkind -- kept directly -; defaultdomain -- a short list, for %i -; ancestors -- used to compute new category updates -; ) -(defun interpOpen () - "open the interpreter database and hash the keys" - (let (constructors pos stamp dbstruct) - (setq *interp-stream* (open (DaaseName "interp.daase" nil))) - (setq stamp (read *interp-stream*)) - (unless (equal stamp *interp-stream-stamp*) - (format t " Re-reading interp.daase") - (setq *interp-stream-stamp* stamp) - (setq pos (car stamp)) - (file-position *interp-stream* pos) - (setq constructors (read *interp-stream*)) - (dolist (item constructors) - (setq item (unsqueeze item)) - (setq *allconstructors* (adjoin (first item) *allconstructors*)) - (setq dbstruct (make-database)) - (setf (get (car item) 'database) dbstruct) - (setf (database-operationalist dbstruct) (second item)) - (setf (database-constructormodemap dbstruct) (third item)) - (setf (database-modemaps dbstruct) (fourth item)) - (setf (database-object dbstruct) (fifth item)) - (setf (database-constructorcategory dbstruct) (sixth item)) - (setf (database-niladic dbstruct) (seventh item)) - (setf (database-abbreviation dbstruct) (eighth item)) - (setf (get (eighth item) 'abbreviationfor) (first item)) ;invert - (setf (database-cosig dbstruct) (ninth item)) - (setf (database-constructorkind dbstruct) (tenth item)) - (setf (database-ancestors dbstruct) (nth 11 item)))) - (format t "~&"))) - -; this is an initialization function for the constructor database -; it sets up 2 hash tables, opens the database and hashes the index values - -; there is a slight asymmetry in this code. sourcefile information for -; system files is only the filename and extension. for user files it -; contains the full pathname. when the database is first opened the -; sourcefile slot contains system names. the lookup function -; has to prefix the $spadroot information if the directory-namestring is -; null (we don't know the real root at database build time). -; a object-hash table is set up to look up nrlib and ao information. -; this slot is empty until a user does a )library call. we remember -; the location of the nrlib or ao file for the users local library -; at that time. a NIL result from this probe means that the -; library is in the system-specified place. when we get into multiple -; library locations this will also contain system files. - - -; format of an entry in browse.daase: -; ( constructorname -; sourcefile -; constructorform -; documentation -; attributes -; predicates -; ) - -(defun browseOpen () - "open the constructor database and hash the keys" - (let (constructors pos stamp dbstruct) - (setq *browse-stream* (open (DaaseName "browse.daase" nil))) - (setq stamp (read *browse-stream*)) - (unless (equal stamp *browse-stream-stamp*) - (format t " Re-reading browse.daase") - (setq *browse-stream-stamp* stamp) - (setq pos (car stamp)) - (file-position *browse-stream* pos) - (setq constructors (read *browse-stream*)) - (dolist (item constructors) - (setq item (unsqueeze item)) - (unless (setq dbstruct (get (car item) 'database)) - (format t "browseOpen:~%") - (format t "the browse database contains a contructor ~a~%" item) - (format t "that is not in the interp.daase file. we cannot~%") - (format t "get the database structure for this constructor and~%") - (warn "will create a new one~%") - (setf (get (car item) 'database) (setq dbstruct (make-database))) - (setq *allconstructors* (adjoin item *allconstructors*))) - (setf (database-sourcefile dbstruct) (second item)) - (setf (database-constructorform dbstruct) (third item)) - (setf (database-documentation dbstruct) (fourth item)) - (setf (database-attributes dbstruct) (fifth item)) - (setf (database-predicates dbstruct) (sixth item)) - (setf (database-parents dbstruct) (seventh item)))) - (format t "~&"))) - -(defun categoryOpen () - "open category.daase and hash the keys" - (let (pos keys stamp) - (setq *category-stream* (open (DaaseName "category.daase" nil))) - (setq stamp (read *category-stream*)) - (unless (equal stamp *category-stream-stamp*) - (format t " Re-reading category.daase") - (setq *category-stream-stamp* stamp) - (setq pos (car stamp)) - (file-position *category-stream* pos) - (setq keys (read *category-stream*)) - (setq *hasCategory-hash* (make-hash-table :test #'equal)) - (dolist (item keys) - (setq item (unsqueeze item)) - (setf (gethash (first item) *hasCategory-hash*) (second item)))) - (format t "~&"))) - -(defun operationOpen () - "read operation database and hash the keys" - (let (operations pos stamp) - (setq *operation-stream* (open (DaaseName "operation.daase" nil))) - (setq stamp (read *operation-stream*)) - (unless (equal stamp *operation-stream-stamp*) - (format t " Re-reading operation.daase") - (setq *operation-stream-stamp* stamp) - (setq pos (car stamp)) - (file-position *operation-stream* pos) - (setq operations (read *operation-stream*)) - (dolist (item operations) - (setq item (unsqueeze item)) - (setf (gethash (car item) *operation-hash*) (cdr item)))) - (format t "~&"))) - -(defun addoperations (constructor oldmaps) - "add ops from a )library domain to *operation-hash*" - (declare (special *operation-hash*)) - (dolist (map oldmaps) ; out with the old - (let (oldop op) - (setq op (car map)) - (setq oldop (getdatabase op 'operation)) - (setq oldop (lisp::delete (cdr map) oldop :test #'equal)) - (setf (gethash op *operation-hash*) oldop))) - (dolist (map (getdatabase constructor 'modemaps)) ; in with the new - (let (op newmap) - (setq op (car map)) - (setq newmap (getdatabase op 'operation)) - (setf (gethash op *operation-hash*) (cons (cdr map) newmap))))) - -(defun showdatabase (constructor) - (format t "~&~a: ~a~%" 'constructorkind - (getdatabase constructor 'constructorkind)) - (format t "~a: ~a~%" 'cosig - (getdatabase constructor 'cosig)) - (format t "~a: ~a~%" 'operation - (getdatabase constructor 'operation)) - (format t "~a: ~%" 'constructormodemap) - (pprint (getdatabase constructor 'constructormodemap)) - (format t "~&~a: ~%" 'constructorcategory) - (pprint (getdatabase constructor 'constructorcategory)) - (format t "~&~a: ~%" 'operationalist) - (pprint (getdatabase constructor 'operationalist)) - (format t "~&~a: ~%" 'modemaps) - (pprint (getdatabase constructor 'modemaps)) - (format t "~a: ~a~%" 'hascategory - (getdatabase constructor 'hascategory)) - (format t "~a: ~a~%" 'object - (getdatabase constructor 'object)) - (format t "~a: ~a~%" 'niladic - (getdatabase constructor 'niladic)) - (format t "~a: ~a~%" 'abbreviation - (getdatabase constructor 'abbreviation)) - (format t "~a: ~a~%" 'constructor? - (getdatabase constructor 'constructor?)) - (format t "~a: ~a~%" 'constructor - (getdatabase constructor 'constructor)) - (format t "~a: ~a~%" 'defaultdomain - (getdatabase constructor 'defaultdomain)) - (format t "~a: ~a~%" 'ancestors - (getdatabase constructor 'ancestors)) - (format t "~a: ~a~%" 'sourcefile - (getdatabase constructor 'sourcefile)) - (format t "~a: ~a~%" 'constructorform - (getdatabase constructor 'constructorform)) - (format t "~a: ~a~%" 'constructorargs - (getdatabase constructor 'constructorargs)) - (format t "~a: ~a~%" 'attributes - (getdatabase constructor 'attributes)) - (format t "~a: ~%" 'predicates) - (pprint (getdatabase constructor 'predicates)) - (format t "~a: ~a~%" 'documentation - (getdatabase constructor 'documentation)) - (format t "~a: ~a~%" 'parents - (getdatabase constructor 'parents))) - -(defun setdatabase (constructor key value) - (let (struct) - (when (symbolp constructor) - (unless (setq struct (get constructor 'database)) - (setq struct (make-database)) - (setf (get constructor 'database) struct)) - (case key - (abbreviation - (setf (database-abbreviation struct) value) - (when (symbolp value) - (setf (get value 'abbreviationfor) constructor))) - (constructorkind - (setf (database-constructorkind struct) value)))))) - -(defun deldatabase (constructor key) - (when (symbolp constructor) - (case key - (abbreviation - (setf (get constructor 'abbreviationfor) nil))))) - -(defun getdatabase (constructor key) - (declare (special *miss*)) - (when (eq *miss* t) (format t "getdatabase call: ~20a ~a~%" constructor key)) - (let (data table stream ignore struct) - (declare (ignore ignore)) - (when (or (symbolp constructor) - (and (eq key 'hascategory) (pairp constructor))) - (case key -; note that abbreviation, constructorkind and cosig are heavy hitters -; thus they occur first in the list of things to check - (abbreviation - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-abbreviation struct)))) - (constructorkind - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-constructorkind struct)))) - (cosig - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-cosig struct)))) - (operation - (setq stream *operation-stream*) - (setq data (gethash constructor *operation-hash*))) - (constructormodemap - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-constructormodemap struct)))) - (constructorcategory - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-constructorcategory struct)) - (when (null data) ;domain or package then subfield of constructormodemap - (setq data (cadar (getdatabase constructor 'constructormodemap)))))) - (operationalist - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-operationalist struct)))) - (modemaps - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-modemaps struct)))) - (hascategory - (setq table *hasCategory-hash*) - (setq stream *category-stream*) - (setq data (gethash constructor table))) - (object - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-object struct)))) - (asharp? - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-object struct)))) - (niladic - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-niladic struct)))) - (constructor? - (when (setq struct (get constructor 'database)) - (setq data (when (database-operationalist struct) t)))) - (superdomain ; only 2 superdomains in the world - (case constructor - (|NonNegativeInteger| - (setq data '((|Integer|) (IF (< |#1| 0) |false| |true|)))) - (|PositiveInteger| - (setq data '((|NonNegativeInteger|) (< 0 |#1|)))))) - (constructor - (when (setq data (get constructor 'abbreviationfor)))) - (defaultdomain - (setq data (cadr (assoc constructor *defaultdomain-list*)))) - (ancestors - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-ancestors struct)))) - (sourcefile - (setq stream *browse-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-sourcefile struct)))) - (constructorform - (setq stream *browse-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-constructorform struct)))) - (constructorargs - (setq data (cdr (getdatabase constructor 'constructorform)))) - (attributes - (setq stream *browse-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-attributes struct)))) - (predicates - (setq stream *browse-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-predicates struct)))) - (documentation - (setq stream *browse-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-documentation struct)))) - (parents - (setq stream *browse-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-parents struct)))) - (users - (setq stream *browse-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-users struct)))) - (dependents - (setq stream *browse-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-dependents struct)))) - (otherwise (warn "~%(GETDATABASE ~a ~a) failed~%" constructor key))) - (when (numberp data) ;fetch the real data - (when *miss* (format t "getdatabase miss: ~20a ~a~%" key constructor)) - (file-position stream data) - (setq data (unsqueeze (read stream))) - (case key ; cache the result of the database read - (operation (setf (gethash constructor *operation-hash*) data)) - (hascategory (setf (gethash constructor *hascategory-hash*) data)) - (constructorkind (setf (database-constructorkind struct) data)) - (cosig (setf (database-cosig struct) data)) - (constructormodemap (setf (database-constructormodemap struct) data)) - (constructorcategory (setf (database-constructorcategory struct) data)) - (operationalist (setf (database-operationalist struct) data)) - (modemaps (setf (database-modemaps struct) data)) - (object (setf (database-object struct) data)) - (niladic (setf (database-niladic struct) data)) - (abbreviation (setf (database-abbreviation struct) data)) - (constructor (setf (database-constructor struct) data)) - (ancestors (setf (database-ancestors struct) data)) - (constructorform (setf (database-constructorform struct) data)) - (attributes (setf (database-attributes struct) data)) - (predicates (setf (database-predicates struct) data)) - (documentation (setf (database-documentation struct) data)) - (parents (setf (database-parents struct) data)) - (users (setf (database-users struct) data)) - (dependents (setf (database-dependents struct) data)) - (sourcefile (setf (database-sourcefile struct) data)))) - (case key ; fixup the special cases - (sourcefile - (when (and data (string= (directory-namestring data) "") - (string= (pathname-type data) "spad")) - (setq data - (concatenate 'string (|systemRootDirectory|) "/../../src/algebra/" data)))) - (asharp? ; is this asharp code? - (if (consp data) - (setq data (cdr data)) - (setq data nil))) - (object ; fix up system object pathname - (if (consp data) - (setq data - (if (string= (directory-namestring (car data)) "") - (concatenate 'string (|systemRootDirectory|) "/algebra/" (car data) ".o") - (car data))) - (when (and data (string= (directory-namestring data) "")) - (setq data (concatenate 'string (|systemRootDirectory|) "/algebra/" data ".o"))))))) - data)) - -; )library top level command -- soon to be obsolete - -(defun |with| (args) - (|library| args)) - -;; Current directory -;; Contributed by Juergen Weiss. -#+:cmu -(defun get-current-directory () - (namestring (extensions::default-directory))) - -#+(or :akcl :gcl) -(defun get-current-directory () - (namestring (truename ""))) - - -; )library top level command - -(defun |library| (args) - (declare (special |$options|)) - (declare (special |$newConlist|)) - (setq original-directory (get-current-directory)) - (setq |$newConlist| nil) - (localdatabase args |$options|) -#+:CCL - (dolist (a args) (check-module-exists a)) - (|extendLocalLibdb| |$newConlist|) - (system::chdir original-directory) - (tersyscommand)) - -;; check-module-exists looks to see if a module exists in one of the current -;; libraries and, if not, compiles it. If the output-library exists but has not -;; been opened then it opens it first. -#+:CCL -(defun check-module-exists (module) - (prog (|$options| mdate) - (if (and (not output-library) (filep (or |$outputLibraryName| "user.lib"))) - (seq (setq |$outputLibraryName| - (if |$outputLibraryName| (truename |$outputLibraryName|) - (make-pathname :directory (get-current-directory) - :name "user.lib"))) - (|openOutputLibrary| |$outputLibraryName|))) - (setq mdate (modulep module)) - (setq |$options| '((|nolibrary| nil) (|quiet| nil))) - (|sayMSG| (format nil " Checking for module ~s." (namestring module))) - (let* ((fn (concatenate 'string (namestring module) ".lsp")) - (fdate (filedate fn)) ) - (if (and fdate (or (null mdate) (datelessp mdate fdate))) - (|compileAsharpLispCmd| (list fn)) - (let* ((fn (concatenate 'string (namestring module) ".NRLIB")) - (fdate (filedate fn)) ) - (if (and fdate (or (null mdate) (datelessp mdate fdate))) - (|compileSpadLispCmd| (list fn)))))))) - -; localdatabase tries to find files in the order of: -; NRLIB/index.KAF -; .asy -; .ao, then asharp to .asy - -(defun localdatabase (filelist options &optional (make-database? nil)) - "read a local filename and update the hash tables" - (labels ( - (processOptions (options) - (let (only dir noexpose) - (when (setq only (assoc '|only| options)) - (setq options (lisp::delete only options :test #'equal)) - (setq only (cdr only))) - (when (setq dir (assoc '|dir| options)) - (setq options (lisp::delete dir options :test #'equal)) - (setq dir (second dir)) - (when (null dir) - (|sayKeyedMsg| 'S2IU0002 nil) )) - (when (setq noexpose (assoc '|noexpose| options)) - (setq options (lisp::delete noexpose options :test #'equal)) - (setq noexpose 't) ) - (when options - (format t " Ignoring unknown )library option: ~a~%" options)) - (values only dir noexpose))) - (processDir (dirarg thisdir) - (let (allfiles skipasos) - (system:chdir (string dirarg)) - (setq allfiles (directory "*")) - (system:chdir thisdir) - (values - (mapcan #'(lambda (f) - (when (string-equal (pathname-type f) "NRLIB") - (list (concatenate 'string (namestring f) "/" - *index-filename*)))) allfiles) - (mapcan #'(lambda (f) - (when (string= (pathname-type f) "asy") - (push (pathname-name f) skipasos) - (list (namestring f)))) allfiles) - (mapcan #'(lambda (f) - (when (and (string= (pathname-type f) "ao") - (not (member (pathname-name f) skipasos :test #'string=))) - (list (namestring f)))) - allfiles) - ;; At the moment we will only look for user.lib: others are taken care - ;; of by localasy and localnrlib. -#+:CCL - (mapcan #'(lambda (f) - (when (and (string= (pathname-type f) "lib") (string= (pathname-name f) "user")) - (list (namestring f)))) - allfiles) -#-:CCL nil - )))) - (let (thisdir nrlibs asos asys libs object only dir key - (|$forceDatabaseUpdate| t) noexpose) - (declare (special |$forceDatabaseUpdate|)) - (setq thisdir (namestring (truename "."))) - (setq noexpose nil) - (multiple-value-setq (only dir noexpose) (processOptions options)) - ;don't force exposure during database build - (if make-database? (setq noexpose t)) - (when dir (multiple-value-setq (nrlibs asys asos libs) (processDir dir thisdir))) - (dolist (file filelist) - (let ((filename (pathname-name file)) - (namedir (directory-namestring file))) - (unless namedir (setq thisdir (concatenate 'string thisdir "/"))) - (cond - ((setq file (probe-file - (concatenate 'string namedir filename ".NRLIB/" - *index-filename*))) - (push (namestring file) nrlibs)) - ((setq file (probe-file - (concatenate 'string namedir filename ".asy"))) - (push (namestring file) asys)) - ((setq file (probe-file - (concatenate 'string namedir filename ".ao"))) - (push (namestring file) asos)) - ('else (format t " )library cannot find the file ~a.~%" filename))))) -#+:CCL - (dolist (file libs) (|addInputLibrary| (truename file))) - (dolist (file (nreverse nrlibs)) - (setq key (pathname-name (first (last (pathname-directory file))))) - (setq object (concatenate 'string (directory-namestring file) "code")) - (localnrlib key file object make-database? noexpose)) - (dolist (file (nreverse asys)) - (setq object - (concatenate 'string (directory-namestring file) (pathname-name file))) - (localasy (|astran| file) object only make-database? noexpose)) - (dolist (file (nreverse asos)) - (setq object - (concatenate 'string (directory-namestring file) (pathname-name file))) - (asharp file) - (setq file (|astran| (concatenate 'string (pathname-name file) ".asy"))) - (localasy file object only make-database? noexpose)) - (HCLEAR |$ConstructorCache|)))) - -(defun localasy (asy object only make-database? noexpose) - "given an alist from the asyfile and the objectfile update the database" - (labels ( - (fetchdata (alist index) - (cdr (assoc index alist :test #'string=)))) - (let (cname kind key alist (systemdir? nil) oldmaps asharp-name dbstruct abbrev) -#+:CCL - ;; Open the library - (let (lib) - (if (filep (setq lib (make-pathname :name object :type "lib")) ) - (setq input-libraries (cons (open-library (truename lib)) input-libraries)))) - (set-file-getter object) ; sets the autoload property for G-object - (dolist (domain asy) - (setq key (first domain)) - (setq alist (rest domain)) - (setq asharp-name - (foam::axiomxl-global-name (pathname-name object) key - (lassoc '|typeCode| alist))) - (if (< (length alist) 4) ;we have a naked function object - (let ((opname key) - (modemap (car (LASSOC '|modemaps| alist))) ) - (setq oldmaps (getdatabase opname 'operation)) - (setf (gethash opname *operation-hash*) - (adjoin (subst asharp-name opname (cdr modemap)) - oldmaps :test #'equal)) - (asharpMkAutoloadFunction object asharp-name)) - (when (if (null only) (not (eq key '%%)) (member key only)) - (setq *allOperations* nil) ; force this to recompute - (setq oldmaps (getdatabase key 'modemaps)) - (setq dbstruct (make-database)) - (setf (get key 'database) dbstruct) - (setq *allconstructors* (adjoin key *allconstructors*)) - (setf (database-constructorform dbstruct) - (fetchdata alist "constructorForm")) - (setf (database-constructorkind dbstruct) - (fetchdata alist "constructorKind")) - (setf (database-constructormodemap dbstruct) - (fetchdata alist "constructorModemap")) - (unless (setf (database-abbreviation dbstruct) - (fetchdata alist "abbreviation")) - (setf (database-abbreviation dbstruct) key)) ; default - (setq abbrev (database-abbreviation dbstruct)) - (setf (get abbrev 'abbreviationfor) key) - (setf (database-constructorcategory dbstruct) - (fetchdata alist "constructorCategory")) - (setf (database-attributes dbstruct) - (fetchdata alist "attributes")) - (setf (database-sourcefile dbstruct) - (fetchdata alist "sourceFile")) - (setf (database-operationalist dbstruct) - (fetchdata alist "operationAlist")) - (setf (database-modemaps dbstruct) - (fetchdata alist "modemaps")) - (setf (database-documentation dbstruct) - (fetchdata alist "documentation")) - (setf (database-predicates dbstruct) - (fetchdata alist "predicates")) - (setf (database-niladic dbstruct) - (fetchdata alist "NILADIC")) - (addoperations key oldmaps) - (setq cname (|opOf| (database-constructorform dbstruct))) - (setq kind (database-constructorkind dbstruct)) - (if (null noexpose) (|setExposeAddConstr| (cons cname nil))) - (unless make-database? - (|updateDatabase| key cname systemdir?) ;makes many hashtables??? - (|installConstructor| cname kind) - ;; following can break category database build - (if (eq kind '|category|) - (setf (database-ancestors dbstruct) - (fetchdata alist "ancestors"))) - (if (eq kind '|domain|) - (dolist (pair (cdr (assoc "ancestors" alist :test #'string=))) - (setf (gethash (cons cname (caar pair)) *hascategory-hash*) - (cdr pair)))) - (if |$InteractiveMode| (setq |$CategoryFrame| |$EmptyEnvironment|))) - (setf (database-cosig dbstruct) - (cons nil (mapcar #'|categoryForm?| - (cddar (database-constructormodemap dbstruct))))) - (setf (database-object dbstruct) (cons object asharp-name)) - (if (eq kind '|category|) - (asharpMkAutoLoadCategory object cname asharp-name - (database-cosig dbstruct)) - (asharpMkAutoLoadFunctor object cname asharp-name - (database-cosig dbstruct))) - (|sayKeyedMsg| 'S2IU0001 (list cname object)))))))) - -(defun localnrlib (key nrlib object make-database? noexpose) - "given a string pathname of an index.KAF and the object update the database" - (labels ( - (fetchdata (alist in index) - (let (pos) - (setq pos (third (assoc index alist :test #'string=))) - (when pos - (file-position in pos) - (read in))))) - (let (alist kind (systemdir? nil) pos constructorform oldmaps abbrev dbstruct) - (with-open-file (in nrlib) - (file-position in (read in)) - (setq alist (read in)) - (setq pos (third (assoc "constructorForm" alist :test #'string=))) - (file-position in pos) - (setq constructorform (read in)) - (setq key (car constructorform)) - (setq oldmaps (getdatabase key 'modemaps)) - (setq dbstruct (make-database)) - (setq *allconstructors* (adjoin key *allconstructors*)) - (setf (get key 'database) dbstruct) ; store the struct, side-effect it... - (setf (database-constructorform dbstruct) constructorform) - (setq *allOperations* nil) ; force this to recompute - (setf (database-object dbstruct) object) - (setq abbrev - (intern (pathname-name (first (last (pathname-directory object)))))) - (setf (database-abbreviation dbstruct) abbrev) - (setf (get abbrev 'abbreviationfor) key) - (setf (database-operationalist dbstruct) nil) - (setf (database-operationalist dbstruct) - (fetchdata alist in "operationAlist")) - (setf (database-constructormodemap dbstruct) - (fetchdata alist in "constructorModemap")) - (setf (database-modemaps dbstruct) (fetchdata alist in "modemaps")) - (setf (database-sourcefile dbstruct) (fetchdata alist in "sourceFile")) - (when make-database? - (setf (database-sourcefile dbstruct) - (file-namestring (database-sourcefile dbstruct)))) - (setf (database-constructorkind dbstruct) - (setq kind (fetchdata alist in "constructorKind"))) - (setf (database-constructorcategory dbstruct) - (fetchdata alist in "constructorCategory")) - (setf (database-documentation dbstruct) - (fetchdata alist in "documentation")) - (setf (database-attributes dbstruct) - (fetchdata alist in "attributes")) - (setf (database-predicates dbstruct) - (fetchdata alist in "predicates")) - (setf (database-niladic dbstruct) - (when (fetchdata alist in "NILADIC") t)) - (addoperations key oldmaps) - (unless make-database? - (if (eq kind '|category|) - (setf (database-ancestors dbstruct) - (SUBLISLIS |$FormalMapVariableList| (cdr constructorform) (fetchdata alist in "ancestors")))) - (|updateDatabase| key key systemdir?) ;makes many hashtables??? - (|installConstructor| key kind) ;used to be key cname ... - (|updateCategoryTable| key kind) - (if |$InteractiveMode| (setq |$CategoryFrame| |$EmptyEnvironment|))) - (setf (database-cosig dbstruct) - (cons nil (mapcar #'|categoryForm?| - (cddar (database-constructormodemap dbstruct))))) - (remprop key 'loaded) - (if (null noexpose) (|setExposeAddConstr| (cons key nil))) - #-:CCL - (setf (symbol-function key) ; sets the autoload property for cname - #'(lambda (&rest args) - (unless (get key 'loaded) - (|startTimingProcess| '|load|) - (|loadLibNoUpdate| key key object)) ; used to be cname key - (apply key args))) - #+:CCL - (let (lib) - (if (filep (setq lib (make-pathname :name object :type "lib")) ) - (setq input-libraries (cons (open-library (truename lib)) input-libraries))) - (|unloadOneConstructor| (get abbrev 'abbreviationfor) abbrev) ) - (|sayKeyedMsg| 'S2IU0001 (list key object)))))) - - -; making new databases consists of: -; 1) reset all of the system hash tables -; *) set up Union, Record and Mapping -; 2) map )library across all of the system files (fills the databases) -; 3) loading some normally autoloaded files -; 4) making some database entries that are computed (like ancestors) -; 5) writing out the databases -; 6) write out 'warm' data to be loaded into the image at build time -; note that this process should be done in a clean image -; followed by a rebuild of the system image to include -; the new index pointers (e.g. *interp-stream-stamp*) -; the system will work without a rebuild but it needs to -; re-read the databases on startup. rebuilding the system -; will cache the information into the image and the databases -; are opened but not read, saving considerable startup time. -; also note that the order the databases are written out is -; critical. interp.daase depends on prior computations and has -; to be written out last. - -(defun make-databases (ext dirlist) - (labels ( - ;; these are types which have no library object associated with them. - ;; we store some constructed data to make them perform like library - ;; objects, the *operationalist-hash* key entry is used by allConstructors - (withSpecialConstructors () - ; note: if item is not in *operationalist-hash* it will not be written - ; Category - (setf (get '|Category| 'database) - (make-database :operationalist nil :niladic t)) - (push '|Category| *allconstructors*) - ; UNION - (setf (get '|Union| 'database) - (make-database :operationalist nil :constructorkind '|domain|)) - (push '|Union| *allconstructors*) - ; RECORD - (setf (get '|Record| 'database) - (make-database :operationalist nil :constructorkind '|domain|)) - (push '|Record| *allconstructors*) - ; MAPPING - (setf (get '|Mapping| 'database) - (make-database :operationalist nil :constructorkind '|domain|)) - (push '|Mapping| *allconstructors*) - ; ENUMERATION - (setf (get '|Enumeration| 'database) - (make-database :operationalist nil :constructorkind '|domain|)) - (push '|Enumeration| *allconstructors*) - ) - (final-name (root) - (format nil "~a.daase~a" root ext)) - ) - (let (d) - (declare (special |$constructorList|)) - (do-symbols (symbol) - (when (get symbol 'database) - (setf (get symbol 'database) nil))) - (setq *hascategory-hash* (make-hash-table :test #'equal)) - (setq *operation-hash* (make-hash-table)) - (setq *allconstructors* nil) - (setq *compressvector* nil) - (withSpecialConstructors) - (localdatabase nil - (list (list '|dir| (namestring (truename "./")) )) - 'make-database) - (dolist (dir dirlist) - (localdatabase nil - (list (list '|dir| - (namestring (probe-file - (format nil "./~a" - dir))))) - 'make-database)) -#+:AKCL (|mkTopicHashTable|) - (setq |$constructorList| nil) ;; affects buildLibdb - (|buildLibdb|) - (|dbSplitLibdb|) -; (|dbAugmentConstructorDataTable|) - (|mkUsersHashTable|) - (|saveUsersHashTable|) - (|mkDependentsHashTable|) - (|saveDependentsHashTable|) -; (|buildGloss|) - (write-compress) - (write-browsedb) - (write-operationdb) - ; note: genCategoryTable creates a new *hascategory-hash* table - ; this smashes the existing table and regenerates it. - ; write-categorydb does getdatabase calls to write the new information - (write-categorydb) - (dolist (con (|allConstructors|)) - (let (dbstruct) - (when (setq dbstruct (get con 'database)) - (setf (database-cosig dbstruct) - (cons nil (mapcar #'|categoryForm?| - (cddar (database-constructormodemap dbstruct))))) - (when (and (|categoryForm?| con) - (= (length (setq d (|domainsOf| (list con) NIL NIL))) 1)) - (setq d (caar d)) - (when (= (length d) (length (|getConstructorForm| con))) - (format t " ~a has a default domain of ~a~%" con (car d)) - (setf (database-defaultdomain dbstruct) (car d))))))) - ; note: genCategoryTable creates *ancestors-hash*. write-interpdb - ; does gethash calls into it rather than doing a getdatabase call. - (write-interpdb) -#+:AKCL (write-warmdata) - (create-initializers) - (when (probe-file (final-name "compress")) - (delete-file (final-name "compress"))) - (rename-file "compress.build" (final-name "compress")) - (when (probe-file (final-name "interp")) - (delete-file (final-name "interp"))) - (rename-file "interp.build" (final-name "interp")) - (when (probe-file (final-name "operation")) - (delete-file (final-name "operation"))) - (rename-file "operation.build" (final-name "operation")) - (when (probe-file (final-name "browse")) - (delete-file (final-name "browse"))) - (rename-file "browse.build" - (final-name "browse")) - (when (probe-file (final-name "category")) - (delete-file (final-name "category"))) - (rename-file "category.build" - (final-name "category"))))) - -(defun DaaseName (name erase?) - (let (daase filename) - (if (setq daase (|systemAlgebraDirectory|)) - (progn - (setq filename (concatenate 'string daase name)) - (format t " Using local database ~a.." filename)) - (setq filename (concatenate 'string - (|systemRootDirectory|) - "/algebra/" - name))) - (when erase? (system::system (concatenate 'string "rm -f " filename))) - filename)) - -;; rewrite this so it works in mnt -;;(defun DaaseName (name erase?) -;; (let (daase filename) -;; (declare (special $spadroot)) -;; (if (setq daase (|getEnv| "DAASE")) -;; (progn -;; (setq filename (concatenate 'string daase "/algebra/" name)) -;; (format t " Using local database ~a.." filename)) -;; (setq filename (concatenate 'string $spadroot "/algebra/" name))) -;; (when erase? (system::system (concatenate 'string "rm -f " filename))) -;; filename)) - -@ -\subsection{compress.daase} -The compress database is special. It contains a list of symbols. -The character string name of a symbol in the other databases is -represented by a negative number. To get the real symbol back you -take the absolute value of the number and use it as a byte index -into the compress database. In this way long symbol names become -short negative numbers. - -<<*>>= - -(defun compressOpen () - (let (lst stamp pos) - (setq *compress-stream* - (open (DaaseName "compress.daase" nil) :direction :input)) - (setq stamp (read *compress-stream*)) - (unless (equal stamp *compress-stream-stamp*) - (format t " Re-reading compress.daase") - (setq *compress-stream-stamp* stamp) - (setq pos (car stamp)) - (file-position *compress-stream* pos) - (setq lst (read *compress-stream*)) - (setq *compressVectorLength* (car lst)) - (setq *compressvector* - (make-array (car lst) :initial-contents (cdr lst)))))) - -(defun write-compress () - (let (compresslist masterpos out) - (close *compress-stream*) - (setq out (open "compress.build" :direction :output)) - (princ " " out) - (finish-output out) - (setq masterpos (file-position out)) - (setq compresslist - (append (|allConstructors|) (|allOperations|) *attributes*)) - (push "algebra" compresslist) - (push "failed" compresslist) - (push 'signature compresslist) - (push '|ofType| compresslist) - (push '|Join| compresslist) - (push 'and compresslist) - (push '|nobranch| compresslist) - (push 'category compresslist) - (push '|category| compresslist) - (push '|domain| compresslist) - (push '|package| compresslist) - (push 'attribute compresslist) - (push '|isDomain| compresslist) - (push '|ofCategory| compresslist) - (push '|Union| compresslist) - (push '|Record| compresslist) - (push '|Mapping| compresslist) - (push '|Enumeration| compresslist) - (setq *compressVectorLength* (length compresslist)) - (setq *compressvector* - (make-array *compressVectorLength* :initial-contents compresslist)) - (print (cons (length compresslist) compresslist) out) - (finish-output out) - (file-position out 0) - (print (cons masterpos (get-universal-time)) out) - (finish-output out) - (close out))) - -@ -\subsubsection{interp.daase} -\begin{verbatim} - format of an entry in interp.daase: - (constructor-name - operationalist - constructormodemap - modemaps -- this should not be needed. eliminate it. - object -- the name of the object file to load for this con. - constructorcategory -- note that this info is the cadar of the - constructormodemap for domains and packages so it is stored - as NIL for them. it is valid for categories. - niladic -- t or nil directly - unused - cosig -- kept directly - constructorkind -- kept directly - defaultdomain -- a short list, for %i - ancestors -- used to compute new category updates - ) -\end{verbatim} - -Here I'll try to outline the interp database write procedure - -\begin{verbatim} -(defun write-interpdb () - "build interp.daase from hash tables" - (declare (special *ancestors-hash*)) - (let (opalistpos modemapspos cmodemappos master masterpos obj *print-pretty* - concategory categorypos kind niladic cosig abbrev defaultdomain - ancestors ancestorspos out) - (declare (special *print-pretty*)) - (print "building interp.daase") - -; 1. We open the file we're going to create - - (setq out (open "interp.build" :direction :output)) - -; 2. We reserve some space at the top of the file for the key-time pair -; We will overwrite these spaces just before we close the file. - - (princ " " out) - -; 3. Make sure we write it out - (finish-output out) - -; 4. For every constructor in the system we write the parts: - - (dolist (constructor (|allConstructors|)) - (let (struct) - -; 4a. Each constructor has a property list. A property list is a list -; of (key . value) pairs. The property we want is called 'database -; so there is a ('database . something) in the property list - - (setq struct (get constructor 'database)) - -; 5 We write the "operationsalist" -; 5a. We remember the current file position before we write -; We need this information so we can seek to this position on read - - (setq opalistpos (file-position out)) - -; 5b. We get the "operationalist", compress it, and write it out - - (print (squeeze (database-operationalist struct)) out) - -; 5c. We make sure it was written - - (finish-output out) - -; 6 We write the "constructormodemap" -; 6a. We remember the current file position before we write - - (setq cmodemappos (file-position out)) - -; 6b. We get the "constructormodemap", compress it, and write it out - - (print (squeeze (database-constructormodemap struct)) out) - -; 6c. We make sure it was written - - (finish-output out) - -; 7. We write the "modemaps" -; 7a. We remember the current file position before we write - - (setq modemapspos (file-position out)) - -; 7b. We get the "modemaps", compress it, and write it out - - (print (squeeze (database-modemaps struct)) out) - -; 7c. We make sure it was written - - (finish-output out) - -; 8. We remember source file pathnames in the obj variable - - (if (consp (database-object struct)) ; if asharp code ... - (setq obj - (cons (pathname-name (car (database-object struct))) - (cdr (database-object struct)))) - (setq obj - (pathname-name - (first (last (pathname-directory (database-object struct))))))) - -; 9. We write the "constructorcategory", if it is a category, else nil -; 9a. Get the constructorcategory and compress it - - (setq concategory (squeeze (database-constructorcategory struct))) - -; 9b. If we have any data we write it out, else we don't write it -; Note that if there is no data then the byte index for the -; constructorcatagory will not be a number but will be nil. - - (if concategory ; if category then write data else write nil - (progn - (setq categorypos (file-position out)) - (print concategory out) - (finish-output out)) - (setq categorypos nil)) - -; 10. We get a set of properties which are kept as "immediate" data -; This means that the key table will hold this data directly -; rather than as a byte index into the file. -; 10a. niladic data - - (setq niladic (database-niladic struct)) - -; 10b. abbreviation data (e.g. POLY for polynomial) - - (setq abbrev (database-abbreviation struct)) - -; 10c. cosig data - - (setq cosig (database-cosig struct)) - -; 10d. kind data - - (setq kind (database-constructorkind struct)) - -; 10e. defaultdomain data - - (setq defaultdomain (database-defaultdomain struct)) - -; 11. The ancestor data might exist. If it does we fetch it, -; compress it, and write it out. If it does not we place -; and immediate value of nil in the key-value table - - (setq ancestors (squeeze (gethash constructor *ancestors-hash*))) ;cattable.boot - (if ancestors - (progn - (setq ancestorspos (file-position out)) - (print ancestors out) - (finish-output out)) - (setq ancestorspos nil)) - -; 12. "master" is an alist. Each element of the alist has the name of -; the constructor and all of the above attributes. When the loop -; finishes we will have constructed all of the data for the key-value -; table - - (push (list constructor opalistpos cmodemappos modemapspos - obj categorypos niladic abbrev cosig kind defaultdomain - ancestorspos) master))) - -; 13. The loop is done, we make sure all of the data is written - - (finish-output out) - -; 14. We remember where the key-value table will be written in the file - - (setq masterpos (file-position out)) - -; 15. We compress and print the key-value table - - (print (mapcar #'squeeze master) out) - -; 16. We make sure we write the table - - (finish-output out) - -; 17. We go to the top of the file - - (file-position out 0) - -; 18. We write out the (master-byte-position . universal-time) pair -; Note that if the universal-time value matches the value of -; *interp-stream-stamp* then there is no reason to read the -; interp database because all of the data is already cached in -; the image. This happens if you build a database and immediatly -; save the image. The saved image already has the data since we -; just wrote it out. If the *interp-stream-stamp* and the database -; time stamp differ we "reread" the database on startup. Actually -; we just open the database and fetch as needed. You can see fetches -; by setting the *miss* variable non-nil. - - (print (cons masterpos (get-universal-time)) out) - -; 19. We make sure we write it. - - (finish-output out) - -; 20 And we are done - - (close out))) -\end{verbatim} - -<<*>>= -(defun write-interpdb () - "build interp.daase from hash tables" - (declare (special *ancestors-hash*)) - (let (opalistpos modemapspos cmodemappos master masterpos obj *print-pretty* - concategory categorypos kind niladic cosig abbrev defaultdomain - ancestors ancestorspos out) - (declare (special *print-pretty*)) - (print "building interp.daase") - (setq out (open "interp.build" :direction :output)) - (princ " " out) - (finish-output out) - (dolist (constructor (|allConstructors|)) - (let (struct) - (setq struct (get constructor 'database)) - (setq opalistpos (file-position out)) - (print (squeeze (database-operationalist struct)) out) - (finish-output out) - (setq cmodemappos (file-position out)) - (print (squeeze (database-constructormodemap struct)) out) - (finish-output out) - (setq modemapspos (file-position out)) - (print (squeeze (database-modemaps struct)) out) - (finish-output out) - (if (consp (database-object struct)) ; if asharp code ... - (setq obj - (cons (pathname-name (car (database-object struct))) - (cdr (database-object struct)))) - (setq obj - (pathname-name - (first (last (pathname-directory (database-object struct))))))) - (setq concategory (squeeze (database-constructorcategory struct))) - (if concategory ; if category then write data else write nil - (progn - (setq categorypos (file-position out)) - (print concategory out) - (finish-output out)) - (setq categorypos nil)) - (setq niladic (database-niladic struct)) - (setq abbrev (database-abbreviation struct)) - (setq cosig (database-cosig struct)) - (setq kind (database-constructorkind struct)) - (setq defaultdomain (database-defaultdomain struct)) - (setq ancestors (squeeze (gethash constructor *ancestors-hash*))) ;cattable.boot - (if ancestors - (progn - (setq ancestorspos (file-position out)) - (print ancestors out) - (finish-output out)) - (setq ancestorspos nil)) - (push (list constructor opalistpos cmodemappos modemapspos - obj categorypos niladic abbrev cosig kind defaultdomain - ancestorspos) master))) - (finish-output out) - (setq masterpos (file-position out)) - (print (mapcar #'squeeze master) out) - (finish-output out) - (file-position out 0) - (print (cons masterpos (get-universal-time)) out) - (finish-output out) - (close out))) - -@ -\subsubsection{browse.daase} -\begin{verbatim} - format of an entry in browse.daase: - ( constructorname - sourcefile - constructorform - documentation - attributes - predicates - ) -\end{verbatim} -This is essentially the same overall process as write-interpdb. - -We reserve some space for the (key-table-byte-position . timestamp) - -We loop across the list of constructors dumping the data and -remembering the byte positions in a key-value pair table. - -We dump the final key-value pair table, write the byte position and -time stamp at the top of the file and close the file. - -<<*>>= -(defun write-browsedb () - "make browse.daase from hash tables" - (let (master masterpos src formpos docpos attpos predpos *print-pretty* out) - (declare (special *print-pretty*)) - (print "building browse.daase") - (setq out (open "browse.build" :direction :output)) - (princ " " out) - (finish-output out) - (dolist (constructor (|allConstructors|)) - (let (struct) - (setq struct (get constructor 'database)) - ; sourcefile is small. store the string directly - (setq src (database-sourcefile struct)) - (setq formpos (file-position out)) - (print (squeeze (database-constructorform struct)) out) - (finish-output out) - (setq docpos (file-position out)) - (print (database-documentation struct) out) - (finish-output out) - (setq attpos (file-position out)) - (print (squeeze (database-attributes struct)) out) - (finish-output out) - (setq predpos (file-position out)) - (print (squeeze (database-predicates struct)) out) - (finish-output out) - (push (list constructor src formpos docpos attpos predpos) master))) - (finish-output out) - (setq masterpos (file-position out)) - (print (mapcar #'squeeze master) out) - (finish-output out) - (file-position out 0) - (print (cons masterpos (get-universal-time)) out) - (finish-output out) - (close out))) - -@ -\subsubsection{category.daase} -This is a single table of category hash table information, dumped in the -database format. -<<*>>= -(defun write-categorydb () - "make category.daase from scratch. contains the *hasCategory-hash* table" - (let (out master pos *print-pretty*) - (declare (special *print-pretty*)) - (print "building category.daase") - (|genCategoryTable|) - (setq out (open "category.build" :direction :output)) - (princ " " out) - (finish-output out) - (maphash #'(lambda (key value) - (if (or (null value) (eq value t)) - (setq pos value) - (progn - (setq pos (file-position out)) - (print (squeeze value) out) - (finish-output out))) - (push (list key pos) master)) - *hasCategory-hash*) - (setq pos (file-position out)) - (print (mapcar #'squeeze master) out) - (finish-output out) - (file-position out 0) - (print (cons pos (get-universal-time)) out) - (finish-output out) - (close out))) - -(defun unsqueeze (expr) - (cond ((atom expr) - (cond ((and (numberp expr) (<= expr 0)) - (svref *compressVector* (- expr))) - (t expr))) - (t (rplaca expr (unsqueeze (car expr))) - (rplacd expr (unsqueeze (cdr expr))) - expr))) - -(defun squeeze (expr) - (let (leaves pos (bound (length *compressvector*))) - (labels ( - (flat (expr) - (when (and (numberp expr) (< expr 0) (>= expr bound)) - (print expr) - (break "squeeze found a negative number")) - (if (atom expr) - (unless (or (null expr) - (and (symbolp expr) (char= (schar (symbol-name expr) 0) #\*))) - (setq leaves (adjoin expr leaves))) - (progn - (flat (car expr)) - (flat (cdr expr)))))) - (setq leaves nil) - (flat expr) - (dolist (leaf leaves) - (when (setq pos (position leaf *compressvector*)) - (nsubst (- pos) leaf expr))) - expr))) - -@ -\subsubsection{operation.daase} -This is a single table of operations hash table information, dumped in the -database format. -<<*>>= -(defun write-operationdb () - (let (pos master out) - (declare (special leaves)) - (setq out (open "operation.build" :direction :output)) - (princ " " out) - (finish-output out) - (maphash #'(lambda (key value) - (setq pos (file-position out)) - (print (squeeze value) out) - (finish-output out) - (push (cons key pos) master)) - *operation-hash*) - (finish-output out) - (setq pos (file-position out)) - (print (mapcar #'squeeze master) out) - (file-position out 0) - (print (cons pos (get-universal-time)) out) - (finish-output out) - (close out))) - -(defun write-warmdata () - "write out information to be loaded into the image at build time" - (declare (special |$topicHash|)) - (with-open-file (out "warm.data" :direction :output) - (format out "(in-package \"BOOT\")~%") - (format out "(setq |$topicHash| (make-hash-table))~%") - (maphash #'(lambda (k v) - (format out "(setf (gethash '|~a| |$topicHash|) ~a)~%" k v)) |$topicHash|))) - -(defun |allConstructors| () - (declare (special *allconstructors*)) - *allconstructors*) - -(defun |allOperations| () - (declare (special *allOperations*)) - (unless *allOperations* - (maphash #'(lambda (k v) (declare (ignore v)) (push k *allOperations*)) - *operation-hash*)) - *allOperations*) - -; the variable NOPfuncall is a funcall-able object that is a dummy -; initializer for libaxiom asharp domains. -(defvar NOPfuncall (cons 'identity nil)) - -(defun create-initializers () -;; since libaxiom is now built with -name=axiom following unnecessary -;; (dolist (con (|allConstructors|)) -;; (let ((sourcefile (getdatabase con 'sourcefile))) -;; (if sourcefile -;; (set (foam::axiomxl-file-init-name (pathname-name sourcefile)) -;; NOPfuncall)))) - (set (foam::axiomxl-file-init-name "axiom") NOPfuncall) -;; (set (foam::axiomxl-file-init-name "axclique") NOPfuncall) - (set (foam::axiomxl-file-init-name "filecliq") NOPfuncall) - (set (foam::axiomxl-file-init-name "attrib") NOPfuncall) -;; following needs to happen inside restart since $AXIOM may change - (let ((asharprootlib (strconc (|systemRootDirectory|) "/aldor/lib/"))) - (set-file-getter (strconc asharprootlib "runtime")) - (set-file-getter (strconc asharprootlib "lang")) - (set-file-getter (strconc asharprootlib "attrib")) - (set-file-getter (strconc asharprootlib "axlit")) - (set-file-getter (strconc asharprootlib "minimach")) - (set-file-getter (strconc asharprootlib "axextend")))) - - - -;--------------------------------------------------------------------- - -; how the magic works: -; when a )library is done on a new compiler file we set up multiple -; functions (refered to as autoloaders). there is an autoloader -; stored in the symbol-function of the G-filename (e.g. G-basic) -; (see set-file-getter function) -; and an autoloader stored in the symbol-function of every domain -; in the basic.as file ( asharpMkAutoloadFunctor ) -; When a domain is needed the autoloader for the domain is executed. -; this autoloader invokes file-getter-name to get the name of the -; file (eg basic) and evaluates the name. the FIRST time this is done -; for a file the file will be loaded by its autoloader, then it will -; return the file object. every other time the file is already -; loaded and the file object is returned directly. -; Once the file object is gotten getconstructor is called to get the -; domain. the FIRST time this is done for the domain the autoloader -; invokes the file object. every other time the domain already -; exists. -;(defvar *this-file* "no-file") - -(defmacro |CCall| (fun &rest args) - (let ((ccc (gensym)) (cfun (gensym)) (cenv (gensym))) - `(let ((,ccc ,fun)) - (let ((,cfun (|ClosFun| ,ccc)) - (,cenv (|ClosEnv| ,ccc))) - (funcall ,cfun ,@args ,cenv ))))) - -(defmacro |ClosFun| (x) `(car ,x)) -(defmacro |ClosEnv| (x) `(cdr ,x)) - -(defun file-runner (name) - (declare (special foam-user::|G-domainPrepare!|)) - (|CCall| foam-user::|G-domainPrepare!| (|CCall| name))) - -(defun getConstructor (file-fn asharp-name) - (|CCall| file-fn) -; (eval (cdr (assoc file-id (get name 'asharp-name) :test #'equal)))) - (eval asharp-name)) - -(defun getop (dom op type) - (declare (special foam-user::|G-domainGetExport!|)) - (|CCall| foam-user::|G-domainGetExport!| dom - (|hashString| (symbol-name op)) type)) - -; the asharp compiler will allow both constant domains and domains -; which are functions. localasy sets the autoload property so that -; the symbol-function contains a function that, when invoked with -; the correct number of args will return a domain. - -; this function is called if we are given a new compiler domain -; which is a function. the symbol-function of the domain is set -; to call the function with the correct number of arguments. - -(defun wrapDomArgs (obj type?) - (cond ((not type?) obj) - (t (|makeOldAxiomDispatchDomain| obj)))) - -;; CCL doesn't have closures, so we use an intermediate function in -;; asharpMkAutoLoadFunctor. -#+:CCL -(defun mkFunctorStub (func cosig cname) - (setf (symbol-function cname) - (if (vectorp (car func)) - `(lambda () ',func) ;; constant domain - `(lambda (&rest args2) - (apply ',(|ClosFun| func) - (nconc - (mapcar #'wrapDomArgs args2 ',(cdr cosig)) - (list ',(|ClosEnv| func)))))))) - -#+:CCL -(defun asharpMkAutoLoadFunctor (file cname asharp-name cosig) - (setf (symbol-function cname) - `(lambda (&rest args) - (mkFunctorStub - (getconstructor (eval (file-getter-name ',file)) ',asharp-name) - ',cosig ',cname) - (apply ',cname args)))) - -#-:CCL -(defun asharpMkAutoLoadFunctor (file cname asharp-name cosig) - (setf (symbol-function cname) - #'(lambda (&rest args) - (let ((func (getconstructor (eval (file-getter-name file)) asharp-name))) - (setf (symbol-function cname) - (if (vectorp (car func)) - #'(lambda () func) ;; constant domain - #'(lambda (&rest args) - (apply (|ClosFun| func) - (nconc - (mapcar #'wrapDomArgs args (cdr cosig)) - (list (|ClosEnv| func))))))) - (apply cname args))))) - -;; CCL doesn't have closures, so we use an intermediate function in -;; asharpMkAutoLoadCategory. -#+:CCL -(defun mkCategoryStub (func cosig packname) - (setf (symbol-function packname) - (if (vectorp (car func)) - `(lambda (self) ;; constant category - (|CCall| (elt ',(car func) 5) ',(cdr func) (wrapDomArgs self t))) - `(lambda (self &rest args) - (let ((precat - (apply (|ClosFun| ',func) - (nconc - (mapcar #'wrapDomArgs args ',(cdr cosig)) - (list (|ClosEnv| ',func)))))) - (|CCall| (elt (car precat) 5) (cdr precat) (wrapDomArgs self t))))) -)) - -#+:CCL -(defun asharpMkAutoLoadCategory (file cname asharp-name cosig) - (asharpMkAutoLoadFunctor file cname asharp-name cosig) - (let ((packname (INTERN (STRCONC cname "&")))) - (setf (symbol-function packname) - `(lambda (self &rest args) - (mkCategoryStub - (getconstructor (eval (file-getter-name ',file)) ',asharp-name) - ',cosig ',packname) - (apply ',packname self args))))) - -#-:CCL -(defun asharpMkAutoLoadCategory (file cname asharp-name cosig) - (asharpMkAutoLoadFunctor file cname asharp-name cosig) - (let ((packname (INTERN (STRCONC cname '"&")))) - (setf (symbol-function packname) - #'(lambda (self &rest args) - (let ((func (getconstructor (eval (file-getter-name file)) asharp-name))) - (setf (symbol-function packname) - (if (vectorp (car func)) - #'(lambda (self) - (|CCall| (elt (car func) 5) (cdr func) (wrapDomArgs self t))) ;; constant category - #'(lambda (self &rest args) - (let ((precat - (apply (|ClosFun| func) - (nconc - (mapcar #'wrapDomArgs args (cdr cosig)) - (list (|ClosEnv| func)))))) - (|CCall| (elt (car precat) 5) (cdr precat) (wrapDomArgs self t)))))) - (apply packname self args)))))) - -#+:CCL -(defun asharpMkAutoLoadFunction (file asharpname) - (set asharpname - (cons - `(lambda (&rest l) - (let ((args (butlast l)) - (func (getconstructor (eval (file-getter-name ',file)) ',asharpname))) - (apply (car func) (append args (list (cdr func)))))) - ()))) - -#-:CCL -(defun asharpMkAutoLoadFunction (file asharpname) - (set asharpname - (cons - #'(lambda (&rest l) - (let ((args (butlast l)) - (func (getconstructor (eval (file-getter-name file)) asharpname))) - (apply (car func) (append args (list (cdr func)))))) - ()))) - -; this function will return the internal name of the file object getter - -(defun file-getter-name (filename) - (foam::axiomxl-file-init-name (pathname-name filename))) - -;;need to initialize |G-filename| to a function which loads file -;; and then returns the new value of |G-filename| - -(defun set-file-getter (filename) - (let ((getter-name (file-getter-name filename))) - (set getter-name - (cons #'init-file-getter (cons getter-name filename))))) - -(defun init-file-getter (env) - (let ((getter-name (car env)) - (filename (cdr env))) -#-:CCL - (load filename) -#+:CCL - (load-module filename) - (|CCall| (eval getter-name)))) - -(defun set-lib-file-getter (filename cname) - (let ((getter-name (file-getter-name filename))) - (set getter-name - (cons #'init-lib-file-getter (cons getter-name cname))))) - -(defun init-lib-file-getter (env) - (let* ((getter-name (car env)) - (cname (cdr env)) - (filename (getdatabase cname 'object))) -#-:CCL - (load filename) -#+:CCL - (load-module (pathname-name filename)) - (|CCall| (eval getter-name)))) - -;; following 2 functions are called by file-exports and file-imports macros -(defun foam::process-import-entry (entry) - (let* ((asharpname (car entry)) - (stringname (cadr entry)) - (hcode (caddr entry)) - (libname (cadddr entry)) - (bootname (intern stringname 'boot))) - (declare (ignore libname)) - (if (and (eq hcode 'foam-user::|initializer|) (not (boundp asharpname))) - (error (format nil "AxiomXL file ~s is missing!" stringname))) - (unless (or (not (numberp hcode)) (zerop hcode) (boundp asharpname)) - (when (|constructor?| bootname) - (set asharpname - (if (getdatabase bootname 'niladic) - (|makeLazyOldAxiomDispatchDomain| (list bootname)) - (cons '|runOldAxiomFunctor| bootname)))) - (when (|attribute?| bootname) - (set asharpname (|makeLazyOldAxiomDispatchDomain| bootname)))))) - - - -;(defun foam::process-export-entry (entry) -; (let* ((asharpname (car entry)) -; (stringname (cadr entry)) -; (hcode (caddr entry)) -; (libname (cadddr entry)) -; (bootname (intern stringname 'boot))) -; (declare (ignore libname)) -; (when (numberp hcode) -; (setf (get bootname 'asharp-name) -; (cons (cons *this-file* asharpname) -; (get bootname 'asharp-name))) -; ))) - - - - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/debug.lisp b/src/interp/debug.lisp new file mode 100644 index 00000000..88896531 --- /dev/null +++ b/src/interp/debug.lisp @@ -0,0 +1,1215 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + + +;; A "resumable" break loop for use in trace etc. Unfortunately this +;; only works for CCL. We need to define a Common Lisp version. For +;; now the function is defined but does nothing. + + +;;; @(#)debug.lisp 2.5 90/02/15 10:27:33 + +; NAME: Debugging Package +; PURPOSE: Debugging hooks for Boot code + +(in-package "BOOT") +(use-package '("LISP" )) + +(DEFPARAMETER /COUNTLIST NIL) +(DEFPARAMETER /TIMERLIST NIL) +(DEFPARAMETER /TRACESIZE NIL "sets limit on size of object to be mathprinted") +(DEFVAR CURSTRM *TERMINAL-IO*) +(DEFVAR /TRACELETNAMES ()) +(DEFVAR /PRETTY () "controls pretty printing of trace output") +(SETANDFILEQ /ECHO NIL) ;;"prevents echo of SPAD or BOOT code with /c" +(MAKEPROP 'LISP '/TERMCHR '(#\ #\()) +(MAKEPROP 'LSP '/TERMCHR '(#\ #\()) +(MAKEPROP 'META '/TERMCHR '(#\: #\()) +(MAKEPROP 'INPUT '/TERMCHR '(#\: #\< #\ #\()) +(MAKEPROP 'SPAD '/TERMCHR '(#\: #\< #\ #\()) +(MAKEPROP 'BOOT '/TERMCHR '(#\: #\< #\ #\()) +(MAKEPROP 'INPUT '/XCAPE #\_) +(MAKEPROP 'BOOT '/XCAPE '#\_) +(MAKEPROP 'SPAD '/XCAPE '#\_) +(MAKEPROP 'META '/READFUN 'META\,RULE) +(MAKEPROP 'INPUT '/READFUN '|New,LEXPR,Interactive|) +(MAKEPROP 'INPUT '/TRAN '/TRANSPAD) +(MAKEPROP 'BOOT '/READFUN '|New,LEXPR1|) +(MAKEPROP 'BOOT '/TRAN '/TRANSNBOOT) +(MAKEPROP 'SPAD '/READFUN '|New,LEXPR|) +(MAKEPROP 'SPAD '/TRAN '/TRANSPAD) + +(defmacro |/C,LIB| (&rest L &aux optionlist /editfile + ($prettyprint 't) ($reportCompilation 't)) + (declare (special optionlist /editfile $prettyprint $reportComilation)) + `',(|compileConstructorLib| L (/COMP) NIL NIL)) + +(defmacro /C (&rest L) `',(/D-1 L (/COMP) NIL NIL)) + +(defmacro /CT (&rest L) `',(/D-1 L (/COMP) NIL 'T)) + +(defmacro /CTL (&rest L) `',(/D-1 L (/COMP) NIL 'TRACELET)) + +(defmacro /D (&rest L) `',(/D-1 L 'DEFINE NIL NIL)) + +(defmacro /EC (&rest L) `', (/D-1 L (/COMP) 'T NIL)) + +(defmacro /ECT (&rest L) `',(/D-1 L (/COMP) 'T 'T)) + +(defmacro /ECTL (&rest L) `',(/D-1 L (/COMP) 'T 'TRACELET)) + +(defmacro /E (&rest L) `',(/D-1 L NIL 'T NIL)) + +(defmacro /ED (&rest L) `',(/D-1 L 'DEFINE 'T NIL)) + +(defun heapelapsed () 0) + +(defun /COMP () (if (fboundp 'COMP) 'COMP 'COMP370)) + +(DEFUN /D-1 (L OP EFLG TFLG) + (CATCH 'FILENAM + (PROG (TO OPTIONL OPTIONS FNL INFILE OUTSTREAM FN ) + (declare (special fn infile outstream )) + (if (member '? L :test #'eq) + (RETURN (OBEY "EXEC SPADEDIT /C TELL"))) + (SETQ OPTIONL (/OPTIONS L)) + (SETQ FNL (TRUNCLIST L OPTIONL)) + (SETQ OPTIONS (OPTIONS2UC OPTIONL)) + (SETQ INFILE (/MKINFILENAM (/GETOPTION OPTIONS 'FROM))) + (SETQ TO (/GETOPTION OPTIONS 'TO)) + (if TO (SETQ TO (/MKOUTFILENAM (/GETOPTION OPTIONS 'TO) INFILE))) + (SETQ OUTSTREAM (if TO (DEFSTREAM TO 'OUTPUT) CUROUTSTREAM)) + (RETURN (mapcar #'(lambda (fn) + (/D-2 FN INFILE OUTSTREAM OP EFLG TFLG)) + (or fnl (list /fn))))))) + +(DEFUN |/D,2,LIB| (FN INFILE CUROUTSTREAM OP EDITFLAG TRACEFLAG) + (declare (special CUROUTSTREAM)) + "Called from compConLib1 (see LISPLIB BOOT) to bind CUROUTSTREAM." + (/D-2 FN INFILE CUROUTSTREAM OP EDITFLAG TRACEFLAG)) + +(defparameter $linenumber 0) + +(DEFUN /D-2 (FN INFILE OUTPUTSTREAM OP EDITFLAG TRACEFLAG) + (declare (special OUTPUTSTREAM)) + (PROG (FT oft SFN X EDINFILE FILE DEF KEY RECNO U W SOURCEFILES + ECHOMETA SINGLINEMODE XCAPE XTOKENREADER INPUTSTREAM SPADERRORSTREAM + ISID NBLNK COMMENTCHR $TOKSTACK (/SOURCEFILES |$sourceFiles|) + METAKEYLST DEFINITION_NAME (|$sourceFileTypes| '(|spad| |boot| |lisp| |lsp| |meta|)) + ($FUNCTION FN) $BOOT $NEWSPAD $LINESTACK $LINENUMBER STACK STACKX BACK OK + TRAPFLAG |$InteractiveMode| TOK COUNT ERRCOL COLUMN *QUERY CHR LINE + (*COMP370-APPLY* (if (eq op 'define) #'eval-defun #'compile-defun))) + (declare (special ECHOMETA SINGLINEMODE XCAPE XTOKENREADER INPUTSTREAM + SPADERRORSTREAM ISID NBLNK COMMENTCHR $TOKSTACK /SOURCEFILES + METAKEYLST DEFINITION_NAME |$sourceFileTypes| + $FUNCTION $BOOT $NEWSPAD $LINESTACK $LINENUMBER STACK STACKX BACK OK + TRAPFLAG |$InteractiveMode| TOK COUNT ERRCOL COLUMN *QUERY CHR LINE)) + (if (PAIRP FN) (SETQ FN (QCAR FN))) + (SETQ INFILE (OR INFILE (|getFunctionSourceFile| FN))) + ;; $FUNCTION is freely set in getFunctionSourceFile + (IF (PAIRP $FUNCTION) (SETQ $FUNCTION (QCAR $FUNCTION))) + (SETQ FN $FUNCTION) + (SETQ /FN $FUNCTION) + LOOP (SETQ SOURCEFILES + (cond ( INFILE + (SETQ /SOURCEFILES (CONS INFILE (REMOVE INFILE /SOURCEFILES))) + (LIST INFILE)) + ( /EDITFILE + (|insert| (|pathname| /EDITFILE) /SOURCEFILES)) + ( 't /SOURCEFILES))) + (SETQ RECNO + (dolist (file sourcefiles) + (SETQ INPUTSTREAM (DEFSTREAM FILE 'INPUT)) + + ;;?(REMFLAG S-SPADKEY 'KEY) ; hack !! + (SETQ FT (|pathnameType| FILE)) + (SETQ oft (|object2Identifier| (UPCASE FT))) + (SETQ XCAPE (OR (GET oft '/XCAPE) #\|)) + (SETQ COMMENTCHR (GET oft '/COMMENTCHR)) + (SETQ XTOKENREADER (OR (GET oft '/NXTTOK) 'METATOK)) + (SETQ DEFINITION_NAME FN) + (SETQ KEY + (STRCONC + (OR (AND (EQ oFT 'SPAD) "") + (AND (EQ oFT 'BOOT) "") + (GET oFT '/PREFIX) + "") + (PNAME FN))) + (SETQ SFN (GET oFT '/READFUN)) + (SETQ RECNO (/LOCATE FN KEY FILE 0)) + (SHUT INPUTSTREAM) + (cond ((NUMBERP RECNO) + (SETQ /SOURCEFILES (CONS FILE (REMOVE FILE /SOURCEFILES))) + (SETQ INFILE FILE) + (RETURN RECNO)))) ) + (if (NOT RECNO) + (if (SETQ INFILE (/MKINFILENAM '(NIL))) (GO LOOP) (UNWIND))) + (TERPRI) + (TERPRI) + (SETQ INFILE (|pathname| INFILE)) + (COND + ( EDITFLAG + ;;%% next form is used because $FINDFILE seems to screw up + ;;%% sometimes. The stream is opened and closed several times + ;;%% in case the filemode has changed during editing. + (SETQ EDINFILE (make-input-filename INFILE)) + (SETQ INPUTSTREAM (DEFSTREAM EDINFILE 'INPUT)) + (|sayBrightly| + (LIST " editing file" '|%b| (|namestring| EDINFILE) '|%d|)) + (OBEY + (STRCONC + (make-absolute-filename "/lib/SPADEDFN ") + (|namestring| EDINFILE) + " " + (STRINGIMAGE $LINENUMBER))) + (SHUT INPUTSTREAM) + ;(COND + ; ( (EQ (READ ERRORINSTREAM) 'ABORTPROCESS) + ; (RETURN 'ABORT) ) ) + ;;%% next is done in case the diskmode changed + ;;(SETQ INFILE (|pathname| (IFCAR + ;; (QSORT ($LISTFILE INFILE))))) + (SETQ INPUTSTREAM (DEFSTREAM INFILE 'INPUT)) + (SETQ RECNO (/LOCATE FN KEY INFILE RECNO)) + + (COND ((NOT RECNO) + (|sayBrightly| (LIST " Warning: function" "%b" /FN "%d" + "was not found in the file" "%l" " " "%b" + (|namestring| INFILE) "%d" "after editing.")) + (RETURN NIL))) + ;; next is done in case the diskmode changed + (SHUT INPUTSTREAM) )) + ;;(SETQ INFILE (|pathname| (IFCAR ($LISTFILE INFILE)))) + (SETQ INFILE (make-input-filename INFILE)) + (MAKEPROP /FN 'DEFLOC + (CONS RECNO INFILE)) + (SETQ oft (|object2Identifier| (UPCASE (|pathnameType| INFILE)))) + (COND + ( (NULL OP) + (RETURN /FN) ) ) + (COND + ( (EQ TRACEFLAG 'TRACELET) + (RETURN (/TRACELET-1 (LIST FN) NIL)) ) ) + (SETQ INPUTSTREAM (DEFSTREAM INFILE 'INPUT)) + (|sayBrightly| + (LIST " Reading file" '|%b| (|namestring| INFILE) '|%d|)) + (TERPRI) + (SETQ $BOOT (EQ oft 'BOOT)) + (SETQ $NEWSPAD (OR $BOOT (EQ oft 'SPAD))) + (SETQ DEF + (COND + ( SFN + ;(+VOL 'METABASE) + (POINT RECNO INPUTSTREAM) + ;(SETQ CHR (CAR INPUTSTREAM)) + ;(SETQ ERRCOL 0) + ;(SETQ COUNT 0) + ;(SETQ COLUMN 0) + ;(SETQ TRAPFLAG NIL) + (SETQ OK 'T) + ;(NXTTOK) + ;(SETQ LINE (CURINPUTLINE)) + ;(SETQ SPADERRORSTREAM CUROUTSTREAM) + ;(AND /ECHO (SETQ ECHOMETA 'T) (PRINTEXP LINE) (TERPRI)) + ;(SFN) + (SETQ DEF (BOOT-PARSE-1 INPUTSTREAM)) + (SETQ DEBUGMODE 'YES) + (COND + ( (NULL OK) + (FUNCALL (GET oft 'SYNTAX_ERROR)) + NIL ) + ( 'T + DEF ) ) ) + ( 'T + (let* ((mode-line (read-line inputstream)) + (pacpos (search "package:" mode-line :test #'equalp)) + (endpos (search "-*-" mode-line :from-end t)) + (*package* *package*) + (newpac nil)) + (when pacpos + (setq newpac (read-from-string mode-line nil nil + :start (+ pacpos 8) + :end endpos)) + (setq *package* + (cond ((find-package newpac)) + (t *package*)))) + (POINT RECNO INPUTSTREAM) + (READ INPUTSTREAM))))) + #+Lucid(system::compiler-options :messages t :warnings t) + (COND + ( (SETQ U (GET oft '/TRAN)) + (SETQ DEF (FUNCALL U DEF)) ) ) + (/WRITEUPDATE + /FN + (|pathnameName| INFILE) + (|pathnameType| INFILE) + (OR (|pathnameDirectory| INFILE) '*) + (OR (KAR (KAR (KDR DEF))) NIL) + OP) + (COND + ( (OR /ECHO $PRETTYPRINT) + (PRETTYPRINT DEF OUTPUTSTREAM) ) ) + (COND + ( (EQ oft 'LISP) + (if (EQ OP 'DEFINE) (EVAL DEF) + (compile (EVAL DEF)))) + ( DEF + (FUNCALL OP (LIST DEF)) ) ) + #+Lucid(system::compiler-options :messages nil :warnings nil) + #+Lucid(TERPRI) + (COND + ( TRACEFLAG + (/TRACE-2 /FN NIL) ) ) + (SHUT INPUTSTREAM) + (RETURN (LIST /FN)) ) ) + +(DEFUN FUNLOC (func &aux file) + (if (PAIRP func) (SETQ func (CAR func))) + (setq file (ifcar (findtag func))) + (if file (list (pathname-name file) (pathname-type file) func) + nil)) + +(DEFUN /LOCATE (FN KEY INFILE INITRECNO) + (PROG (FT RECNO KEYLENGTH LN) + (if (AND (NOT (eq 'FROMWRITEUPDATE (|pathnameName| INFILE))) + (NOT (make-input-filename INFILE))) + (RETURN NIL)) + (SETQ FT (UPCASE (|object2Identifier| (|pathnameType| INFILE)))) + (SETQ KEYLENGTH (STRINGLENGTH KEY)) + (WHEN (> INITRECNO 1) ;; we think we know where it is + (POINT INITRECNO INPUTSTREAM) + (SETQ LN (READ-LINE INPUTSTREAM NIL NIL)) + (IF (AND LN (MATCH-FUNCTION-DEF FN KEY KEYLENGTH LN FT)) + (RETURN INITRECNO))) + (SETQ $LINENUMBER 0) + (POINT 0 INPUTSTREAM) +EXAMINE (SETQ RECNO (NOTE INPUTSTREAM)) + (SETQ LN (READ-LINE INPUTSTREAM NIL NIL)) + (INCF $LINENUMBER) + (if (NULL LN) (RETURN NIL)) + (IF (MATCH-FUNCTION-DEF FN KEY KEYLENGTH LN FT) + (RETURN RECNO)) + (GO EXAMINE))) + +(DEFUN MATCH-FUNCTION-DEF (fn key keylength line type) + (if (eq type 'LISP) (match-lisp-tag fn line "(def") + (let ((n (mismatch key line))) + (and (= n keylength) + (or (= n (length line)) + (member (elt line n) + (or (get type '/termchr) '(#\space )))))))) + +(define-function '|/D,1| #'/D-1) + +(DEFUN /INITUPDATES (/VERSION) + (SETQ FILENAME (STRINGIMAGE /VERSION)) + (SETQ /UPDATESTREAM (open (strconc "/tmp/update." FILENAME) :direction :output + :if-exists :append :if-does-not-exist :create)) + (PRINTEXP + " Function Name Filename Date Time" + /UPDATESTREAM) + (TERPRI /UPDATESTREAM) + (PRINTEXP + " --------------------------- ----------------------- -------- -----" + /UPDATESTREAM) + (TERPRI /UPDATESTREAM) ) + +(defun /UPDATE (&rest ARGS) + (LET (( FILENAME (OR (KAR ARGS) + (strconc "/tmp/update." (STRINGIMAGE /VERSION)))) + (|$createUpdateFiles| NIL)) + (DECLARE (SPECIAL |$createUpdateFiles|)) + (CATCH 'FILENAM (/UPDATE-1 FILENAME '(/COMP))) + (SAY "Update is finished"))) + +(defun /DUPDATE (&rest ARGS) + (LET (( FILENAME (OR (KAR ARGS) + (strconc "/tmp/update." (STRINGIMAGE /VERSION)))) + (|$createUpdateFiles| NIL)) + (DECLARE (SPECIAL |$createUpdateFiles|)) + (CATCH 'FILENAM (/UPDATE-1 FILENAME 'DEFINE)) + (SAY "Update is finished"))) + +(DEFUN /UPDATE-1 (UPFILE OP) + ;;if /VERSION=0 then no new update files will be written. + (prog (STREAM RECORD FUN FILE FUNFILES) + (SETQ STREAM (DEFSTREAM (/MKINFILENAM UPFILE) 'INPUT)) + LOOP + (if (STREAM-EOF STREAM) (RETURN NIL)) + (SETQ RECORD (read-line STREAM)) + (if (NOT (STRINGP RECORD)) (RETURN NIL)) + (if (< (LENGTH RECORD) 36) (GO LOOP)) + (SETQ FUN (STRING2ID-N (SUBSTRING RECORD 0 36) 1)) + (if (AND (NOT (EQUAL FUN 'QUAD)) (EQUAL (SUBSTRING RECORD 0 1) " ")) + (GO LOOP)) + (SETQ FILE (STRING2ID-N RECORD 2)) + (if (member (cons fun file) funfiles :test #'equal) (go loop)) + (push (cons fun file) funfiles) + (COND ((EQUAL FUN 'QUAD) (/RF-1 FILE)) + ((/D-2 FUN FILE CUROUTSTREAM OP NIL NIL))) + (GO LOOP))) + +(DEFUN /WRITEUPDATE (FUN FN FT FM FTYPE OP) + +;;;If /VERSION=0 then no save has yet been done. +;;;If A disk is not read-write, then issue msg and return. +;;;If /UPDATESTREAM not set or current /UPDATES file doesnt exist, initialize. + + (PROG (IFT KEY RECNO ORECNO COUNT DATE TIME) +; (if (EQ 0 /VERSION) (RETURN NIL)) + (if (EQ 'INPUT FT) (RETURN NIL)) + (if (NOT |$createUpdateFiles|) (RETURN NIL)) +; (COND ((/= 0 (directory "A"))) +; ((SAY "A disk is not read-write. Update file not modified") +; (RETURN NIL))) + (if (OR (NOT (BOUNDP '/UPDATESTREAM)) + (NOT (STREAMP /UPDATESTREAM))) + (/INITUPDATES /VERSION)) +; (SETQ IFT (INTERN (STRINGIMAGE /VERSION))) +; (SETQ INPUTSTREAM (open (strconc IFT /WSNAME) :direction :input)) +; (NEXT INPUTSTREAM) +; (SETQ KEY (if (NOT FUN) +; (STRCONC " QUAD " +; (PNAME FN)) +; (PNAME FUN))) +; (SETQ RECNO (/LOCATE KEY (LIST 'FROMWRITEUPDATE /WSNAME) 1)) +; (SETQ COUNT (COND +; ((NOT (NUMBERP RECNO)) 1) +; ((POINT RECNO INPUTSTREAM) +; (do ((i 1 (1+ i))) ((> i 4)) (read inputstream)) +; (1+ (READ INPUTSTREAM)) ))) +; (COND ((NUMBERP RECNO) +; (SETQ ORECNO (NOTE /UPDATESTREAM)) +; (POINTW RECNO /UPDATESTREAM) )) + (SETQ DATETIME (|getDateAndTime|)) + (SETQ DATE (CAR DATETIME)) + (SETQ TIME (CDR DATETIME)) + (PRINTEXP (STRCONC + (COND ((NOT FUN) " QUAD ") + ((STRINGPAD (PNAME FUN) 28))) " " + (STRINGIMAGE FM) + (STRINGIMAGE FN) "." (STRINGIMAGE FT) + " " + DATE " " TIME) /UPDATESTREAM) + (TERPRI /UPDATESTREAM) +; (if (NUMBERP RECNO) (POINTW ORECNO /UPDATESTREAM)) + )) + +(defun |getDateAndTime| () + (MULTIPLE-VALUE-BIND (sec min hour day mon year) (get-decoded-time) + (CONS (STRCONC (LENGTH2STR mon) "/" + (LENGTH2STR day) "/" + (LENGTH2STR year) ) + (STRCONC (LENGTH2STR hour) ":" + (LENGTH2STR min))))) + +(DEFUN LENGTH2STR (X &aux XLEN) + (cond ( (= 1 (SETQ XLEN (LENGTH (SETQ X (STRINGIMAGE X))))) (STRCONC "0" X)) + ( (= 2 XLEN) X) + ( (subseq x (- XLEN 2))))) + +(defmacro /T (&rest L) (CONS '/TRACE (OR L (LIST /FN)))) + +(defmacro /TRACE (&rest L) `',(/TRACE-0 L)) + +(DEFUN /TRACE-0 (L) + (if (member '? L :test #'eq) + (OBEY "EXEC NORMEDIT TRACE TELL") + (let* ((options (/OPTIONS L)) (FNL (TRUNCLIST L OPTIONS))) + (/TRACE-1 FNL OPTIONS)))) + +(define-function '|/TRACE,0| #'/TRACE-0) + +(defmacro /TRACEANDCOUNT (&rest L) `', + (let* ((OPTIONS (/OPTIONS L)) + (FNL (TRUNCLIST L OPTIONS))) + (/TRACE-1 FNL (CONS '(DEPTH) OPTIONS)))) + +(DEFUN /TRACE-1 (FNLIST OPTIONS) + (mapcar #'(lambda (X) (/TRACE-2 X OPTIONS)) FNLIST) + (/TRACEREPLY)) + +(defvar |$traceDomains| t) + +(DEFUN /TRACE-2 (FN OPTIONS) + (PROG (U FNVAL COUNTNAM TRACECODE BEFORE AFTER CONDITION + TRACENAME CALLER VARS BREAK FROM_CONDITION VARBREAK TIMERNAM + ONLYS G WITHIN_CONDITION DEPTH_CONDITION COUNT_CONDITION + LETFUNCODE MATHTRACE ) + (if (member FN /TRACENAMES :test #'eq) (/UNTRACE-2 FN NIL)) + (SETQ OPTIONS (OPTIONS2UC OPTIONS)) + (if (AND |$traceDomains| (|isFunctor| FN) (ATOM FN)) + (RETURN (|traceDomainConstructor| FN OPTIONS))) + (SETQ MATHTRACE (/GETTRACEOPTIONS OPTIONS 'MATHPRINT)) + (if (AND MATHTRACE (NOT (EQL (ELT (PNAME FN) 0) #\$)) (NOT (GENSYMP FN))) + (if (RASSOC FN |$mapSubNameAlist|) + (SETQ |$mathTraceList| (CONS FN |$mathTraceList|)) + (|spadThrowBrightly| + (format nil "mathprint not available for ~A" FN)))) + (SETQ VARS (/GETTRACEOPTIONS OPTIONS 'VARS)) + (if VARS + (progn (if (NOT (CDR VARS)) (SETQ VARS 'all) (SETQ VARS (CDR VARS))) + (|tracelet| FN VARS))) + (SETQ BREAK (/GETTRACEOPTIONS OPTIONS 'BREAK)) + (SETQ VARBREAK (/GETTRACEOPTIONS OPTIONS 'VARBREAK)) + (if VARBREAK + (progn (if (NOT (CDR VARBREAK)) (SETQ VARS 'all) + (SETQ VARS (CDR VARBREAK))) + (|breaklet| FN VARS))) + (if (and (symbolp fn) (not (boundp FN)) (not (fboundp FN))) + (progn + (COND ((|isUncompiledMap| FN) + (|sayBrightly| + (format nil + "~A must be compiled before it may be traced -- invoke ~A to compile" + FN FN))) + ((|isInterpOnlyMap| FN) + (|sayBrightly| (format nil + "~A cannot be traced because it is an interpret-only function" FN))) + (T (|sayBrightly| (format nil "~A is not a function" FN)))) + (RETURN NIL))) + (if (and (symbolp fn) (boundp FN) + (|isDomainOrPackage| (SETQ FNVAL (EVAL FN)))) + (RETURN (|spadTrace| FNVAL OPTIONS))) + (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'MASK=)) + (MAKEPROP FN '/TRANSFORM (CADR U))) + (SETQ /TRACENAMES + (COND ((/GETTRACEOPTIONS OPTIONS 'ALIAS) /TRACENAMES) + ((ATOM /TRACENAMES) (LIST FN)) + ((CONS FN /TRACENAMES)))) + (SETQ TRACENAME + (COND ((SETQ U (/GETTRACEOPTIONS OPTIONS 'ALIAS)) + (STRINGIMAGE (CADR U))) + (T + (COND ((AND |$traceNoisely| (NOT VARS) + (NOT (|isSubForRedundantMapName| FN))) + (|sayBrightly| + (LIST '|%b| (|rassocSub| FN |$mapSubNameAlist|) + '|%d| "traced")))) + (STRINGIMAGE FN)))) + (COND (|$fromSpadTrace| + (if MATHTRACE (push (INTERN TRACENAME) |$mathTraceList|)) + (SETQ LETFUNCODE `(SETQ |$currentFunction| ,(MKQ FN))) + (SETQ BEFORE + (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'BEFORE)) + `(progn ,(CADR U) ,LETFUNCODE) + LETFUNCODE))) + (T (SETQ BEFORE + (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'BEFORE)) + (CADR U))))) + (SETQ AFTER (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'AFTER)) (CADR U))) + (SETQ CALLER (/GETTRACEOPTIONS OPTIONS 'CALLER)) + (SETQ FROM_CONDITION + (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'FROM)) + (LIST 'EQ '|#9| (LIST 'QUOTE (CADR U))) + T)) + (SETQ CONDITION + (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'WHEN)) (CADR U) T)) + (SETQ WITHIN_CONDITION T) + (COND ((SETQ U (/GETTRACEOPTIONS OPTIONS 'WITHIN)) + (SETQ G (INTERN (STRCONC (PNAME FN) "/" (PNAME (CADR U))))) + (SET G 0) + (/TRACE-1 + (LIST (CADR U)) + `((WHEN NIL) + (BEFORE (SETQ ,G (1+ ,G))) + (AFTER (SETQ ,G (1- ,G))))) + (SETQ WITHIN_CONDITION `(> ,G 0)))) + (SETQ COUNTNAM + (AND (/GETTRACEOPTIONS OPTIONS 'COUNT) + (INTERN (STRCONC TRACENAME ",COUNT"))) ) + (SETQ COUNT_CONDITION + (COND ((SETQ U (/GETTRACEOPTIONS OPTIONS 'COUNT)) + (SETQ /COUNTLIST (adjoin TRACENAME /COUNTLIST + :test 'equal)) + (if (AND (CDR U) (integerp (CADR U))) + `(cond ((<= ,COUNTNAM ,(CADR U)) t) + (t (/UNTRACE-2 ,(MKQ FN) NIL) NIL)) + t)) + (T T))) + (AND (/GETTRACEOPTIONS OPTIONS 'TIMER) + (SETQ TIMERNAM (INTERN (STRCONC TRACENAME ",TIMER"))) + (SETQ /TIMERLIST (adjoin TRACENAME /TIMERLIST :test 'equal))) + (SETQ DEPTH_CONDITION + (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'DEPTH)) + (if (AND (CDR U) (integerp (CADR U))) + (LIST 'LE 'FUNDEPTH (CADR U)) + (TRACE_OPTION_ERROR 'DEPTH)) + T)) + (SETQ CONDITION + (MKPF + (LIST CONDITION WITHIN_CONDITION FROM_CONDITION COUNT_CONDITION + DEPTH_CONDITION ) + 'AND)) + (SETQ ONLYS (/GETTRACEOPTIONS OPTIONS 'ONLY)) + + ;TRACECODE meaning: + ; 0: Caller (0,1) print caller if 1 + ; 1: Value (0,1) print value if 1 + ; 2...: Arguments (0,...,9) stop if 0; print ith if i; all if 9 + (SETQ TRACECODE + (if (/GETTRACEOPTIONS OPTIONS 'NT) "000" + (PROG (F A V C NL BUF) + (SETQ ONLYS (MAPCAR #'COND-UCASE ONLYS)) + (SETQ F (OR (member 'F ONLYS :test #'eq) + (member 'FULL ONLYS :test #'eq))) + (SETQ A (OR F (member 'A ONLYS :test #'eq) + (member 'ARGS ONLYS :test #'eq))) + (SETQ V (OR F (member 'V ONLYS :test #'eq) + (member 'VALUE ONLYS :test #'eq))) + (SETQ C (OR F (member 'C ONLYS :test #'eq) + (member 'CALLER ONLYS :test #'eq))) + (SETQ NL + (if A '(#\9) + (mapcan #'(lambda (X) + (if (AND (INTEGERP X) + (> X 0) + (< X 9)) + (LIST (FETCHCHAR (STRINGIMAGE X) 0)))) + onlys))) + (if (NOT (OR A V C NL)) + (if Caller (return "119") (return "019"))) + (SETQ NL (APPEND NL '(\0))) + (SETQ BUF (GETSTR 12)) + (SUFFIX (if (or C Caller) #\1 #\0) BUF) + (SUFFIX (if V #\1 #\0) BUF) + (if A (suffix #\9 BUF) + (mapcar #'(lambda (x) (suffix x BUF)) NL)) + (RETURN BUF)))) + (/MONITOR FN TRACECODE BEFORE AFTER CONDITION TIMERNAM + COUNTNAM TRACENAME BREAK ))) + +(DEFUN OPTIONS2UC (L) + (COND ((NOT L) NIL) + ((ATOM (CAR L)) + (|spadThrowBrightly| + (format nil "~A has wrong format for an option" (car L)))) + ((CONS (CONS (LC2UC (CAAR L)) (CDAR L)) (OPTIONS2UC (CDR L)))))) + +(DEFUN COND-UCASE (X) (COND ((INTEGERP X) X) ((UPCASE X)))) + +(DEFUN TRACEOPTIONS (X) + (COND ((NOT X) NIL) + ((EQ (CAR X) '/) X) + ((TRACEOPTIONS (CDR X))))) + +(defmacro |/untrace| (&rest L) `', (/UNTRACE-0 L)) + +(defmacro /UNTRACE (&rest L) `', (/UNTRACE-0 L)) + +(defmacro /U (&rest L) `', (/UNTRACE-0 L)) + +(DEFUN /UNTRACE-0 (L) + (PROG (OPTIONL OPTIONS FNL) + (if (member '? L :test #'eq) (RETURN (OBEY "EXEC NORMEDIT TRACE TELL"))) + (SETQ OPTIONL (/OPTIONS L)) + (SETQ FNL (TRUNCLIST L OPTIONL)) + (SETQ OPTIONS (if OPTIONL (CAR OPTIONL))) + (RETURN (/UNTRACE-1 FNL OPTIONS)))) + +(define-function '|/UNTRACE,0| #'/UNTRACE-0) + +(defun /UNTRACE-1 (L OPTIONS) + (cond + ((NOT L) + (if (ATOM /TRACENAMES) + NIL + (mapcar #'(lambda (u) (/UNTRACE-2 (/UNTRACE-REDUCE U) OPTIONS)) + (APPEND /TRACENAMES NIL)))) + ((mapcar #'(lambda (x) (/UNTRACE-2 X OPTIONS)) L))) + (/TRACEREPLY)) + +(DEFUN /UNTRACE-REDUCE (X) (if (ATOM X) X (first X))) ; (CAR X) is now a domain + +(DEFUN /UNTRACE-2 (X OPTIONS) + (let (u y) + (COND ((AND (|isFunctor| X) (ATOM X)) + (|untraceDomainConstructor| X)) + ((OR (|isDomainOrPackage| (SETQ U X)) + (and (symbolp X) (boundp X) + (|isDomain| (SETQ U (EVAL X))))) + (|spadUntrace| U OPTIONS)) + ((EQCAR OPTIONS 'ALIAS) + (if |$traceNoisely| + (|sayBrightly| (LIST '|%b| (CADR OPTIONS) '|%d| '**untraced))) + (SETQ /TIMERLIST + (REMOVE (STRINGIMAGE (CADR OPTIONS)) /TIMERLIST :test 'equal)) + (SETQ /COUNTLIST + (REMOVE (STRINGIMAGE (CADR OPTIONS)) /COUNTLIST :test 'equal)) + (SETQ |$mathTraceList| + (REMOVE (CADR OPTIONS) |$mathTraceList| :test 'equal)) + (UNEMBED X)) + ((AND (NOT (MEMBER X /TRACENAMES)) + (NOT (|isSubForRedundantMapName| X))) + (|sayBrightly| + (LIST + '|%b| + (|rassocSub| X |$mapSubNameAlist|) + '|%d| + "not traced"))) + (T (SETQ /TRACENAMES (REMOVE X /TRACENAMES :test 'equal)) + (SETQ |$mathTraceList| + (REMOVE (if (STRINGP X) (INTERN X) X) |$mathTraceList|)) + (SETQ |$letAssoc| (DELASC X |$letAssoc|)) + (setq Y (if (IS_GENVAR X) (|devaluate| (EVAL X)) X)) + (SETQ /TIMERLIST (REMOVE (STRINGIMAGE Y) /TIMERLIST :test 'equal)) + (SET (INTERN (STRCONC Y ",TIMER")) 0) + (SETQ /COUNTLIST (REMOVE (STRINGIMAGE Y) /COUNTLIST :test 'equal)) + (SET (INTERN (STRCONC Y ",COUNT")) 0) + (COND ((AND |$traceNoisely| (NOT (|isSubForRedundantMapName| Y))) + (|sayBrightly| + (LIST '|%b| (|rassocSub| Y |$mapSubNameAlist|) + '|%d| "untraced")))) + (UNEMBED X))))) + + ;; the following is called by |clearCache| +(define-function '/UNTRACE\,2 #'/UNTRACE-2) + +(DEFUN MONITOR-PRINVALUE (VAL NAME) + (let (u) + (COND ((setq U (GET NAME '/TRANSFORM)) + (COND + ((EQCAR U '&) + (PRINC "//" CURSTRM) (PRIN1 VAL CURSTRM) (TERPRI CURSTRM)) + (T (PRINC "! " CURSTRM) + (PRIN1 (EVAL (SUBST (MKQ VAL) '* (CAR U))) CURSTRM) + (TERPRI CURSTRM)) )) + (T + (PRINC ": " CURSTRM) + (COND ((NOT (SMALL-ENOUGH VAL)) (|F,PRINT-ONE| VAL CURSTRM)) + (/PRETTY (PRETTYPRINT VAL CURSTRM)) + (T (COND (|$mathTrace| (TERPRI))) + (PRINMATHOR0 VAL CURSTRM))))))) + +(DEFUN MONITOR-BLANKS (N) (PRINC (MAKE-FULL-CVEC N " ") CURSTRM)) + +(DEFUN MONITOR-EVALBEFORE (X) (EVALFUN (MONITOR-EVALTRAN X NIL)) X) + +(DEFUN MONITOR-EVALAFTER (X) (EVALFUN (MONITOR-EVALTRAN X 'T))) + +(DEFUN MONITOR-EVALTRAN (X FG) + (if (HAS_SHARP_VAR X) (MONITOR-EVALTRAN1 X FG) X)) + +(define-function 'MONITOR\,EVALTRAN #'MONITOR-EVALTRAN) + +(DEFUN MONITOR-EVALTRAN1 (X FG) + (let (n) + (COND + ((SETQ N (|isSharpVarWithNum| X)) (MONITOR-GETVALUE N FG)) + ((ATOM X) X) + ((CONS (MONITOR-EVALTRAN1 (CAR X) FG) + (MONITOR-EVALTRAN1 (CDR X) FG)))))) + +(DEFUN HAS_SHARP_VAR (X) + (COND ((AND (ATOM X) (IS_SHARP_VAR X)) 'T) + ((ATOM X) NIL) + ((OR (HAS_SHARP_VAR (CAR X)) (HAS_SHARP_VAR (CDR X)))))) + +(DEFUN IS_SHARP_VAR (X) + (AND (IDENTP X) + (EQL (ELT (PNAME X) 0) #\#) + (INTEGERP (lisp:parse-integer (symbol-name X) :start 1)))) + +(DEFUN MONITOR-GETVALUE (N FG) + (COND ((= N 0) + (if FG + (MKQ /VALUE) + (|spadThrowBrightly| "cannot ask for value before execution"))) + ((= N 9) (MKQ /CALLER)) + ((<= N (SIZE /ARGS)) (MKQ (ELT /ARGS (1- N)))) + ((|spadThrowBrightly| (LIST 'function '|%b| /NAME '|%d| + "does not have" '|%b| N '|%d| "arguments"))))) + +(DEFUN MONITOR-PRINARGS (L CODE /TRANSFORM) + (let (N) + (cond + ((= (digit-char-p (elt CODE 2)) 0) NIL) + ((= (digit-char-p (elt CODE 2)) 9) + (cond + (/TRANSFORM + (mapcar + #'(lambda (x y) + (COND ((EQ Y '*) + (PRINC "\\ " CURSTRM) + (MONITOR-PRINT X CURSTRM)) + ((EQ Y '&) + (PRINC "\\\\" CURSTRM) + (TERPRI CURSTRM) + (PRINT X CURSTRM)) + ((NOT Y) (PRINC "! " CURSTRM)) + (T + (PRINC "! " CURSTRM) + (MONITOR-PRINT + (EVAL (SUBST (MKQ X) '* Y)) CURSTRM)))) + L (cdr /transform))) + (T (PRINC ": " CURSTRM) + (COND ((NOT (ATOM L)) + (if |$mathTrace| (TERPRI CURSTRM)) + (MONITOR-PRINT (CAR L) CURSTRM) (SETQ L (CDR L)))) + (mapcar #'monitor-printrest L)))) + ((do ((istep 2 (+ istep 1)) + (k (maxindex code))) + ((> istep k) nil) + (when (not (= 0 (SETQ N (digit-char-p (elt CODE ISTEP))))) + (PRINC "\\" CURSTRM) + (PRINMATHOR0 N CURSTRM) + (PRINC ": " CURSTRM) + (MONITOR-PRINARGS-1 L N))))))) + +(DEFUN MONITOR-PRINTREST (X) + (COND ((NOT (SMALL-ENOUGH X)) + (PROGN (TERPRI) + (MONITOR-BLANKS (1+ /DEPTH)) + (PRINC "\\" CURSTRM) + (PRINT X CURSTRM))) + ((PROGN (if (NOT |$mathTrace|) (PRINC "\\" CURSTRM)) + (COND (/PRETTY (PRETTYPRINT X CURSTRM)) + ((PRINMATHOR0 X CURSTRM))))))) + +(DEFUN MONITOR-PRINARGS-1 (L N) + (COND ((OR (ATOM L) (LESSP N 1)) NIL) + ((EQ N 1) (MONITOR-PRINT (CAR L) CURSTRM)) + ((MONITOR-PRINARGS-1 (CDR L) (1- N))))) + +(DEFUN MONITOR-PRINT (X CURSTRM) + (COND ((NOT (SMALL-ENOUGH X)) (|F,PRINT-ONE| X CURSTRM)) + (/PRETTY (PRETTYPRINT X CURSTRM)) + ((PRINMATHOR0 X CURSTRM)))) + +(DEFUN PRINMATHOR0 (X CURSTRM) + (if |$mathTrace| (|maprinSpecial| (|outputTran| X) /DEPTH 80) + (PRIN0 X CURSTRM))) + +(DEFUN SMALL-ENOUGH (X) (if /TRACESIZE (SMALL-ENOUGH-COUNT X 0 /TRACESIZE) t)) + +(DEFUN SMALL-ENOUGH-COUNT (X N M) + "Returns number if number of nodes < M otherwise nil." + (COND ((< M N) NIL) + ((VECP X) + (do ((i 0 (1+ i)) (k (maxindex x))) + ((> i k) n) + (if (NOT (SETQ N (SMALL-ENOUGH-COUNT (ELT X I) (1+ N) M))) + (RETURN NIL)))) + ((ATOM X) N) + ((AND (SETQ N (SMALL-ENOUGH-COUNT (CAR X) (1+ N) M)) + (SMALL-ENOUGH-COUNT (CDR X) N M))))) + +(DEFUN /OPTIONS (X) + (COND ((ATOM X) NIL) + ((OR (ATOM (CAR X)) (|isFunctor| (CAAR X))) (/OPTIONS (CDR X))) + (X))) + +(DEFUN /GETOPTION (L OPT) (KDR (/GETTRACEOPTIONS L OPT))) + +(DEFUN /GETTRACEOPTIONS (L OPT) + (COND ((ATOM L) NIL) + ((EQ (KAR (CAR L)) OPT) (CAR L)) + ((/GETTRACEOPTIONS (CDR L) OPT)))) + +(DEFMACRO /TRACELET (&rest L) `', + (PROG (OPTIONL FNL) + (if (member '? L :test #'eq) + (RETURN (OBEY (if (EQ (SYSID) 1) + "EXEC NORMEDIT TRACELET TELL" + "$COPY AZ8F:TRLET.TELL")) )) + (SETQ OPTIONL (/OPTIONS L)) + (SETQ FNL (TRUNCLIST L OPTIONL)) + (RETURN (/TRACELET-1 FNL OPTIONL)))) + +(DEFUN /TRACELET-1 (FNLIST OPTIONL) + (mapcar #'(lambda (x) (/tracelet-2 x optionl)) fnlist) + (/TRACE-1 FNLIST OPTIONL) + (TRACELETREPLY)) + +(DEFUN TRACELETREPLY () + (if (ATOM /TRACELETNAMES) '(none tracelet) + (APPEND /TRACELETNAMES (LIST 'tracelet)))) + +(DEFUN /TRACELET-2 (FN OPTIONL &AUX ($TRACELETFLAG T)) + (/D-1 (CONS FN OPTIONL) 'COMP NIL NIL) + (SETQ /TRACELETNAMES + (if (ATOM /TRACELETNAMES) (LIST FN) (CONS FN /TRACELETNAMES))) + FN) + +(defmacro /TRACE-LET (A B) + `(PROG1 (SPADLET ,A ,B) + . ,(mapcar #'(lambda (x) `(/tracelet-print ',x ,x)) + (if (ATOM A) (LIST A) A)))) + +(defun /TRACELET-PRINT (X Y &AUX (/PRETTY 'T)) + (PRINC (STRCONC (PNAME X) ": ") *terminal-io*) + (MONITOR-PRINT Y *terminal-io*)) + +(defmacro /UNTRACELET (&rest L) `', + (COND + ((NOT L) + (if (ATOM /TRACELETNAMES) NIL (EVAL (CONS '/UNTRACELET /TRACELETNAMES)))) + ((mapcar #'/untracelet-1 L)) + ((TRACELETREPLY)))) + +(DEFUN /UNTRACELET-1 (X) + (COND + ((NOT (MEMBER X /TRACELETNAMES)) + (PROGN (PRINT (STRCONC (PNAME X) " not tracelet")) (TERPRI))) + ((PROGN + (/UNTRACELET-2 X) + (/D-1 (LIST X) 'COMP NIL NIL))))) + +(DEFUN /UNTRACELET-2 (X) + (SETQ /TRACELETNAMES (REMOVE X /TRACELETNAMES)) + (PRINT (STRCONC (PNAME X) " untracelet")) (TERPRI)) + +(defmacro /EMBED (&rest L) `', + (COND ((NOT L) (/EMBEDREPLY)) + ((member '? L :test #'eq) (OBEY "EXEC NORMEDIT EMBED TELL")) + ((EQ 2 (LENGTH L)) (/EMBED-1 (CAR L) (CADR L))) + ((MOAN "IMPROPER USE OF /EMBED")))) + +(defmacro /UNEMBED (&rest L) `', + (COND ((NOT L) + (if (ATOM (EMBEDDED)) NIL + (mapcar #'unembed (embedded))) + (SETQ /TRACENAMES NIL) + (SETQ /EMBEDNAMES NIL)) + ((mapcar #'/unembed-1 L) + (SETQ /TRACENAMES (S- /TRACENAMES L)) )) + (/EMBEDREPLY)) + +(defun /UNEMBED-Q (X) + (COND + ((NOT (MEMBER X /EMBEDNAMES)) + (ERROR (STRCONC (PNAME X) " not embeded"))) + ((PROGN + (SETQ /EMBEDNAMES (REMOVE X /EMBEDNAMES)) + (UNEMBED X))))) + +(defun /UNEMBED-1 (X) + (COND + ((NOT (MEMBER X /EMBEDNAMES)) + (|sayBrightly| (LIST '|%b| (PNAME X) '|%d| "not embeded" '|%l|))) + ((PROGN + (SETQ /EMBEDNAMES (REMOVE X /EMBEDNAMES)) + (|sayBrightly| (LIST '|%b| (PNAME X) '|%d| "unembeded" '|%l|)) + (UNEMBED X))) )) + + + +(defun /MONITOR (&rest G5) + (PROG (G1 G4 TRACECODE BEFORE AFTER CONDITION + TIMERNAM COUNTNAM TRACENAME BREAK) + (dcq (G1 TRACECODE BEFORE AFTER CONDITION TIMERNAM COUNTNAM TRACENAME BREAK) G5) + (SETQ G4 (macro-function G1)) + (SETQ TRACECODE (OR TRACECODE "119")) + (if COUNTNAM (SET COUNTNAM 0)) + (if TIMERNAM (SET TIMERNAM 0)) + (EMBED + G1 + (LIST + (if G4 'MLAMBDA 'LAMBDA) + '(&rest G6) + (LIST + '/MONITORX + (QUOTE G6) + G1 + (LIST + 'QUOTE + (LIST + TRACENAME (if G4 'MACRO) TRACECODE + COUNTNAM TIMERNAM BEFORE AFTER + CONDITION BREAK |$tracedModemap| ''T))))) + (RETURN G1))) + +(defvar |$TraceFlag| t) + +(defun /MONITORX (/ARGS FUNCT OPTS &AUX NAME TYPE TRACECODE COUNTNAM TIMERNAM + BEFORE AFTER CONDITION BREAK TRACEDMODEMAP + BREAKCONDITION) + (declare (special /ARGS)) + (DCQ (NAME TYPE TRACECODE COUNTNAM TIMERNAM BEFORE AFTER CONDITION BREAK TRACEDMODEMAP BREAKCONDITION) OPTS) + (|stopTimer|) + (PROG (C V A NAME1 CURSTRM EVAL_TIME INIT_TIME NOT_TOP_LEVEL + (/DEPTH (if (and (BOUNDP '/DEPTH) (numberp /depth)) (1+ /DEPTH) 1)) + (|depthAlist| (if (BOUNDP '|depthAlist|) (COPY-TREE |depthAlist|) NIL)) + FUNDEPTH NAMEID YES (|$tracedSpadModemap| TRACEDMODEMAP) (|$mathTrace| NIL) + /caller /name /value /breakcondition curdepth) + (declare (special curstrm /depth fundepth |$tracedSpadModemap| |$mathTrace| + /caller /name /value /breakcondition |depthAlist|)) + (SETQ /NAME NAME) + (SETQ NAME1 (PNAME (|rassocSub| (INTERN NAME) |$mapSubNameAlist|))) + (SETQ /BREAKCONDITION BREAKCONDITION) + (SETQ /CALLER (|rassocSub| (WHOCALLED 6) |$mapSubNameAlist|)) + (if (NOT (STRINGP TRACECODE)) + (MOAN "set TRACECODE to \'1911\' and restart")) + (SETQ C (digit-char-p (elt TRACECODE 0)) + V (digit-char-p (elt TRACECODE 1)) + A (digit-char-p (elt TRACECODE 2))) + (if COUNTNAM (SET COUNTNAM (1+ (EVAL COUNTNAM)))) + (SETQ NAMEID (INTERN NAME)) + (SETQ NOT_TOP_LEVEL (ASSOC NAMEID |depthAlist| :test #'eq)) + (if (NOT NOT_TOP_LEVEL) + (SETQ |depthAlist| (CONS (CONS NAMEID 1) |depthAlist|)) + (RPLACD NOT_TOP_LEVEL (1+ (CDR NOT_TOP_LEVEL)))) + (SETQ FUNDEPTH (CDR (ASSOC NAMEID |depthAlist| :test #'eq))) + (SETQ CONDITION (MONITOR-EVALTRAN CONDITION NIL)) + (SETQ YES (EVALFUN CONDITION)) + (if (member NAMEID |$mathTraceList| :test #'eq) + (SETQ |$mathTrace| T)) + (if (AND YES |$TraceFlag|) + (PROG (|$TraceFlag|) + (SETQ CURSTRM *TERMINAL-IO*) + (if (EQUAL TRACECODE "000") (RETURN NIL)) + (TAB 0 CURSTRM) + (MONITOR-BLANKS (1- /DEPTH)) + (PRIN0 FUNDEPTH CURSTRM) + (|sayBrightlyNT| (LIST "exit " '|%b| NAME1 '|%d|) CURSTRM) + (COND (TIMERNAM + (|sayBrightlyNT| '\( CURSTRM) + (|sayBrightlyNT| (/ EVAL_TIME 60.0) CURSTRM) + (|sayBrightlyNT| '\ sec\) CURSTRM) )) + (if (EQ 1 V) + (MONITOR-PRINVALUE + (|coerceTraceFunValue2E| + (INTERN NAME1) (INTERN NAME) /VALUE) + (INTERN NAME1))) + (if (NOT |$mathTrace|) (TERPRI CURSTRM)) + SKIP)) + (if (member '|after| BREAK :test #'eq) + (|break| (LIST "Break on exiting" '|%b| NAME1 '|%d| ":"))) + (|startTimer|) + (RETURN /VALUE))) + +; Functions to run a timer for tracing +; It avoids timing the tracing function itself by turning the timer +; on and off + +(defvar |$oldTime| 0) +(defvar |$timerOn| t) +(defvar $delay 0) + +(defun |startTimer| () + (SETQ $delay (PLUS $delay (DIFFERENCE (TEMPUS-FUGIT) |$oldTime|))) + (SETQ |$timerOn| 'T) + (|clock|)) + +(defun |stopTimer| () (SETQ |$oldTime| (TEMPUS-FUGIT) |$timerOn| NIL) (|clock|)) + +(defun |clock| () + (if |$timerOn| (- (TEMPUS-FUGIT) $delay) (- |$oldTime| $delay))) + +; Functions to trace/untrace a BPI; use as follows: +; To trace a BPI-value , evaluate (SETQ (BPITRACE )) +; To later untrace , evaluate (BPITRACE ) + +(defun PAIRTRACE (PAIR ALIAS) + (RPLACA PAIR (BPITRACE (CAR PAIR) ALIAS )) NIL) + +(defun BPITRACE (BPI ALIAS &optional OPTIONS) + (SETQ NEWNAME (GENSYM)) + (IF (identp bpi) (setq bpi (symbol-function bpi))) + (SET NEWNAME BPI) + (SETF (symbol-function NEWNAME) BPI) + (/TRACE-0 (APPEND (LIST NEWNAME (LIST 'ALIAS ALIAS)) OPTIONS)) + NEWNAME) + +(defun BPIUNTRACE (X ALIAS) (/UNTRACE-0 (LIST X (LIST 'ALIAS ALIAS)))) + +(defun SPADSYSNAMEP (STR) + (let (n i j) + (AND (SETQ N (MAXINDEX STR)) + (SETQ I (position #\. STR :start 1)) + (SETQ J (position #\, STR :start (1+ I))) + (do ((k (1+ j) (1+ k))) + ((> k n) t) + (if (not (digitp (elt str k))) (return nil)))))) + +; ********************************************************************** +; Utility functions for Tracing Package +; ********************************************************************** + +(MAKEPROP '|coerce| '/TRANSFORM '(& & *)) +(MAKEPROP '|comp| '/TRANSFORM '(& * * &)) +(MAKEPROP '|compIf| '/TRANSFORM '(& * * &)) + +; by having no transform for the 3rd argument, it is simply not printed + +(MAKEPROP '|compFormWithModemap| '/TRANSFORM '(& * * & *)) + +(defun UNVEC (X) + (COND ((REFVECP X) (CONS '$ (VEC_TO_TREE X))) + ((ATOM X) X) + ((CONS (UNVEC (CAR X)) (UNVEC (CDR X)))))) + +(defun DROPENV (X) (AND X (LIST (CAR X) (CADR X)))) + +(defun SHOWBIND (E) + (do ((v e (cdr v)) + (llev 1 (1+ llev))) + ((not v)) + (PRINT (LIST "LAMBDA LEVEL" LLEV)) + (do ((w (car v) (cdr w)) + (clev 1 (1+ clev))) + ((not w)) + (PRINT (LIST "CONTOUR LEVEL" CLEV)) + (PRINT (mapcar #'car (car W)))))) + +#+:CCL +(defun break (&rest ignore) (lisp-break ignore) (lisp::unwind)) + + +#+:CCL +(defun lisp-break (&rest ignore) + (prog (prompt ifile ofile u v) + (setq ifile (rds *debug-io*)) + (setq ofile (wrs *debug-io*)) + (setq prompt (setpchar "Break loop (:? for help)> ")) +top (setq u (read)) + (cond + ((equal u ':x) (go exit)) + ((equal u ':q) + (progn (lisp::enable-backtrace nil) + (princ "Backtrace now disabled") + (terpri))) + ((equal u ':v) + (progn (lisp::enable-backtrace t) + (princ "Backtrace now enabled") + (terpri))) + ((equal u ':?) + (progn + (princ ":Q disables backtrace") + (terpri) + (princ ":V enables backtrace") + (terpri) + (princ ":X exits from break loop") + (terpri) + (princ "else enter LISP expressions for evaluation") + (terpri))) + ((equal u #\eof) + (go exit)) + (t (progn + (setq v (errorset u nil nil)) + (if (listp v) (progn (princ "=> ") (prinl (car v)) (terpri))))) ) + (go top) +exit (rds ifile) + (wrs ofile) + (setpchar prompt) + (return nil))) + +(defun lisp-break-from-axiom (&rest ignore) + (boot::|handleLispBreakLoop| boot::|$BreakMode|)) +#+:CCL (setq lisp:*break-loop* 'boot::lisp-break-from-axiom) + +#-:CCL +(defun interrupt (&rest ignore)) + +#+:CCL +(defun interrupt (&rest ignore) + (prog (prompt ifile ofile u v) + (setq ifile (rds *debug-io*)) + (setq ofile (wrs *debug-io*)) + (setq prompt (setpchar "Break loop (:? for help)> ")) +top (setq u (read)) + (cond + ((equal u ':x) (go exit)) + ((equal u ':r) (go resume)) + ((equal u ':q) + (progn (lisp::enable-backtrace nil) + (princ "Backtrace now disabled") + (terpri))) + ((equal u ':v) + (progn (lisp::enable-backtrace t) + (princ "Backtrace now enabled") + (terpri))) + ((equal u ':?) + (progn + (princ ":Q disables backtrace") + (terpri) + (princ ":V enables backtrace") + (terpri) + (princ ":R resumes from break") + (terpri) + (princ ":X exits from break loop") + (terpri) + (princ "else enter LISP expressions for evaluation") + (terpri))) + ((equal u #\eof) + (go exit)) + (t (progn + (setq v (errorset u nil nil)) + (if (listp v) (progn (princ "=> ") (prinl (car v)) (terpri))))) ) + (go top) +resume (rds ifile) + (wrs ofile) + (setpchar prompt) + (return nil) +exit (rds ifile) + (wrs ofile) + (setpchar prompt) + (lisp::unwind))) + + diff --git a/src/interp/debug.lisp.pamphlet b/src/interp/debug.lisp.pamphlet deleted file mode 100644 index b4ceeed3..00000000 --- a/src/interp/debug.lisp.pamphlet +++ /dev/null @@ -1,1244 +0,0 @@ -%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/debug.lisp} Pamphlet} -\author{Timothy Daly} - -\begin{document} -\maketitle - -\begin{abstract} -\end{abstract} - -\tableofcontents -\eject - -\section{interrupt} - -A "resumable" break loop for use in trace etc. Unfortunately this -only works for CCL. We need to define a Common Lisp version. For -now the function is defined but does nothing. -<>= -#-:CCL -(defun interrupt (&rest ignore)) - -#+:CCL -(defun interrupt (&rest ignore) - (prog (prompt ifile ofile u v) - (setq ifile (rds *debug-io*)) - (setq ofile (wrs *debug-io*)) - (setq prompt (setpchar "Break loop (:? for help)> ")) -top (setq u (read)) - (cond - ((equal u ':x) (go exit)) - ((equal u ':r) (go resume)) - ((equal u ':q) - (progn (lisp::enable-backtrace nil) - (princ "Backtrace now disabled") - (terpri))) - ((equal u ':v) - (progn (lisp::enable-backtrace t) - (princ "Backtrace now enabled") - (terpri))) - ((equal u ':?) - (progn - (princ ":Q disables backtrace") - (terpri) - (princ ":V enables backtrace") - (terpri) - (princ ":R resumes from break") - (terpri) - (princ ":X exits from break loop") - (terpri) - (princ "else enter LISP expressions for evaluation") - (terpri))) - ((equal u #\eof) - (go exit)) - (t (progn - (setq v (errorset u nil nil)) - (if (listp v) (progn (princ "=> ") (prinl (car v)) (terpri))))) ) - (go top) -resume (rds ifile) - (wrs ofile) - (setpchar prompt) - (return nil) -exit (rds ifile) - (wrs ofile) - (setpchar prompt) - (lisp::unwind))) - -@ - -\section{License} - -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -;;; @(#)debug.lisp 2.5 90/02/15 10:27:33 - -; NAME: Debugging Package -; PURPOSE: Debugging hooks for Boot code - -(in-package "BOOT") -(use-package '("LISP" )) - -(DEFPARAMETER /COUNTLIST NIL) -(DEFPARAMETER /TIMERLIST NIL) -(DEFPARAMETER /TRACESIZE NIL "sets limit on size of object to be mathprinted") -(DEFVAR CURSTRM *TERMINAL-IO*) -(DEFVAR /TRACELETNAMES ()) -(DEFVAR /PRETTY () "controls pretty printing of trace output") -(SETANDFILEQ /ECHO NIL) ;;"prevents echo of SPAD or BOOT code with /c" -(MAKEPROP 'LISP '/TERMCHR '(#\ #\()) -(MAKEPROP 'LSP '/TERMCHR '(#\ #\()) -(MAKEPROP 'META '/TERMCHR '(#\: #\()) -(MAKEPROP 'INPUT '/TERMCHR '(#\: #\< #\ #\()) -(MAKEPROP 'SPAD '/TERMCHR '(#\: #\< #\ #\()) -(MAKEPROP 'BOOT '/TERMCHR '(#\: #\< #\ #\()) -(MAKEPROP 'INPUT '/XCAPE #\_) -(MAKEPROP 'BOOT '/XCAPE '#\_) -(MAKEPROP 'SPAD '/XCAPE '#\_) -(MAKEPROP 'META '/READFUN 'META\,RULE) -(MAKEPROP 'INPUT '/READFUN '|New,LEXPR,Interactive|) -(MAKEPROP 'INPUT '/TRAN '/TRANSPAD) -(MAKEPROP 'BOOT '/READFUN '|New,LEXPR1|) -(MAKEPROP 'BOOT '/TRAN '/TRANSNBOOT) -(MAKEPROP 'SPAD '/READFUN '|New,LEXPR|) -(MAKEPROP 'SPAD '/TRAN '/TRANSPAD) - -(defmacro |/C,LIB| (&rest L &aux optionlist /editfile - ($prettyprint 't) ($reportCompilation 't)) - (declare (special optionlist /editfile $prettyprint $reportComilation)) - `',(|compileConstructorLib| L (/COMP) NIL NIL)) - -(defmacro /C (&rest L) `',(/D-1 L (/COMP) NIL NIL)) - -(defmacro /CT (&rest L) `',(/D-1 L (/COMP) NIL 'T)) - -(defmacro /CTL (&rest L) `',(/D-1 L (/COMP) NIL 'TRACELET)) - -(defmacro /D (&rest L) `',(/D-1 L 'DEFINE NIL NIL)) - -(defmacro /EC (&rest L) `', (/D-1 L (/COMP) 'T NIL)) - -(defmacro /ECT (&rest L) `',(/D-1 L (/COMP) 'T 'T)) - -(defmacro /ECTL (&rest L) `',(/D-1 L (/COMP) 'T 'TRACELET)) - -(defmacro /E (&rest L) `',(/D-1 L NIL 'T NIL)) - -(defmacro /ED (&rest L) `',(/D-1 L 'DEFINE 'T NIL)) - -(defun heapelapsed () 0) - -(defun /COMP () (if (fboundp 'COMP) 'COMP 'COMP370)) - -(DEFUN /D-1 (L OP EFLG TFLG) - (CATCH 'FILENAM - (PROG (TO OPTIONL OPTIONS FNL INFILE OUTSTREAM FN ) - (declare (special fn infile outstream )) - (if (member '? L :test #'eq) - (RETURN (OBEY "EXEC SPADEDIT /C TELL"))) - (SETQ OPTIONL (/OPTIONS L)) - (SETQ FNL (TRUNCLIST L OPTIONL)) - (SETQ OPTIONS (OPTIONS2UC OPTIONL)) - (SETQ INFILE (/MKINFILENAM (/GETOPTION OPTIONS 'FROM))) - (SETQ TO (/GETOPTION OPTIONS 'TO)) - (if TO (SETQ TO (/MKOUTFILENAM (/GETOPTION OPTIONS 'TO) INFILE))) - (SETQ OUTSTREAM (if TO (DEFSTREAM TO 'OUTPUT) CUROUTSTREAM)) - (RETURN (mapcar #'(lambda (fn) - (/D-2 FN INFILE OUTSTREAM OP EFLG TFLG)) - (or fnl (list /fn))))))) - -(DEFUN |/D,2,LIB| (FN INFILE CUROUTSTREAM OP EDITFLAG TRACEFLAG) - (declare (special CUROUTSTREAM)) - "Called from compConLib1 (see LISPLIB BOOT) to bind CUROUTSTREAM." - (/D-2 FN INFILE CUROUTSTREAM OP EDITFLAG TRACEFLAG)) - -(defparameter $linenumber 0) - -(DEFUN /D-2 (FN INFILE OUTPUTSTREAM OP EDITFLAG TRACEFLAG) - (declare (special OUTPUTSTREAM)) - (PROG (FT oft SFN X EDINFILE FILE DEF KEY RECNO U W SOURCEFILES - ECHOMETA SINGLINEMODE XCAPE XTOKENREADER INPUTSTREAM SPADERRORSTREAM - ISID NBLNK COMMENTCHR $TOKSTACK (/SOURCEFILES |$sourceFiles|) - METAKEYLST DEFINITION_NAME (|$sourceFileTypes| '(|spad| |boot| |lisp| |lsp| |meta|)) - ($FUNCTION FN) $BOOT $NEWSPAD $LINESTACK $LINENUMBER STACK STACKX BACK OK - TRAPFLAG |$InteractiveMode| TOK COUNT ERRCOL COLUMN *QUERY CHR LINE - (*COMP370-APPLY* (if (eq op 'define) #'eval-defun #'compile-defun))) - (declare (special ECHOMETA SINGLINEMODE XCAPE XTOKENREADER INPUTSTREAM - SPADERRORSTREAM ISID NBLNK COMMENTCHR $TOKSTACK /SOURCEFILES - METAKEYLST DEFINITION_NAME |$sourceFileTypes| - $FUNCTION $BOOT $NEWSPAD $LINESTACK $LINENUMBER STACK STACKX BACK OK - TRAPFLAG |$InteractiveMode| TOK COUNT ERRCOL COLUMN *QUERY CHR LINE)) - (if (PAIRP FN) (SETQ FN (QCAR FN))) - (SETQ INFILE (OR INFILE (|getFunctionSourceFile| FN))) - ;; $FUNCTION is freely set in getFunctionSourceFile - (IF (PAIRP $FUNCTION) (SETQ $FUNCTION (QCAR $FUNCTION))) - (SETQ FN $FUNCTION) - (SETQ /FN $FUNCTION) - LOOP (SETQ SOURCEFILES - (cond ( INFILE - (SETQ /SOURCEFILES (CONS INFILE (REMOVE INFILE /SOURCEFILES))) - (LIST INFILE)) - ( /EDITFILE - (|insert| (|pathname| /EDITFILE) /SOURCEFILES)) - ( 't /SOURCEFILES))) - (SETQ RECNO - (dolist (file sourcefiles) - (SETQ INPUTSTREAM (DEFSTREAM FILE 'INPUT)) - - ;;?(REMFLAG S-SPADKEY 'KEY) ; hack !! - (SETQ FT (|pathnameType| FILE)) - (SETQ oft (|object2Identifier| (UPCASE FT))) - (SETQ XCAPE (OR (GET oft '/XCAPE) #\|)) - (SETQ COMMENTCHR (GET oft '/COMMENTCHR)) - (SETQ XTOKENREADER (OR (GET oft '/NXTTOK) 'METATOK)) - (SETQ DEFINITION_NAME FN) - (SETQ KEY - (STRCONC - (OR (AND (EQ oFT 'SPAD) "") - (AND (EQ oFT 'BOOT) "") - (GET oFT '/PREFIX) - "") - (PNAME FN))) - (SETQ SFN (GET oFT '/READFUN)) - (SETQ RECNO (/LOCATE FN KEY FILE 0)) - (SHUT INPUTSTREAM) - (cond ((NUMBERP RECNO) - (SETQ /SOURCEFILES (CONS FILE (REMOVE FILE /SOURCEFILES))) - (SETQ INFILE FILE) - (RETURN RECNO)))) ) - (if (NOT RECNO) - (if (SETQ INFILE (/MKINFILENAM '(NIL))) (GO LOOP) (UNWIND))) - (TERPRI) - (TERPRI) - (SETQ INFILE (|pathname| INFILE)) - (COND - ( EDITFLAG - ;;%% next form is used because $FINDFILE seems to screw up - ;;%% sometimes. The stream is opened and closed several times - ;;%% in case the filemode has changed during editing. - (SETQ EDINFILE (make-input-filename INFILE)) - (SETQ INPUTSTREAM (DEFSTREAM EDINFILE 'INPUT)) - (|sayBrightly| - (LIST " editing file" '|%b| (|namestring| EDINFILE) '|%d|)) - (OBEY - (STRCONC - (make-absolute-filename "/lib/SPADEDFN ") - (|namestring| EDINFILE) - " " - (STRINGIMAGE $LINENUMBER))) - (SHUT INPUTSTREAM) - ;(COND - ; ( (EQ (READ ERRORINSTREAM) 'ABORTPROCESS) - ; (RETURN 'ABORT) ) ) - ;;%% next is done in case the diskmode changed - ;;(SETQ INFILE (|pathname| (IFCAR - ;; (QSORT ($LISTFILE INFILE))))) - (SETQ INPUTSTREAM (DEFSTREAM INFILE 'INPUT)) - (SETQ RECNO (/LOCATE FN KEY INFILE RECNO)) - - (COND ((NOT RECNO) - (|sayBrightly| (LIST " Warning: function" "%b" /FN "%d" - "was not found in the file" "%l" " " "%b" - (|namestring| INFILE) "%d" "after editing.")) - (RETURN NIL))) - ;; next is done in case the diskmode changed - (SHUT INPUTSTREAM) )) - ;;(SETQ INFILE (|pathname| (IFCAR ($LISTFILE INFILE)))) - (SETQ INFILE (make-input-filename INFILE)) - (MAKEPROP /FN 'DEFLOC - (CONS RECNO INFILE)) - (SETQ oft (|object2Identifier| (UPCASE (|pathnameType| INFILE)))) - (COND - ( (NULL OP) - (RETURN /FN) ) ) - (COND - ( (EQ TRACEFLAG 'TRACELET) - (RETURN (/TRACELET-1 (LIST FN) NIL)) ) ) - (SETQ INPUTSTREAM (DEFSTREAM INFILE 'INPUT)) - (|sayBrightly| - (LIST " Reading file" '|%b| (|namestring| INFILE) '|%d|)) - (TERPRI) - (SETQ $BOOT (EQ oft 'BOOT)) - (SETQ $NEWSPAD (OR $BOOT (EQ oft 'SPAD))) - (SETQ DEF - (COND - ( SFN - ;(+VOL 'METABASE) - (POINT RECNO INPUTSTREAM) - ;(SETQ CHR (CAR INPUTSTREAM)) - ;(SETQ ERRCOL 0) - ;(SETQ COUNT 0) - ;(SETQ COLUMN 0) - ;(SETQ TRAPFLAG NIL) - (SETQ OK 'T) - ;(NXTTOK) - ;(SETQ LINE (CURINPUTLINE)) - ;(SETQ SPADERRORSTREAM CUROUTSTREAM) - ;(AND /ECHO (SETQ ECHOMETA 'T) (PRINTEXP LINE) (TERPRI)) - ;(SFN) - (SETQ DEF (BOOT-PARSE-1 INPUTSTREAM)) - (SETQ DEBUGMODE 'YES) - (COND - ( (NULL OK) - (FUNCALL (GET oft 'SYNTAX_ERROR)) - NIL ) - ( 'T - DEF ) ) ) - ( 'T - (let* ((mode-line (read-line inputstream)) - (pacpos (search "package:" mode-line :test #'equalp)) - (endpos (search "-*-" mode-line :from-end t)) - (*package* *package*) - (newpac nil)) - (when pacpos - (setq newpac (read-from-string mode-line nil nil - :start (+ pacpos 8) - :end endpos)) - (setq *package* - (cond ((find-package newpac)) - (t *package*)))) - (POINT RECNO INPUTSTREAM) - (READ INPUTSTREAM))))) - #+Lucid(system::compiler-options :messages t :warnings t) - (COND - ( (SETQ U (GET oft '/TRAN)) - (SETQ DEF (FUNCALL U DEF)) ) ) - (/WRITEUPDATE - /FN - (|pathnameName| INFILE) - (|pathnameType| INFILE) - (OR (|pathnameDirectory| INFILE) '*) - (OR (KAR (KAR (KDR DEF))) NIL) - OP) - (COND - ( (OR /ECHO $PRETTYPRINT) - (PRETTYPRINT DEF OUTPUTSTREAM) ) ) - (COND - ( (EQ oft 'LISP) - (if (EQ OP 'DEFINE) (EVAL DEF) - (compile (EVAL DEF)))) - ( DEF - (FUNCALL OP (LIST DEF)) ) ) - #+Lucid(system::compiler-options :messages nil :warnings nil) - #+Lucid(TERPRI) - (COND - ( TRACEFLAG - (/TRACE-2 /FN NIL) ) ) - (SHUT INPUTSTREAM) - (RETURN (LIST /FN)) ) ) - -(DEFUN FUNLOC (func &aux file) - (if (PAIRP func) (SETQ func (CAR func))) - (setq file (ifcar (findtag func))) - (if file (list (pathname-name file) (pathname-type file) func) - nil)) - -(DEFUN /LOCATE (FN KEY INFILE INITRECNO) - (PROG (FT RECNO KEYLENGTH LN) - (if (AND (NOT (eq 'FROMWRITEUPDATE (|pathnameName| INFILE))) - (NOT (make-input-filename INFILE))) - (RETURN NIL)) - (SETQ FT (UPCASE (|object2Identifier| (|pathnameType| INFILE)))) - (SETQ KEYLENGTH (STRINGLENGTH KEY)) - (WHEN (> INITRECNO 1) ;; we think we know where it is - (POINT INITRECNO INPUTSTREAM) - (SETQ LN (READ-LINE INPUTSTREAM NIL NIL)) - (IF (AND LN (MATCH-FUNCTION-DEF FN KEY KEYLENGTH LN FT)) - (RETURN INITRECNO))) - (SETQ $LINENUMBER 0) - (POINT 0 INPUTSTREAM) -EXAMINE (SETQ RECNO (NOTE INPUTSTREAM)) - (SETQ LN (READ-LINE INPUTSTREAM NIL NIL)) - (INCF $LINENUMBER) - (if (NULL LN) (RETURN NIL)) - (IF (MATCH-FUNCTION-DEF FN KEY KEYLENGTH LN FT) - (RETURN RECNO)) - (GO EXAMINE))) - -(DEFUN MATCH-FUNCTION-DEF (fn key keylength line type) - (if (eq type 'LISP) (match-lisp-tag fn line "(def") - (let ((n (mismatch key line))) - (and (= n keylength) - (or (= n (length line)) - (member (elt line n) - (or (get type '/termchr) '(#\space )))))))) - -(define-function '|/D,1| #'/D-1) - -(DEFUN /INITUPDATES (/VERSION) - (SETQ FILENAME (STRINGIMAGE /VERSION)) - (SETQ /UPDATESTREAM (open (strconc "/tmp/update." FILENAME) :direction :output - :if-exists :append :if-does-not-exist :create)) - (PRINTEXP - " Function Name Filename Date Time" - /UPDATESTREAM) - (TERPRI /UPDATESTREAM) - (PRINTEXP - " --------------------------- ----------------------- -------- -----" - /UPDATESTREAM) - (TERPRI /UPDATESTREAM) ) - -(defun /UPDATE (&rest ARGS) - (LET (( FILENAME (OR (KAR ARGS) - (strconc "/tmp/update." (STRINGIMAGE /VERSION)))) - (|$createUpdateFiles| NIL)) - (DECLARE (SPECIAL |$createUpdateFiles|)) - (CATCH 'FILENAM (/UPDATE-1 FILENAME '(/COMP))) - (SAY "Update is finished"))) - -(defun /DUPDATE (&rest ARGS) - (LET (( FILENAME (OR (KAR ARGS) - (strconc "/tmp/update." (STRINGIMAGE /VERSION)))) - (|$createUpdateFiles| NIL)) - (DECLARE (SPECIAL |$createUpdateFiles|)) - (CATCH 'FILENAM (/UPDATE-1 FILENAME 'DEFINE)) - (SAY "Update is finished"))) - -(DEFUN /UPDATE-1 (UPFILE OP) - ;;if /VERSION=0 then no new update files will be written. - (prog (STREAM RECORD FUN FILE FUNFILES) - (SETQ STREAM (DEFSTREAM (/MKINFILENAM UPFILE) 'INPUT)) - LOOP - (if (STREAM-EOF STREAM) (RETURN NIL)) - (SETQ RECORD (read-line STREAM)) - (if (NOT (STRINGP RECORD)) (RETURN NIL)) - (if (< (LENGTH RECORD) 36) (GO LOOP)) - (SETQ FUN (STRING2ID-N (SUBSTRING RECORD 0 36) 1)) - (if (AND (NOT (EQUAL FUN 'QUAD)) (EQUAL (SUBSTRING RECORD 0 1) " ")) - (GO LOOP)) - (SETQ FILE (STRING2ID-N RECORD 2)) - (if (member (cons fun file) funfiles :test #'equal) (go loop)) - (push (cons fun file) funfiles) - (COND ((EQUAL FUN 'QUAD) (/RF-1 FILE)) - ((/D-2 FUN FILE CUROUTSTREAM OP NIL NIL))) - (GO LOOP))) - -(DEFUN /WRITEUPDATE (FUN FN FT FM FTYPE OP) - -;;;If /VERSION=0 then no save has yet been done. -;;;If A disk is not read-write, then issue msg and return. -;;;If /UPDATESTREAM not set or current /UPDATES file doesnt exist, initialize. - - (PROG (IFT KEY RECNO ORECNO COUNT DATE TIME) -; (if (EQ 0 /VERSION) (RETURN NIL)) - (if (EQ 'INPUT FT) (RETURN NIL)) - (if (NOT |$createUpdateFiles|) (RETURN NIL)) -; (COND ((/= 0 (directory "A"))) -; ((SAY "A disk is not read-write. Update file not modified") -; (RETURN NIL))) - (if (OR (NOT (BOUNDP '/UPDATESTREAM)) - (NOT (STREAMP /UPDATESTREAM))) - (/INITUPDATES /VERSION)) -; (SETQ IFT (INTERN (STRINGIMAGE /VERSION))) -; (SETQ INPUTSTREAM (open (strconc IFT /WSNAME) :direction :input)) -; (NEXT INPUTSTREAM) -; (SETQ KEY (if (NOT FUN) -; (STRCONC " QUAD " -; (PNAME FN)) -; (PNAME FUN))) -; (SETQ RECNO (/LOCATE KEY (LIST 'FROMWRITEUPDATE /WSNAME) 1)) -; (SETQ COUNT (COND -; ((NOT (NUMBERP RECNO)) 1) -; ((POINT RECNO INPUTSTREAM) -; (do ((i 1 (1+ i))) ((> i 4)) (read inputstream)) -; (1+ (READ INPUTSTREAM)) ))) -; (COND ((NUMBERP RECNO) -; (SETQ ORECNO (NOTE /UPDATESTREAM)) -; (POINTW RECNO /UPDATESTREAM) )) - (SETQ DATETIME (|getDateAndTime|)) - (SETQ DATE (CAR DATETIME)) - (SETQ TIME (CDR DATETIME)) - (PRINTEXP (STRCONC - (COND ((NOT FUN) " QUAD ") - ((STRINGPAD (PNAME FUN) 28))) " " - (STRINGIMAGE FM) - (STRINGIMAGE FN) "." (STRINGIMAGE FT) - " " - DATE " " TIME) /UPDATESTREAM) - (TERPRI /UPDATESTREAM) -; (if (NUMBERP RECNO) (POINTW ORECNO /UPDATESTREAM)) - )) - -(defun |getDateAndTime| () - (MULTIPLE-VALUE-BIND (sec min hour day mon year) (get-decoded-time) - (CONS (STRCONC (LENGTH2STR mon) "/" - (LENGTH2STR day) "/" - (LENGTH2STR year) ) - (STRCONC (LENGTH2STR hour) ":" - (LENGTH2STR min))))) - -(DEFUN LENGTH2STR (X &aux XLEN) - (cond ( (= 1 (SETQ XLEN (LENGTH (SETQ X (STRINGIMAGE X))))) (STRCONC "0" X)) - ( (= 2 XLEN) X) - ( (subseq x (- XLEN 2))))) - -(defmacro /T (&rest L) (CONS '/TRACE (OR L (LIST /FN)))) - -(defmacro /TRACE (&rest L) `',(/TRACE-0 L)) - -(DEFUN /TRACE-0 (L) - (if (member '? L :test #'eq) - (OBEY "EXEC NORMEDIT TRACE TELL") - (let* ((options (/OPTIONS L)) (FNL (TRUNCLIST L OPTIONS))) - (/TRACE-1 FNL OPTIONS)))) - -(define-function '|/TRACE,0| #'/TRACE-0) - -(defmacro /TRACEANDCOUNT (&rest L) `', - (let* ((OPTIONS (/OPTIONS L)) - (FNL (TRUNCLIST L OPTIONS))) - (/TRACE-1 FNL (CONS '(DEPTH) OPTIONS)))) - -(DEFUN /TRACE-1 (FNLIST OPTIONS) - (mapcar #'(lambda (X) (/TRACE-2 X OPTIONS)) FNLIST) - (/TRACEREPLY)) - -(defvar |$traceDomains| t) - -(DEFUN /TRACE-2 (FN OPTIONS) - (PROG (U FNVAL COUNTNAM TRACECODE BEFORE AFTER CONDITION - TRACENAME CALLER VARS BREAK FROM_CONDITION VARBREAK TIMERNAM - ONLYS G WITHIN_CONDITION DEPTH_CONDITION COUNT_CONDITION - LETFUNCODE MATHTRACE ) - (if (member FN /TRACENAMES :test #'eq) (/UNTRACE-2 FN NIL)) - (SETQ OPTIONS (OPTIONS2UC OPTIONS)) - (if (AND |$traceDomains| (|isFunctor| FN) (ATOM FN)) - (RETURN (|traceDomainConstructor| FN OPTIONS))) - (SETQ MATHTRACE (/GETTRACEOPTIONS OPTIONS 'MATHPRINT)) - (if (AND MATHTRACE (NOT (EQL (ELT (PNAME FN) 0) #\$)) (NOT (GENSYMP FN))) - (if (RASSOC FN |$mapSubNameAlist|) - (SETQ |$mathTraceList| (CONS FN |$mathTraceList|)) - (|spadThrowBrightly| - (format nil "mathprint not available for ~A" FN)))) - (SETQ VARS (/GETTRACEOPTIONS OPTIONS 'VARS)) - (if VARS - (progn (if (NOT (CDR VARS)) (SETQ VARS 'all) (SETQ VARS (CDR VARS))) - (|tracelet| FN VARS))) - (SETQ BREAK (/GETTRACEOPTIONS OPTIONS 'BREAK)) - (SETQ VARBREAK (/GETTRACEOPTIONS OPTIONS 'VARBREAK)) - (if VARBREAK - (progn (if (NOT (CDR VARBREAK)) (SETQ VARS 'all) - (SETQ VARS (CDR VARBREAK))) - (|breaklet| FN VARS))) - (if (and (symbolp fn) (not (boundp FN)) (not (fboundp FN))) - (progn - (COND ((|isUncompiledMap| FN) - (|sayBrightly| - (format nil - "~A must be compiled before it may be traced -- invoke ~A to compile" - FN FN))) - ((|isInterpOnlyMap| FN) - (|sayBrightly| (format nil - "~A cannot be traced because it is an interpret-only function" FN))) - (T (|sayBrightly| (format nil "~A is not a function" FN)))) - (RETURN NIL))) - (if (and (symbolp fn) (boundp FN) - (|isDomainOrPackage| (SETQ FNVAL (EVAL FN)))) - (RETURN (|spadTrace| FNVAL OPTIONS))) - (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'MASK=)) - (MAKEPROP FN '/TRANSFORM (CADR U))) - (SETQ /TRACENAMES - (COND ((/GETTRACEOPTIONS OPTIONS 'ALIAS) /TRACENAMES) - ((ATOM /TRACENAMES) (LIST FN)) - ((CONS FN /TRACENAMES)))) - (SETQ TRACENAME - (COND ((SETQ U (/GETTRACEOPTIONS OPTIONS 'ALIAS)) - (STRINGIMAGE (CADR U))) - (T - (COND ((AND |$traceNoisely| (NOT VARS) - (NOT (|isSubForRedundantMapName| FN))) - (|sayBrightly| - (LIST '|%b| (|rassocSub| FN |$mapSubNameAlist|) - '|%d| "traced")))) - (STRINGIMAGE FN)))) - (COND (|$fromSpadTrace| - (if MATHTRACE (push (INTERN TRACENAME) |$mathTraceList|)) - (SETQ LETFUNCODE `(SETQ |$currentFunction| ,(MKQ FN))) - (SETQ BEFORE - (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'BEFORE)) - `(progn ,(CADR U) ,LETFUNCODE) - LETFUNCODE))) - (T (SETQ BEFORE - (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'BEFORE)) - (CADR U))))) - (SETQ AFTER (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'AFTER)) (CADR U))) - (SETQ CALLER (/GETTRACEOPTIONS OPTIONS 'CALLER)) - (SETQ FROM_CONDITION - (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'FROM)) - (LIST 'EQ '|#9| (LIST 'QUOTE (CADR U))) - T)) - (SETQ CONDITION - (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'WHEN)) (CADR U) T)) - (SETQ WITHIN_CONDITION T) - (COND ((SETQ U (/GETTRACEOPTIONS OPTIONS 'WITHIN)) - (SETQ G (INTERN (STRCONC (PNAME FN) "/" (PNAME (CADR U))))) - (SET G 0) - (/TRACE-1 - (LIST (CADR U)) - `((WHEN NIL) - (BEFORE (SETQ ,G (1+ ,G))) - (AFTER (SETQ ,G (1- ,G))))) - (SETQ WITHIN_CONDITION `(> ,G 0)))) - (SETQ COUNTNAM - (AND (/GETTRACEOPTIONS OPTIONS 'COUNT) - (INTERN (STRCONC TRACENAME ",COUNT"))) ) - (SETQ COUNT_CONDITION - (COND ((SETQ U (/GETTRACEOPTIONS OPTIONS 'COUNT)) - (SETQ /COUNTLIST (adjoin TRACENAME /COUNTLIST - :test 'equal)) - (if (AND (CDR U) (integerp (CADR U))) - `(cond ((<= ,COUNTNAM ,(CADR U)) t) - (t (/UNTRACE-2 ,(MKQ FN) NIL) NIL)) - t)) - (T T))) - (AND (/GETTRACEOPTIONS OPTIONS 'TIMER) - (SETQ TIMERNAM (INTERN (STRCONC TRACENAME ",TIMER"))) - (SETQ /TIMERLIST (adjoin TRACENAME /TIMERLIST :test 'equal))) - (SETQ DEPTH_CONDITION - (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'DEPTH)) - (if (AND (CDR U) (integerp (CADR U))) - (LIST 'LE 'FUNDEPTH (CADR U)) - (TRACE_OPTION_ERROR 'DEPTH)) - T)) - (SETQ CONDITION - (MKPF - (LIST CONDITION WITHIN_CONDITION FROM_CONDITION COUNT_CONDITION - DEPTH_CONDITION ) - 'AND)) - (SETQ ONLYS (/GETTRACEOPTIONS OPTIONS 'ONLY)) - - ;TRACECODE meaning: - ; 0: Caller (0,1) print caller if 1 - ; 1: Value (0,1) print value if 1 - ; 2...: Arguments (0,...,9) stop if 0; print ith if i; all if 9 - (SETQ TRACECODE - (if (/GETTRACEOPTIONS OPTIONS 'NT) "000" - (PROG (F A V C NL BUF) - (SETQ ONLYS (MAPCAR #'COND-UCASE ONLYS)) - (SETQ F (OR (member 'F ONLYS :test #'eq) - (member 'FULL ONLYS :test #'eq))) - (SETQ A (OR F (member 'A ONLYS :test #'eq) - (member 'ARGS ONLYS :test #'eq))) - (SETQ V (OR F (member 'V ONLYS :test #'eq) - (member 'VALUE ONLYS :test #'eq))) - (SETQ C (OR F (member 'C ONLYS :test #'eq) - (member 'CALLER ONLYS :test #'eq))) - (SETQ NL - (if A '(#\9) - (mapcan #'(lambda (X) - (if (AND (INTEGERP X) - (> X 0) - (< X 9)) - (LIST (FETCHCHAR (STRINGIMAGE X) 0)))) - onlys))) - (if (NOT (OR A V C NL)) - (if Caller (return "119") (return "019"))) - (SETQ NL (APPEND NL '(\0))) - (SETQ BUF (GETSTR 12)) - (SUFFIX (if (or C Caller) #\1 #\0) BUF) - (SUFFIX (if V #\1 #\0) BUF) - (if A (suffix #\9 BUF) - (mapcar #'(lambda (x) (suffix x BUF)) NL)) - (RETURN BUF)))) - (/MONITOR FN TRACECODE BEFORE AFTER CONDITION TIMERNAM - COUNTNAM TRACENAME BREAK ))) - -(DEFUN OPTIONS2UC (L) - (COND ((NOT L) NIL) - ((ATOM (CAR L)) - (|spadThrowBrightly| - (format nil "~A has wrong format for an option" (car L)))) - ((CONS (CONS (LC2UC (CAAR L)) (CDAR L)) (OPTIONS2UC (CDR L)))))) - -(DEFUN COND-UCASE (X) (COND ((INTEGERP X) X) ((UPCASE X)))) - -(DEFUN TRACEOPTIONS (X) - (COND ((NOT X) NIL) - ((EQ (CAR X) '/) X) - ((TRACEOPTIONS (CDR X))))) - -(defmacro |/untrace| (&rest L) `', (/UNTRACE-0 L)) - -(defmacro /UNTRACE (&rest L) `', (/UNTRACE-0 L)) - -(defmacro /U (&rest L) `', (/UNTRACE-0 L)) - -(DEFUN /UNTRACE-0 (L) - (PROG (OPTIONL OPTIONS FNL) - (if (member '? L :test #'eq) (RETURN (OBEY "EXEC NORMEDIT TRACE TELL"))) - (SETQ OPTIONL (/OPTIONS L)) - (SETQ FNL (TRUNCLIST L OPTIONL)) - (SETQ OPTIONS (if OPTIONL (CAR OPTIONL))) - (RETURN (/UNTRACE-1 FNL OPTIONS)))) - -(define-function '|/UNTRACE,0| #'/UNTRACE-0) - -(defun /UNTRACE-1 (L OPTIONS) - (cond - ((NOT L) - (if (ATOM /TRACENAMES) - NIL - (mapcar #'(lambda (u) (/UNTRACE-2 (/UNTRACE-REDUCE U) OPTIONS)) - (APPEND /TRACENAMES NIL)))) - ((mapcar #'(lambda (x) (/UNTRACE-2 X OPTIONS)) L))) - (/TRACEREPLY)) - -(DEFUN /UNTRACE-REDUCE (X) (if (ATOM X) X (first X))) ; (CAR X) is now a domain - -(DEFUN /UNTRACE-2 (X OPTIONS) - (let (u y) - (COND ((AND (|isFunctor| X) (ATOM X)) - (|untraceDomainConstructor| X)) - ((OR (|isDomainOrPackage| (SETQ U X)) - (and (symbolp X) (boundp X) - (|isDomain| (SETQ U (EVAL X))))) - (|spadUntrace| U OPTIONS)) - ((EQCAR OPTIONS 'ALIAS) - (if |$traceNoisely| - (|sayBrightly| (LIST '|%b| (CADR OPTIONS) '|%d| '**untraced))) - (SETQ /TIMERLIST - (REMOVE (STRINGIMAGE (CADR OPTIONS)) /TIMERLIST :test 'equal)) - (SETQ /COUNTLIST - (REMOVE (STRINGIMAGE (CADR OPTIONS)) /COUNTLIST :test 'equal)) - (SETQ |$mathTraceList| - (REMOVE (CADR OPTIONS) |$mathTraceList| :test 'equal)) - (UNEMBED X)) - ((AND (NOT (MEMBER X /TRACENAMES)) - (NOT (|isSubForRedundantMapName| X))) - (|sayBrightly| - (LIST - '|%b| - (|rassocSub| X |$mapSubNameAlist|) - '|%d| - "not traced"))) - (T (SETQ /TRACENAMES (REMOVE X /TRACENAMES :test 'equal)) - (SETQ |$mathTraceList| - (REMOVE (if (STRINGP X) (INTERN X) X) |$mathTraceList|)) - (SETQ |$letAssoc| (DELASC X |$letAssoc|)) - (setq Y (if (IS_GENVAR X) (|devaluate| (EVAL X)) X)) - (SETQ /TIMERLIST (REMOVE (STRINGIMAGE Y) /TIMERLIST :test 'equal)) - (SET (INTERN (STRCONC Y ",TIMER")) 0) - (SETQ /COUNTLIST (REMOVE (STRINGIMAGE Y) /COUNTLIST :test 'equal)) - (SET (INTERN (STRCONC Y ",COUNT")) 0) - (COND ((AND |$traceNoisely| (NOT (|isSubForRedundantMapName| Y))) - (|sayBrightly| - (LIST '|%b| (|rassocSub| Y |$mapSubNameAlist|) - '|%d| "untraced")))) - (UNEMBED X))))) - - ;; the following is called by |clearCache| -(define-function '/UNTRACE\,2 #'/UNTRACE-2) - -(DEFUN MONITOR-PRINVALUE (VAL NAME) - (let (u) - (COND ((setq U (GET NAME '/TRANSFORM)) - (COND - ((EQCAR U '&) - (PRINC "//" CURSTRM) (PRIN1 VAL CURSTRM) (TERPRI CURSTRM)) - (T (PRINC "! " CURSTRM) - (PRIN1 (EVAL (SUBST (MKQ VAL) '* (CAR U))) CURSTRM) - (TERPRI CURSTRM)) )) - (T - (PRINC ": " CURSTRM) - (COND ((NOT (SMALL-ENOUGH VAL)) (|F,PRINT-ONE| VAL CURSTRM)) - (/PRETTY (PRETTYPRINT VAL CURSTRM)) - (T (COND (|$mathTrace| (TERPRI))) - (PRINMATHOR0 VAL CURSTRM))))))) - -(DEFUN MONITOR-BLANKS (N) (PRINC (MAKE-FULL-CVEC N " ") CURSTRM)) - -(DEFUN MONITOR-EVALBEFORE (X) (EVALFUN (MONITOR-EVALTRAN X NIL)) X) - -(DEFUN MONITOR-EVALAFTER (X) (EVALFUN (MONITOR-EVALTRAN X 'T))) - -(DEFUN MONITOR-EVALTRAN (X FG) - (if (HAS_SHARP_VAR X) (MONITOR-EVALTRAN1 X FG) X)) - -(define-function 'MONITOR\,EVALTRAN #'MONITOR-EVALTRAN) - -(DEFUN MONITOR-EVALTRAN1 (X FG) - (let (n) - (COND - ((SETQ N (|isSharpVarWithNum| X)) (MONITOR-GETVALUE N FG)) - ((ATOM X) X) - ((CONS (MONITOR-EVALTRAN1 (CAR X) FG) - (MONITOR-EVALTRAN1 (CDR X) FG)))))) - -(DEFUN HAS_SHARP_VAR (X) - (COND ((AND (ATOM X) (IS_SHARP_VAR X)) 'T) - ((ATOM X) NIL) - ((OR (HAS_SHARP_VAR (CAR X)) (HAS_SHARP_VAR (CDR X)))))) - -(DEFUN IS_SHARP_VAR (X) - (AND (IDENTP X) - (EQL (ELT (PNAME X) 0) #\#) - (INTEGERP (lisp:parse-integer (symbol-name X) :start 1)))) - -(DEFUN MONITOR-GETVALUE (N FG) - (COND ((= N 0) - (if FG - (MKQ /VALUE) - (|spadThrowBrightly| "cannot ask for value before execution"))) - ((= N 9) (MKQ /CALLER)) - ((<= N (SIZE /ARGS)) (MKQ (ELT /ARGS (1- N)))) - ((|spadThrowBrightly| (LIST 'function '|%b| /NAME '|%d| - "does not have" '|%b| N '|%d| "arguments"))))) - -(DEFUN MONITOR-PRINARGS (L CODE /TRANSFORM) - (let (N) - (cond - ((= (digit-char-p (elt CODE 2)) 0) NIL) - ((= (digit-char-p (elt CODE 2)) 9) - (cond - (/TRANSFORM - (mapcar - #'(lambda (x y) - (COND ((EQ Y '*) - (PRINC "\\ " CURSTRM) - (MONITOR-PRINT X CURSTRM)) - ((EQ Y '&) - (PRINC "\\\\" CURSTRM) - (TERPRI CURSTRM) - (PRINT X CURSTRM)) - ((NOT Y) (PRINC "! " CURSTRM)) - (T - (PRINC "! " CURSTRM) - (MONITOR-PRINT - (EVAL (SUBST (MKQ X) '* Y)) CURSTRM)))) - L (cdr /transform))) - (T (PRINC ": " CURSTRM) - (COND ((NOT (ATOM L)) - (if |$mathTrace| (TERPRI CURSTRM)) - (MONITOR-PRINT (CAR L) CURSTRM) (SETQ L (CDR L)))) - (mapcar #'monitor-printrest L)))) - ((do ((istep 2 (+ istep 1)) - (k (maxindex code))) - ((> istep k) nil) - (when (not (= 0 (SETQ N (digit-char-p (elt CODE ISTEP))))) - (PRINC "\\" CURSTRM) - (PRINMATHOR0 N CURSTRM) - (PRINC ": " CURSTRM) - (MONITOR-PRINARGS-1 L N))))))) - -(DEFUN MONITOR-PRINTREST (X) - (COND ((NOT (SMALL-ENOUGH X)) - (PROGN (TERPRI) - (MONITOR-BLANKS (1+ /DEPTH)) - (PRINC "\\" CURSTRM) - (PRINT X CURSTRM))) - ((PROGN (if (NOT |$mathTrace|) (PRINC "\\" CURSTRM)) - (COND (/PRETTY (PRETTYPRINT X CURSTRM)) - ((PRINMATHOR0 X CURSTRM))))))) - -(DEFUN MONITOR-PRINARGS-1 (L N) - (COND ((OR (ATOM L) (LESSP N 1)) NIL) - ((EQ N 1) (MONITOR-PRINT (CAR L) CURSTRM)) - ((MONITOR-PRINARGS-1 (CDR L) (1- N))))) - -(DEFUN MONITOR-PRINT (X CURSTRM) - (COND ((NOT (SMALL-ENOUGH X)) (|F,PRINT-ONE| X CURSTRM)) - (/PRETTY (PRETTYPRINT X CURSTRM)) - ((PRINMATHOR0 X CURSTRM)))) - -(DEFUN PRINMATHOR0 (X CURSTRM) - (if |$mathTrace| (|maprinSpecial| (|outputTran| X) /DEPTH 80) - (PRIN0 X CURSTRM))) - -(DEFUN SMALL-ENOUGH (X) (if /TRACESIZE (SMALL-ENOUGH-COUNT X 0 /TRACESIZE) t)) - -(DEFUN SMALL-ENOUGH-COUNT (X N M) - "Returns number if number of nodes < M otherwise nil." - (COND ((< M N) NIL) - ((VECP X) - (do ((i 0 (1+ i)) (k (maxindex x))) - ((> i k) n) - (if (NOT (SETQ N (SMALL-ENOUGH-COUNT (ELT X I) (1+ N) M))) - (RETURN NIL)))) - ((ATOM X) N) - ((AND (SETQ N (SMALL-ENOUGH-COUNT (CAR X) (1+ N) M)) - (SMALL-ENOUGH-COUNT (CDR X) N M))))) - -(DEFUN /OPTIONS (X) - (COND ((ATOM X) NIL) - ((OR (ATOM (CAR X)) (|isFunctor| (CAAR X))) (/OPTIONS (CDR X))) - (X))) - -(DEFUN /GETOPTION (L OPT) (KDR (/GETTRACEOPTIONS L OPT))) - -(DEFUN /GETTRACEOPTIONS (L OPT) - (COND ((ATOM L) NIL) - ((EQ (KAR (CAR L)) OPT) (CAR L)) - ((/GETTRACEOPTIONS (CDR L) OPT)))) - -(DEFMACRO /TRACELET (&rest L) `', - (PROG (OPTIONL FNL) - (if (member '? L :test #'eq) - (RETURN (OBEY (if (EQ (SYSID) 1) - "EXEC NORMEDIT TRACELET TELL" - "$COPY AZ8F:TRLET.TELL")) )) - (SETQ OPTIONL (/OPTIONS L)) - (SETQ FNL (TRUNCLIST L OPTIONL)) - (RETURN (/TRACELET-1 FNL OPTIONL)))) - -(DEFUN /TRACELET-1 (FNLIST OPTIONL) - (mapcar #'(lambda (x) (/tracelet-2 x optionl)) fnlist) - (/TRACE-1 FNLIST OPTIONL) - (TRACELETREPLY)) - -(DEFUN TRACELETREPLY () - (if (ATOM /TRACELETNAMES) '(none tracelet) - (APPEND /TRACELETNAMES (LIST 'tracelet)))) - -(DEFUN /TRACELET-2 (FN OPTIONL &AUX ($TRACELETFLAG T)) - (/D-1 (CONS FN OPTIONL) 'COMP NIL NIL) - (SETQ /TRACELETNAMES - (if (ATOM /TRACELETNAMES) (LIST FN) (CONS FN /TRACELETNAMES))) - FN) - -(defmacro /TRACE-LET (A B) - `(PROG1 (SPADLET ,A ,B) - . ,(mapcar #'(lambda (x) `(/tracelet-print ',x ,x)) - (if (ATOM A) (LIST A) A)))) - -(defun /TRACELET-PRINT (X Y &AUX (/PRETTY 'T)) - (PRINC (STRCONC (PNAME X) ": ") *terminal-io*) - (MONITOR-PRINT Y *terminal-io*)) - -(defmacro /UNTRACELET (&rest L) `', - (COND - ((NOT L) - (if (ATOM /TRACELETNAMES) NIL (EVAL (CONS '/UNTRACELET /TRACELETNAMES)))) - ((mapcar #'/untracelet-1 L)) - ((TRACELETREPLY)))) - -(DEFUN /UNTRACELET-1 (X) - (COND - ((NOT (MEMBER X /TRACELETNAMES)) - (PROGN (PRINT (STRCONC (PNAME X) " not tracelet")) (TERPRI))) - ((PROGN - (/UNTRACELET-2 X) - (/D-1 (LIST X) 'COMP NIL NIL))))) - -(DEFUN /UNTRACELET-2 (X) - (SETQ /TRACELETNAMES (REMOVE X /TRACELETNAMES)) - (PRINT (STRCONC (PNAME X) " untracelet")) (TERPRI)) - -(defmacro /EMBED (&rest L) `', - (COND ((NOT L) (/EMBEDREPLY)) - ((member '? L :test #'eq) (OBEY "EXEC NORMEDIT EMBED TELL")) - ((EQ 2 (LENGTH L)) (/EMBED-1 (CAR L) (CADR L))) - ((MOAN "IMPROPER USE OF /EMBED")))) - -(defmacro /UNEMBED (&rest L) `', - (COND ((NOT L) - (if (ATOM (EMBEDDED)) NIL - (mapcar #'unembed (embedded))) - (SETQ /TRACENAMES NIL) - (SETQ /EMBEDNAMES NIL)) - ((mapcar #'/unembed-1 L) - (SETQ /TRACENAMES (S- /TRACENAMES L)) )) - (/EMBEDREPLY)) - -(defun /UNEMBED-Q (X) - (COND - ((NOT (MEMBER X /EMBEDNAMES)) - (ERROR (STRCONC (PNAME X) " not embeded"))) - ((PROGN - (SETQ /EMBEDNAMES (REMOVE X /EMBEDNAMES)) - (UNEMBED X))))) - -(defun /UNEMBED-1 (X) - (COND - ((NOT (MEMBER X /EMBEDNAMES)) - (|sayBrightly| (LIST '|%b| (PNAME X) '|%d| "not embeded" '|%l|))) - ((PROGN - (SETQ /EMBEDNAMES (REMOVE X /EMBEDNAMES)) - (|sayBrightly| (LIST '|%b| (PNAME X) '|%d| "unembeded" '|%l|)) - (UNEMBED X))) )) - - - -(defun /MONITOR (&rest G5) - (PROG (G1 G4 TRACECODE BEFORE AFTER CONDITION - TIMERNAM COUNTNAM TRACENAME BREAK) - (dcq (G1 TRACECODE BEFORE AFTER CONDITION TIMERNAM COUNTNAM TRACENAME BREAK) G5) - (SETQ G4 (macro-function G1)) - (SETQ TRACECODE (OR TRACECODE "119")) - (if COUNTNAM (SET COUNTNAM 0)) - (if TIMERNAM (SET TIMERNAM 0)) - (EMBED - G1 - (LIST - (if G4 'MLAMBDA 'LAMBDA) - '(&rest G6) - (LIST - '/MONITORX - (QUOTE G6) - G1 - (LIST - 'QUOTE - (LIST - TRACENAME (if G4 'MACRO) TRACECODE - COUNTNAM TIMERNAM BEFORE AFTER - CONDITION BREAK |$tracedModemap| ''T))))) - (RETURN G1))) - -(defvar |$TraceFlag| t) - -(defun /MONITORX (/ARGS FUNCT OPTS &AUX NAME TYPE TRACECODE COUNTNAM TIMERNAM - BEFORE AFTER CONDITION BREAK TRACEDMODEMAP - BREAKCONDITION) - (declare (special /ARGS)) - (DCQ (NAME TYPE TRACECODE COUNTNAM TIMERNAM BEFORE AFTER CONDITION BREAK TRACEDMODEMAP BREAKCONDITION) OPTS) - (|stopTimer|) - (PROG (C V A NAME1 CURSTRM EVAL_TIME INIT_TIME NOT_TOP_LEVEL - (/DEPTH (if (and (BOUNDP '/DEPTH) (numberp /depth)) (1+ /DEPTH) 1)) - (|depthAlist| (if (BOUNDP '|depthAlist|) (COPY-TREE |depthAlist|) NIL)) - FUNDEPTH NAMEID YES (|$tracedSpadModemap| TRACEDMODEMAP) (|$mathTrace| NIL) - /caller /name /value /breakcondition curdepth) - (declare (special curstrm /depth fundepth |$tracedSpadModemap| |$mathTrace| - /caller /name /value /breakcondition |depthAlist|)) - (SETQ /NAME NAME) - (SETQ NAME1 (PNAME (|rassocSub| (INTERN NAME) |$mapSubNameAlist|))) - (SETQ /BREAKCONDITION BREAKCONDITION) - (SETQ /CALLER (|rassocSub| (WHOCALLED 6) |$mapSubNameAlist|)) - (if (NOT (STRINGP TRACECODE)) - (MOAN "set TRACECODE to \'1911\' and restart")) - (SETQ C (digit-char-p (elt TRACECODE 0)) - V (digit-char-p (elt TRACECODE 1)) - A (digit-char-p (elt TRACECODE 2))) - (if COUNTNAM (SET COUNTNAM (1+ (EVAL COUNTNAM)))) - (SETQ NAMEID (INTERN NAME)) - (SETQ NOT_TOP_LEVEL (ASSOC NAMEID |depthAlist| :test #'eq)) - (if (NOT NOT_TOP_LEVEL) - (SETQ |depthAlist| (CONS (CONS NAMEID 1) |depthAlist|)) - (RPLACD NOT_TOP_LEVEL (1+ (CDR NOT_TOP_LEVEL)))) - (SETQ FUNDEPTH (CDR (ASSOC NAMEID |depthAlist| :test #'eq))) - (SETQ CONDITION (MONITOR-EVALTRAN CONDITION NIL)) - (SETQ YES (EVALFUN CONDITION)) - (if (member NAMEID |$mathTraceList| :test #'eq) - (SETQ |$mathTrace| T)) - (if (AND YES |$TraceFlag|) - (PROG (|$TraceFlag|) - (SETQ CURSTRM *TERMINAL-IO*) - (if (EQUAL TRACECODE "000") (RETURN NIL)) - (TAB 0 CURSTRM) - (MONITOR-BLANKS (1- /DEPTH)) - (PRIN0 FUNDEPTH CURSTRM) - (|sayBrightlyNT| (LIST "exit " '|%b| NAME1 '|%d|) CURSTRM) - (COND (TIMERNAM - (|sayBrightlyNT| '\( CURSTRM) - (|sayBrightlyNT| (/ EVAL_TIME 60.0) CURSTRM) - (|sayBrightlyNT| '\ sec\) CURSTRM) )) - (if (EQ 1 V) - (MONITOR-PRINVALUE - (|coerceTraceFunValue2E| - (INTERN NAME1) (INTERN NAME) /VALUE) - (INTERN NAME1))) - (if (NOT |$mathTrace|) (TERPRI CURSTRM)) - SKIP)) - (if (member '|after| BREAK :test #'eq) - (|break| (LIST "Break on exiting" '|%b| NAME1 '|%d| ":"))) - (|startTimer|) - (RETURN /VALUE))) - -; Functions to run a timer for tracing -; It avoids timing the tracing function itself by turning the timer -; on and off - -(defvar |$oldTime| 0) -(defvar |$timerOn| t) -(defvar $delay 0) - -(defun |startTimer| () - (SETQ $delay (PLUS $delay (DIFFERENCE (TEMPUS-FUGIT) |$oldTime|))) - (SETQ |$timerOn| 'T) - (|clock|)) - -(defun |stopTimer| () (SETQ |$oldTime| (TEMPUS-FUGIT) |$timerOn| NIL) (|clock|)) - -(defun |clock| () - (if |$timerOn| (- (TEMPUS-FUGIT) $delay) (- |$oldTime| $delay))) - -; Functions to trace/untrace a BPI; use as follows: -; To trace a BPI-value , evaluate (SETQ (BPITRACE )) -; To later untrace , evaluate (BPITRACE ) - -(defun PAIRTRACE (PAIR ALIAS) - (RPLACA PAIR (BPITRACE (CAR PAIR) ALIAS )) NIL) - -(defun BPITRACE (BPI ALIAS &optional OPTIONS) - (SETQ NEWNAME (GENSYM)) - (IF (identp bpi) (setq bpi (symbol-function bpi))) - (SET NEWNAME BPI) - (SETF (symbol-function NEWNAME) BPI) - (/TRACE-0 (APPEND (LIST NEWNAME (LIST 'ALIAS ALIAS)) OPTIONS)) - NEWNAME) - -(defun BPIUNTRACE (X ALIAS) (/UNTRACE-0 (LIST X (LIST 'ALIAS ALIAS)))) - -(defun SPADSYSNAMEP (STR) - (let (n i j) - (AND (SETQ N (MAXINDEX STR)) - (SETQ I (position #\. STR :start 1)) - (SETQ J (position #\, STR :start (1+ I))) - (do ((k (1+ j) (1+ k))) - ((> k n) t) - (if (not (digitp (elt str k))) (return nil)))))) - -; ********************************************************************** -; Utility functions for Tracing Package -; ********************************************************************** - -(MAKEPROP '|coerce| '/TRANSFORM '(& & *)) -(MAKEPROP '|comp| '/TRANSFORM '(& * * &)) -(MAKEPROP '|compIf| '/TRANSFORM '(& * * &)) - -; by having no transform for the 3rd argument, it is simply not printed - -(MAKEPROP '|compFormWithModemap| '/TRANSFORM '(& * * & *)) - -(defun UNVEC (X) - (COND ((REFVECP X) (CONS '$ (VEC_TO_TREE X))) - ((ATOM X) X) - ((CONS (UNVEC (CAR X)) (UNVEC (CDR X)))))) - -(defun DROPENV (X) (AND X (LIST (CAR X) (CADR X)))) - -(defun SHOWBIND (E) - (do ((v e (cdr v)) - (llev 1 (1+ llev))) - ((not v)) - (PRINT (LIST "LAMBDA LEVEL" LLEV)) - (do ((w (car v) (cdr w)) - (clev 1 (1+ clev))) - ((not w)) - (PRINT (LIST "CONTOUR LEVEL" CLEV)) - (PRINT (mapcar #'car (car W)))))) - -#+:CCL -(defun break (&rest ignore) (lisp-break ignore) (lisp::unwind)) - - -#+:CCL -(defun lisp-break (&rest ignore) - (prog (prompt ifile ofile u v) - (setq ifile (rds *debug-io*)) - (setq ofile (wrs *debug-io*)) - (setq prompt (setpchar "Break loop (:? for help)> ")) -top (setq u (read)) - (cond - ((equal u ':x) (go exit)) - ((equal u ':q) - (progn (lisp::enable-backtrace nil) - (princ "Backtrace now disabled") - (terpri))) - ((equal u ':v) - (progn (lisp::enable-backtrace t) - (princ "Backtrace now enabled") - (terpri))) - ((equal u ':?) - (progn - (princ ":Q disables backtrace") - (terpri) - (princ ":V enables backtrace") - (terpri) - (princ ":X exits from break loop") - (terpri) - (princ "else enter LISP expressions for evaluation") - (terpri))) - ((equal u #\eof) - (go exit)) - (t (progn - (setq v (errorset u nil nil)) - (if (listp v) (progn (princ "=> ") (prinl (car v)) (terpri))))) ) - (go top) -exit (rds ifile) - (wrs ofile) - (setpchar prompt) - (return nil))) - -(defun lisp-break-from-axiom (&rest ignore) - (boot::|handleLispBreakLoop| boot::|$BreakMode|)) -#+:CCL (setq lisp:*break-loop* 'boot::lisp-break-from-axiom) - -<> - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/def.lisp b/src/interp/def.lisp index 799034ee..146d65de 100644 --- a/src/interp/def.lisp +++ b/src/interp/def.lisp @@ -1,5 +1,7 @@ ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are diff --git a/src/interp/fname.lisp b/src/interp/fname.lisp index 1d54a0d9..926aba92 100644 --- a/src/interp/fname.lisp +++ b/src/interp/fname.lisp @@ -1,5 +1,7 @@ ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are diff --git a/src/interp/fnewmeta.lisp b/src/interp/fnewmeta.lisp new file mode 100644 index 00000000..1abd09dc --- /dev/null +++ b/src/interp/fnewmeta.lisp @@ -0,0 +1,991 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + +;; % Scratchpad II Boot Language Grammar, Common Lisp Version +;; % IBM Thomas J. Watson Research Center +;; % Summer, 1986 +;; % +;; % NOTE: Substantially different from VM/LISP version, due to +;; % different parser and attempt to render more within META proper. + +;; .META(New NewExpr Process) +;; .PACKAGE 'BOOT' +;; .DECLARE(tmptok TOK ParseMode DEFINITION_NAME LABLASOC) +;; .PREFIX 'PARSE-' + +;; NewExpr: =')' .(processSynonyms) Command +;; / .(SETQ DEFINITION_NAME (CURRENT-SYMBOL)) Statement ; + +;; Command: ')' SpecialKeyWord SpecialCommand +() ; + +;; SpecialKeyWord: =(MATCH-CURRENT-TOKEN "IDENTIFIER) +;; .(SETF (TOKEN-SYMBOL (CURRENT-TOKEN)) (unAbbreviateKeyword (CURRENT-SYMBOL))) ; + +;; SpecialCommand: 'show' <'?' / Expression>! +(show #1) CommandTail +;; / ?(MEMBER (CURRENT-SYMBOL) \$noParseCommands) +;; .(FUNCALL (CURRENT-SYMBOL)) +;; / ?(MEMBER (CURRENT-SYMBOL) \$tokenCommands) TokenList +;; TokenCommandTail +;; / PrimaryOrQM* CommandTail ; + +;; TokenList: (^?(isTokenDelimiter) +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN))* ; + +;; TokenCommandTail: +;; ! ?(atEndOfLine) +(#2 -#1) .(systemCommand #1) ; + +;; TokenOption: ')' TokenList ; + +;; CommandTail: ! ?(atEndOfLine) +(#2 -#1) .(systemCommand #1) ; + +;; PrimaryOrQM: '?' +\? / Primary ; + +;; Option: ')' PrimaryOrQM* ; + +;; Statement: Expr{0} <(',' Expr{0})* +(Series #2 -#1)>; + +;; InfixWith: With +(Join #2 #1) ; + +;; With: 'with' Category +(with #1) ; + +;; Category: 'if' Expression 'then' Category <'else' Category>! +(if #3 #2 #1) +;; / '(' Category <(';' Category)*>! ')' +(CATEGORY #2 -#1) +;; / .(SETQ $1 (LINE-NUMBER CURRENT-LINE)) Application +;; ( ':' Expression +(Signature #2 #1) +;; .(recordSignatureDocumentation ##1 $1) +;; / +(Attribute #1) +;; .(recordAttributeDocumentation ##1 $1)); + +;; Expression: Expr{(PARSE-rightBindingPowerOf (MAKE-SYMBOL-OF PRIOR-TOKEN) ParseMode)} +;; +#1 ; + +;; Import: 'import' Expr{1000} <(',' Expr{1000})*>! +(import #2 -#1) ; + +;; Infix: =TRUE +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) +;; Expression +(#2 #2 #1) ; + +;; Prefix: =TRUE +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) +;; Expression +(#2 #1) ; + +;; Suffix: +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) +(#1 #1) ; + +;; TokTail: ?(AND (NULL \$BOOT) (EQ (CURRENT-SYMBOL) "\$) +;; (OR (ALPHA-CHAR-P (CURRENT-CHAR)) +;; (CHAR-EQ (CURRENT-CHAR) '$') +;; (CHAR-EQ (CURRENT-CHAR) '\%') +;; (CHAR-EQ (CURRENT-CHAR) '('))) +;; .(SETQ $1 (COPY-TOKEN PRIOR-TOKEN)) Qualification +;; .(SETQ PRIOR-TOKEN $1) ; + +;; Qualification: '$' Primary1 +=(dollarTran #1 #1) ; + +;; SemiColon: ';' (Expr{82} / + \/throwAway) +(\; #2 #1) ; + +;; Return: 'return' Expression +(return #1) ; + +;; Exit: 'exit' (Expression / +\$NoValue) +(exit #1) ; + +;; Leave: 'leave' ( Expression / +\$NoValue ) +;; ('from' Label +(leaveFrom #1 #1) / +(leave #1)) ; + +;; Seg: GliphTok{"\.\.} ! +(SEGMENT #2 #1) ; + +;; Conditional: 'if' Expression 'then' Expression <'else' ElseClause>! +;; +(if #3 #2 #1) ; + +;; ElseClause: ?(EQ (CURRENT-SYMBOL) "if) Conditional / Expression ; + +;; Loop: Iterator* 'repeat' Expr{110} +(REPEAT -#2 #1) +;; / 'repeat' Expr{110} +(REPEAT #1) ; + +;; Iterator: 'for' Primary 'in' Expression +;; ( 'by' Expr{200} +(INBY #3 #2 #1) / +(IN #2 #1) ) +;; < '\|' Expr{111} +(\| #1) > +;; / 'while' Expr{190} +(WHILE #1) +;; / 'until' Expr{190} +(UNTIL #1) ; + +;; Expr{RBP}: NudPart{RBP} * +#1; + +;; LabelExpr: Label Expr{120} +(LABEL #2 #1) ; + +;; Label: '<<' Name '>>' ; + +;; LedPart{RBP}: Operation{"Led RBP} +#1; + +;; NudPart{RBP}: (Operation{"Nud RBP} / Reduction / Form) +#1 ; + +;; Operation{ParseMode RBP}: +;; ^?(MATCH-CURRENT-TOKEN "IDENTIFIER) +;; ?(GETL (SETQ tmptok (CURRENT-SYMBOL)) ParseMode) +;; ?(LT RBP (PARSE-leftBindingPowerOf tmptok ParseMode)) +;; .(SETQ RBP (PARSE-rightBindingPowerOf tmptok ParseMode)) +;; getSemanticForm{tmptok ParseMode (ELEMN (GETL tmptok ParseMode) 5 NIL)} ; + +;; % Binding powers stored under the Led and Red properties of an operator +;; % are set up by the file BOTTOMUP.LISP. The format for a Led property +;; % is , and the same for a Nud, except that +;; % it may also have a fourth component . ELEMN attempts to +;; % get the Nth indicator, counting from 1. + +;; leftBindingPowerOf{X IND}: =(LET ((Y (GETL X IND))) (IF Y (ELEMN Y 3 0) 0)) ; + +;; rightBindingPowerOf{X IND}: =(LET ((Y (GETL X IND))) (IF Y (ELEMN Y 4 105) 105)) ; + +;; getSemanticForm{X IND Y}: +;; ?(AND Y (EVAL Y)) / ?(EQ IND "Nud) Prefix / ?(EQ IND "Led) Infix ; + + +;; Reduction: ReductionOp Expr{1000} +(Reduce #2 #1) ; + +;; ReductionOp: ?(AND (GETL (CURRENT-SYMBOL) "Led) +;; (MATCH-NEXT-TOKEN "SPECIAL-CHAR (CODE-CHAR 47))) % Forgive me! +;; +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) .(ADVANCE-TOKEN) ; + +;; Form: 'iterate' < 'from' Label +(#1) >! +(iterate -#1) +;; / 'yield' Application +(yield #1) +;; / Application ; + +;; Application: Primary * ; + +;; Selector: ?NONBLANK ?(EQ (CURRENT-SYMBOL) "\.) ?(CHAR-NE (CURRENT-CHAR) "\ ) +;; '.' PrimaryNoFloat (=\$BOOT +(ELT #2 #1)/ +(#2 #1)) +;; / (Float /'.' Primary) (=\$BOOT +(ELT #2 #1)/ +(#2 #1)); + +;; PrimaryNoFloat: Primary1 ; + +;; Primary: Float /PrimaryNoFloat ; + +;; Primary1: VarForm <=(AND NONBLANK (EQ (CURRENT-SYMBOL) "\()) Primary1 +(#2 #1)> +;; /Quad +;; /String +;; /IntegerTok +;; /FormalParameter +;; /='\'' (?\$BOOT Data / '\'' Expr{999} +(QUOTE #1)) +;; /Sequence +;; /Enclosure ; + +;; Float: FloatBase (?NONBLANK FloatExponent / +0) +=(MAKE-FLOAT #4 #2 #2 #1) ; + +;; FloatBase: ?(FIXP (CURRENT-SYMBOL)) ?(CHAR-EQ (CURRENT-CHAR) '.') +;; ?(CHAR-NE (NEXT-CHAR) '.') +;; IntegerTok FloatBasePart +;; /?(FIXP (CURRENT-SYMBOL)) ?(CHAR-EQ (CHAR-UPCASE (CURRENT-CHAR)) "E) +;; IntegerTok +0 +0 +;; /?(DIGITP (CURRENT-CHAR)) ?(EQ (CURRENT-SYMBOL) "\.) +;; +0 FloatBasePart ; + +;; FloatBasePart: '.' +;; (?(DIGITP (CURRENT-CHAR)) +=(TOKEN-NONBLANK (CURRENT-TOKEN)) IntegerTok +;; / +0 +0); + + +;; FloatExponent: =(AND (MEMBER (CURRENT-SYMBOL) "(E e)) +;; (FIND (CURRENT-CHAR) '+-')) +;; .(ADVANCE-TOKEN) +;; (IntegerTok/'+' IntegerTok/'-' IntegerTok +=(MINUS #1)/+0) +;; /?(IDENTP (CURRENT-SYMBOL)) =(SETQ $1 (FLOATEXPID (CURRENT-SYMBOL))) +;; .(ADVANCE-TOKEN) +=$1 ; + +;; Enclosure: '(' ( Expr{6} ')' / ')' +(Tuple) ) +;; / '{' ( Expr{6} '}' +(brace (construct #1)) / '}' +(brace)) ; + +;; IntegerTok: NUMBER ; + +;; FloatTok: NUMBER +=(IF \$BOOT #1 (BFP- #1)) ; + +;; FormalParameter: FormalParameterTok ; + +;; FormalParameterTok: ARGUMENT-DESIGNATOR ; + +;; Quad: '$' +\$ / ?\$BOOT GliphTok{"\.} +\. ; + +;; String: SPADSTRING ; + +;; VarForm: Name +#1 ; + +;; Scripts: ?NONBLANK '[' ScriptItem ']' ; + +;; ScriptItem: Expr{90} <(';' ScriptItem)* +(\; #2 -#1)> +;; / ';' ScriptItem +(PrefixSC #1) ; + +;; Name: IDENTIFIER +#1 ; + +;; Data: .(SETQ LABLASOC NIL) Sexpr +(QUOTE =(TRANSLABEL #1 LABLASOC)) ; + +;; Sexpr: .(ADVANCE-TOKEN) Sexpr1 ; + +;; Sexpr1: AnyId +;; < NBGliphTok{"\=} Sexpr1 +;; .(SETQ LABLASOC (CONS (CONS #2 ##1) LABLASOC))> +;; / '\'' Sexpr1 +(QUOTE #1) +;; / IntegerTok +;; / '-' IntegerTok +=(MINUS #1) +;; / String +;; / '<' ! '>' +=(LIST2VEC #1) +;; / '(' >! ')' ; + +;; NBGliphTok{tok}: ?(AND (MATCH-CURRENT-TOKEN "GLIPH tok) NONBLANK) +;; .(ADVANCE-TOKEN) ; + +;; GliphTok{tok}: ?(MATCH-CURRENT-TOKEN "GLIPH tok) .(ADVANCE-TOKEN) ; + +;; AnyId: IDENTIFIER +;; / (='$' +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) / KEYWORD) ; + +;; Sequence: OpenBracket Sequence1 ']' +;; / OpenBrace Sequence1 '}' +(brace #1) ; + +;; Sequence1: (Expression +(#2 #1) / +(#1)) ; + +;; OpenBracket: =(EQ (getToken (SETQ $1 (CURRENT-SYMBOL))) "\[ ) +;; (=(EQCAR $1 "elt) +(elt =(CADR $1) construct) +;; / +construct) .(ADVANCE-TOKEN) ; + +;; OpenBrace: =(EQ (getToken (SETQ $1 (CURRENT-SYMBOL))) "\{ ) +;; (=(EQCAR $1 "elt) +(elt =(CADR $1) brace) +;; / +construct) .(ADVANCE-TOKEN) ; + +;; IteratorTail: ('repeat' ! / Iterator*) ; + +;; .FIN ; + + + +(IMPORT-MODULE "parsing") +(IN-PACKAGE "BOOT" ) + + +(DEFPARAMETER |tmptok| NIL) +(DEFPARAMETER TOK NIL) +(DEFPARAMETER |ParseMode| NIL) +(DEFPARAMETER DEFINITION_NAME NIL) +(DEFPARAMETER LABLASOC NIL) + +(defun |isTokenDelimiter| () + (MEMBER (CURRENT-SYMBOL) '(\) END\_UNIT NIL))) + + +(DEFUN |PARSE-NewExpr| () + (OR (AND (MATCH-STRING ")") (ACTION (|processSynonyms|)) + (MUST (|PARSE-Command|))) + (AND (ACTION (SETQ DEFINITION_NAME (CURRENT-SYMBOL))) + (|PARSE-Statement|)))) + + +(DEFUN |PARSE-Command| () + (AND (MATCH-ADVANCE-STRING ")") (MUST (|PARSE-SpecialKeyWord|)) + (MUST (|PARSE-SpecialCommand|)) + (PUSH-REDUCTION '|PARSE-Command| NIL))) + + +(DEFUN |PARSE-SpecialKeyWord| () + (AND (MATCH-CURRENT-TOKEN 'IDENTIFIER) + (ACTION (SETF (TOKEN-SYMBOL (CURRENT-TOKEN)) + (|unAbbreviateKeyword| (CURRENT-SYMBOL)))))) + + +(DEFUN |PARSE-SpecialCommand| () + (OR (AND (MATCH-ADVANCE-STRING "show") + (BANG FIL_TEST + (OPTIONAL + (OR (MATCH-ADVANCE-STRING "?") + (|PARSE-Expression|)))) + (PUSH-REDUCTION '|PARSE-SpecialCommand| + (CONS '|show| (CONS (POP-STACK-1) NIL))) + (MUST (|PARSE-CommandTail|))) + (AND (MEMBER (CURRENT-SYMBOL) |$noParseCommands|) + (ACTION (FUNCALL (CURRENT-SYMBOL)))) + (AND (MEMBER (CURRENT-SYMBOL) |$tokenCommands|) + (|PARSE-TokenList|) (MUST (|PARSE-TokenCommandTail|))) + (AND (STAR REPEATOR (|PARSE-PrimaryOrQM|)) + (MUST (|PARSE-CommandTail|))))) + + +(DEFUN |PARSE-TokenList| () + (STAR REPEATOR + (AND (NOT (|isTokenDelimiter|)) + (PUSH-REDUCTION '|PARSE-TokenList| (CURRENT-SYMBOL)) + (ACTION (ADVANCE-TOKEN))))) + + +(DEFUN |PARSE-TokenCommandTail| () + (AND (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-TokenOption|)))) + (|atEndOfLine|) + (PUSH-REDUCTION '|PARSE-TokenCommandTail| + (CONS (POP-STACK-2) (APPEND (POP-STACK-1) NIL))) + (ACTION (|systemCommand| (POP-STACK-1))))) + + +(DEFUN |PARSE-TokenOption| () + (AND (MATCH-ADVANCE-STRING ")") (MUST (|PARSE-TokenList|)))) + + +(DEFUN |PARSE-CommandTail| () + (AND (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-Option|)))) + (|atEndOfLine|) + (PUSH-REDUCTION '|PARSE-CommandTail| + (CONS (POP-STACK-2) (APPEND (POP-STACK-1) NIL))) + (ACTION (|systemCommand| (POP-STACK-1))))) + + +(DEFUN |PARSE-PrimaryOrQM| () + (OR (AND (MATCH-ADVANCE-STRING "?") + (PUSH-REDUCTION '|PARSE-PrimaryOrQM| '?)) + (|PARSE-Primary|))) + + +(DEFUN |PARSE-Option| () + (AND (MATCH-ADVANCE-STRING ")") + (MUST (STAR REPEATOR (|PARSE-PrimaryOrQM|))))) + + +(DEFUN |PARSE-Statement| () + (AND (|PARSE-Expr| 0) + (OPTIONAL + (AND (STAR REPEATOR + (AND (MATCH-ADVANCE-STRING ",") + (MUST (|PARSE-Expr| 0)))) + (PUSH-REDUCTION '|PARSE-Statement| + (CONS '|Series| + (CONS (POP-STACK-2) + (APPEND (POP-STACK-1) NIL)))))))) + + +(DEFUN |PARSE-InfixWith| () + (AND (|PARSE-With|) + (PUSH-REDUCTION '|PARSE-InfixWith| + (CONS '|Join| (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-With| () + (AND (MATCH-ADVANCE-STRING "with") (MUST (|PARSE-Category|)) + (PUSH-REDUCTION '|PARSE-With| + (CONS '|with| (CONS (POP-STACK-1) NIL))))) + + +(DEFUN |PARSE-Category| () + (PROG (G1) + (RETURN + (OR (AND (MATCH-ADVANCE-STRING "if") (MUST (|PARSE-Expression|)) + (MUST (MATCH-ADVANCE-STRING "then")) + (MUST (|PARSE-Category|)) + (BANG FIL_TEST + (OPTIONAL + (AND (MATCH-ADVANCE-STRING "else") + (MUST (|PARSE-Category|))))) + (PUSH-REDUCTION '|PARSE-Category| + (CONS '|if| + (CONS (POP-STACK-3) + (CONS (POP-STACK-2) + (CONS (POP-STACK-1) NIL)))))) + (AND (MATCH-ADVANCE-STRING "(") (MUST (|PARSE-Category|)) + (BANG FIL_TEST + (OPTIONAL + (STAR REPEATOR + (AND (MATCH-ADVANCE-STRING ";") + (MUST (|PARSE-Category|)))))) + (MUST (MATCH-ADVANCE-STRING ")")) + (PUSH-REDUCTION '|PARSE-Category| + (CONS 'CATEGORY + (CONS (POP-STACK-2) + (APPEND (POP-STACK-1) NIL))))) + (AND (ACTION (SETQ G1 (LINE-NUMBER CURRENT-LINE))) + (|PARSE-Application|) + (MUST (OR (AND (MATCH-ADVANCE-STRING ":") + (MUST (|PARSE-Expression|)) + (PUSH-REDUCTION '|PARSE-Category| + (CONS '|Signature| + (CONS (POP-STACK-2) + (CONS (POP-STACK-1) NIL)))) + (ACTION (|recordSignatureDocumentation| + (NTH-STACK 1) G1))) + (AND (PUSH-REDUCTION '|PARSE-Category| + (CONS '|Attribute| + (CONS (POP-STACK-1) NIL))) + (ACTION (|recordAttributeDocumentation| + (NTH-STACK 1) G1)))))))))) + + +(DEFUN |PARSE-Expression| () + (AND (|PARSE-Expr| + (|PARSE-rightBindingPowerOf| (MAKE-SYMBOL-OF PRIOR-TOKEN) + |ParseMode|)) + (PUSH-REDUCTION '|PARSE-Expression| (POP-STACK-1)))) + + +(DEFUN |PARSE-Import| () + (AND (MATCH-ADVANCE-STRING "import") (MUST (|PARSE-Expr| 1000)) + (BANG FIL_TEST + (OPTIONAL + (STAR REPEATOR + (AND (MATCH-ADVANCE-STRING ",") + (MUST (|PARSE-Expr| 1000)))))) + (PUSH-REDUCTION '|PARSE-Import| + (CONS '|import| + (CONS (POP-STACK-2) (APPEND (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Infix| () + (AND (PUSH-REDUCTION '|PARSE-Infix| (CURRENT-SYMBOL)) + (ACTION (ADVANCE-TOKEN)) (OPTIONAL (|PARSE-TokTail|)) + (MUST (|PARSE-Expression|)) + (PUSH-REDUCTION '|PARSE-Infix| + (CONS (POP-STACK-2) + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Prefix| () + (AND (PUSH-REDUCTION '|PARSE-Prefix| (CURRENT-SYMBOL)) + (ACTION (ADVANCE-TOKEN)) (OPTIONAL (|PARSE-TokTail|)) + (MUST (|PARSE-Expression|)) + (PUSH-REDUCTION '|PARSE-Prefix| + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL))))) + + +(DEFUN |PARSE-Suffix| () + (AND (PUSH-REDUCTION '|PARSE-Suffix| (CURRENT-SYMBOL)) + (ACTION (ADVANCE-TOKEN)) (OPTIONAL (|PARSE-TokTail|)) + (PUSH-REDUCTION '|PARSE-Suffix| + (CONS (POP-STACK-1) (CONS (POP-STACK-1) NIL))))) + + +(DEFUN |PARSE-TokTail| () + (PROG (G1) + (RETURN + (AND (NULL $BOOT) (EQ (CURRENT-SYMBOL) '$) + (OR (ALPHA-CHAR-P (CURRENT-CHAR)) + (CHAR-EQ (CURRENT-CHAR) "$") + (CHAR-EQ (CURRENT-CHAR) "%") + (CHAR-EQ (CURRENT-CHAR) "(")) + (ACTION (SETQ G1 (COPY-TOKEN PRIOR-TOKEN))) + (|PARSE-Qualification|) (ACTION (SETQ PRIOR-TOKEN G1)))))) + + +(DEFUN |PARSE-Qualification| () + (AND (MATCH-ADVANCE-STRING "$") (MUST (|PARSE-Primary1|)) + (PUSH-REDUCTION '|PARSE-Qualification| + (|dollarTran| (POP-STACK-1) (POP-STACK-1))))) + + +(DEFUN |PARSE-SemiColon| () + (AND (MATCH-ADVANCE-STRING ";") + (MUST (OR (|PARSE-Expr| 82) + (PUSH-REDUCTION '|PARSE-SemiColon| '|/throwAway|))) + (PUSH-REDUCTION '|PARSE-SemiColon| + (CONS '|;| (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Return| () + (AND (MATCH-ADVANCE-STRING "return") (MUST (|PARSE-Expression|)) + (PUSH-REDUCTION '|PARSE-Return| + (CONS '|return| (CONS (POP-STACK-1) NIL))))) + + +(DEFUN |PARSE-Exit| () + (AND (MATCH-ADVANCE-STRING "exit") + (MUST (OR (|PARSE-Expression|) + (PUSH-REDUCTION '|PARSE-Exit| '|$NoValue|))) + (PUSH-REDUCTION '|PARSE-Exit| + (CONS '|exit| (CONS (POP-STACK-1) NIL))))) + + +(DEFUN |PARSE-Leave| () + (AND (MATCH-ADVANCE-STRING "leave") + (MUST (OR (|PARSE-Expression|) + (PUSH-REDUCTION '|PARSE-Leave| '|$NoValue|))) + (MUST (OR (AND (MATCH-ADVANCE-STRING "from") + (MUST (|PARSE-Label|)) + (PUSH-REDUCTION '|PARSE-Leave| + (CONS '|leaveFrom| + (CONS (POP-STACK-1) + (CONS (POP-STACK-1) NIL))))) + (PUSH-REDUCTION '|PARSE-Leave| + (CONS '|leave| (CONS (POP-STACK-1) NIL))))))) + + +(DEFUN |PARSE-Seg| () + (AND (|PARSE-GliphTok| '|..|) + (BANG FIL_TEST (OPTIONAL (|PARSE-Expression|))) + (PUSH-REDUCTION '|PARSE-Seg| + (CONS 'SEGMENT + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Conditional| () + (AND (MATCH-ADVANCE-STRING "if") (MUST (|PARSE-Expression|)) + (MUST (MATCH-ADVANCE-STRING "then")) (MUST (|PARSE-Expression|)) + (BANG FIL_TEST + (OPTIONAL + (AND (MATCH-ADVANCE-STRING "else") + (MUST (|PARSE-ElseClause|))))) + (PUSH-REDUCTION '|PARSE-Conditional| + (CONS '|if| + (CONS (POP-STACK-3) + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL))))))) + + +(DEFUN |PARSE-ElseClause| () + (OR (AND (EQ (CURRENT-SYMBOL) '|if|) (|PARSE-Conditional|)) + (|PARSE-Expression|))) + + +(DEFUN |PARSE-Loop| () + (OR (AND (STAR REPEATOR (|PARSE-Iterator|)) + (MUST (MATCH-ADVANCE-STRING "repeat")) + (MUST (|PARSE-Expr| 110)) + (PUSH-REDUCTION '|PARSE-Loop| + (CONS 'REPEAT + (APPEND (POP-STACK-2) (CONS (POP-STACK-1) NIL))))) + (AND (MATCH-ADVANCE-STRING "repeat") (MUST (|PARSE-Expr| 110)) + (PUSH-REDUCTION '|PARSE-Loop| + (CONS 'REPEAT (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Iterator| () + (OR (AND (MATCH-ADVANCE-STRING "for") (MUST (|PARSE-Primary|)) + (MUST (MATCH-ADVANCE-STRING "in")) + (MUST (|PARSE-Expression|)) + (MUST (OR (AND (MATCH-ADVANCE-STRING "by") + (MUST (|PARSE-Expr| 200)) + (PUSH-REDUCTION '|PARSE-Iterator| + (CONS 'INBY + (CONS (POP-STACK-3) + (CONS (POP-STACK-2) + (CONS (POP-STACK-1) NIL)))))) + (PUSH-REDUCTION '|PARSE-Iterator| + (CONS 'IN + (CONS (POP-STACK-2) + (CONS (POP-STACK-1) NIL)))))) + (OPTIONAL + (AND (MATCH-ADVANCE-STRING "|") + (MUST (|PARSE-Expr| 111)) + (PUSH-REDUCTION '|PARSE-Iterator| + (CONS '|\|| (CONS (POP-STACK-1) NIL)))))) + (AND (MATCH-ADVANCE-STRING "while") (MUST (|PARSE-Expr| 190)) + (PUSH-REDUCTION '|PARSE-Iterator| + (CONS 'WHILE (CONS (POP-STACK-1) NIL)))) + (AND (MATCH-ADVANCE-STRING "until") (MUST (|PARSE-Expr| 190)) + (PUSH-REDUCTION '|PARSE-Iterator| + (CONS 'UNTIL (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Expr| (RBP) + (DECLARE (SPECIAL RBP)) + (AND (|PARSE-NudPart| RBP) + (OPTIONAL (STAR OPT_EXPR (|PARSE-LedPart| RBP))) + (PUSH-REDUCTION '|PARSE-Expr| (POP-STACK-1)))) + + +(DEFUN |PARSE-LabelExpr| () + (AND (|PARSE-Label|) (MUST (|PARSE-Expr| 120)) + (PUSH-REDUCTION '|PARSE-LabelExpr| + (CONS 'LABEL (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Label| () + (AND (MATCH-ADVANCE-STRING "<<") (MUST (|PARSE-Name|)) + (MUST (MATCH-ADVANCE-STRING ">>")))) + + +(DEFUN |PARSE-LedPart| (RBP) + (DECLARE (SPECIAL RBP)) + (AND (|PARSE-Operation| '|Led| RBP) + (PUSH-REDUCTION '|PARSE-LedPart| (POP-STACK-1)))) + + +(DEFUN |PARSE-NudPart| (RBP) + (DECLARE (SPECIAL RBP)) + (AND (OR (|PARSE-Operation| '|Nud| RBP) (|PARSE-Reduction|) + (|PARSE-Form|)) + (PUSH-REDUCTION '|PARSE-NudPart| (POP-STACK-1)))) + + +(DEFUN |PARSE-Operation| (|ParseMode| RBP) + (DECLARE (SPECIAL |ParseMode| RBP)) + (AND (NOT (MATCH-CURRENT-TOKEN 'IDENTIFIER)) + (GETL (SETQ |tmptok| (CURRENT-SYMBOL)) |ParseMode|) + (LT RBP (|PARSE-leftBindingPowerOf| |tmptok| |ParseMode|)) + (ACTION (SETQ RBP + (|PARSE-rightBindingPowerOf| |tmptok| |ParseMode|))) + (|PARSE-getSemanticForm| |tmptok| |ParseMode| + (ELEMN (GETL |tmptok| |ParseMode|) 5 NIL)))) + + +(DEFUN |PARSE-leftBindingPowerOf| (X IND) + (DECLARE (SPECIAL X IND)) + (LET ((Y (GETL X IND))) (IF Y (ELEMN Y 3 0) 0))) + + +(DEFUN |PARSE-rightBindingPowerOf| (X IND) + (DECLARE (SPECIAL X IND)) + (LET ((Y (GETL X IND))) (IF Y (ELEMN Y 4 105) 105))) + + +(DEFUN |PARSE-getSemanticForm| (X IND Y) + (DECLARE (SPECIAL X IND Y)) + (OR (AND Y (EVAL Y)) (AND (EQ IND '|Nud|) (|PARSE-Prefix|)) + (AND (EQ IND '|Led|) (|PARSE-Infix|)))) + + +(DEFUN |PARSE-Reduction| () + (AND (|PARSE-ReductionOp|) (MUST (|PARSE-Expr| 1000)) + (PUSH-REDUCTION '|PARSE-Reduction| + (CONS '|Reduce| + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-ReductionOp| () + (AND (GETL (CURRENT-SYMBOL) '|Led|) + (MATCH-NEXT-TOKEN 'SPECIAL-CHAR (CODE-CHAR 47)) + (PUSH-REDUCTION '|PARSE-ReductionOp| (CURRENT-SYMBOL)) + (ACTION (ADVANCE-TOKEN)) (ACTION (ADVANCE-TOKEN)))) + + +(DEFUN |PARSE-Form| () + (OR (AND (MATCH-ADVANCE-STRING "iterate") + (BANG FIL_TEST + (OPTIONAL + (AND (MATCH-ADVANCE-STRING "from") + (MUST (|PARSE-Label|)) + (PUSH-REDUCTION '|PARSE-Form| + (CONS (POP-STACK-1) NIL))))) + (PUSH-REDUCTION '|PARSE-Form| + (CONS '|iterate| (APPEND (POP-STACK-1) NIL)))) + (AND (MATCH-ADVANCE-STRING "yield") (MUST (|PARSE-Application|)) + (PUSH-REDUCTION '|PARSE-Form| + (CONS '|yield| (CONS (POP-STACK-1) NIL)))) + (|PARSE-Application|))) + + +(DEFUN |PARSE-Application| () + (AND (|PARSE-Primary|) (OPTIONAL (STAR OPT_EXPR (|PARSE-Selector|))) + (OPTIONAL + (AND (|PARSE-Application|) + (PUSH-REDUCTION '|PARSE-Application| + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL))))))) + + +(DEFUN |PARSE-Selector| () + (OR (AND NONBLANK (EQ (CURRENT-SYMBOL) '|.|) + (CHAR-NE (CURRENT-CHAR) '| |) (MATCH-ADVANCE-STRING ".") + (MUST (|PARSE-PrimaryNoFloat|)) + (MUST (OR (AND $BOOT + (PUSH-REDUCTION '|PARSE-Selector| + (CONS 'ELT + (CONS (POP-STACK-2) + (CONS (POP-STACK-1) NIL))))) + (PUSH-REDUCTION '|PARSE-Selector| + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + (AND (OR (|PARSE-Float|) + (AND (MATCH-ADVANCE-STRING ".") + (MUST (|PARSE-Primary|)))) + (MUST (OR (AND $BOOT + (PUSH-REDUCTION '|PARSE-Selector| + (CONS 'ELT + (CONS (POP-STACK-2) + (CONS (POP-STACK-1) NIL))))) + (PUSH-REDUCTION '|PARSE-Selector| + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))))) + + +(DEFUN |PARSE-PrimaryNoFloat| () + (AND (|PARSE-Primary1|) (OPTIONAL (|PARSE-TokTail|)))) + + +(DEFUN |PARSE-Primary| () + (OR (|PARSE-Float|) (|PARSE-PrimaryNoFloat|))) + + +(DEFUN |PARSE-Primary1| () + (OR (AND (|PARSE-VarForm|) + (OPTIONAL + (AND NONBLANK (EQ (CURRENT-SYMBOL) '|(|) + (MUST (|PARSE-Primary1|)) + (PUSH-REDUCTION '|PARSE-Primary1| + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + (|PARSE-Quad|) (|PARSE-String|) (|PARSE-IntegerTok|) + (|PARSE-FormalParameter|) + (AND (MATCH-STRING "'") + (MUST (OR (AND $BOOT (|PARSE-Data|)) + (AND (MATCH-ADVANCE-STRING "'") + (MUST (|PARSE-Expr| 999)) + (PUSH-REDUCTION '|PARSE-Primary1| + (CONS 'QUOTE (CONS (POP-STACK-1) NIL))))))) + (|PARSE-Sequence|) (|PARSE-Enclosure|))) + + +(DEFUN |PARSE-Float| () + (AND (|PARSE-FloatBase|) + (MUST (OR (AND NONBLANK (|PARSE-FloatExponent|)) + (PUSH-REDUCTION '|PARSE-Float| 0))) + (PUSH-REDUCTION '|PARSE-Float| + (MAKE-FLOAT (POP-STACK-4) (POP-STACK-2) (POP-STACK-2) + (POP-STACK-1))))) + + +(DEFUN |PARSE-FloatBase| () + (OR (AND (FIXP (CURRENT-SYMBOL)) (CHAR-EQ (CURRENT-CHAR) ".") + (CHAR-NE (NEXT-CHAR) ".") (|PARSE-IntegerTok|) + (MUST (|PARSE-FloatBasePart|))) + (AND (FIXP (CURRENT-SYMBOL)) + (CHAR-EQ (CHAR-UPCASE (CURRENT-CHAR)) 'E) + (|PARSE-IntegerTok|) (PUSH-REDUCTION '|PARSE-FloatBase| 0) + (PUSH-REDUCTION '|PARSE-FloatBase| 0)) + (AND (DIGITP (CURRENT-CHAR)) (EQ (CURRENT-SYMBOL) '|.|) + (PUSH-REDUCTION '|PARSE-FloatBase| 0) + (|PARSE-FloatBasePart|)))) + + +(DEFUN |PARSE-FloatBasePart| () + (AND (MATCH-ADVANCE-STRING ".") + (MUST (OR (AND (DIGITP (CURRENT-CHAR)) + (PUSH-REDUCTION '|PARSE-FloatBasePart| + (TOKEN-NONBLANK (CURRENT-TOKEN))) + (|PARSE-IntegerTok|)) + (AND (PUSH-REDUCTION '|PARSE-FloatBasePart| 0) + (PUSH-REDUCTION '|PARSE-FloatBasePart| 0)))))) + + +(DEFUN |PARSE-FloatExponent| () + (PROG (G1) + (RETURN + (OR (AND (MEMBER (CURRENT-SYMBOL) '(E |e|)) + (FIND (CURRENT-CHAR) "+-") (ACTION (ADVANCE-TOKEN)) + (MUST (OR (|PARSE-IntegerTok|) + (AND (MATCH-ADVANCE-STRING "+") + (MUST (|PARSE-IntegerTok|))) + (AND (MATCH-ADVANCE-STRING "-") + (MUST (|PARSE-IntegerTok|)) + (PUSH-REDUCTION '|PARSE-FloatExponent| + (MINUS (POP-STACK-1)))) + (PUSH-REDUCTION '|PARSE-FloatExponent| 0)))) + (AND (IDENTP (CURRENT-SYMBOL)) + (SETQ G1 (FLOATEXPID (CURRENT-SYMBOL))) + (ACTION (ADVANCE-TOKEN)) + (PUSH-REDUCTION '|PARSE-FloatExponent| G1)))))) + + +(DEFUN |PARSE-Enclosure| () + (OR (AND (MATCH-ADVANCE-STRING "(") + (MUST (OR (AND (|PARSE-Expr| 6) + (MUST (MATCH-ADVANCE-STRING ")"))) + (AND (MATCH-ADVANCE-STRING ")") + (PUSH-REDUCTION '|PARSE-Enclosure| + (CONS '|Tuple| NIL)))))) + (AND (MATCH-ADVANCE-STRING "{") + (MUST (OR (AND (|PARSE-Expr| 6) + (MUST (MATCH-ADVANCE-STRING "}")) + (PUSH-REDUCTION '|PARSE-Enclosure| + (CONS '|brace| + (CONS + (CONS '|construct| + (CONS (POP-STACK-1) NIL)) + NIL)))) + (AND (MATCH-ADVANCE-STRING "}") + (PUSH-REDUCTION '|PARSE-Enclosure| + (CONS '|brace| NIL)))))))) + + +(DEFUN |PARSE-IntegerTok| () (PARSE-NUMBER)) + + +(DEFUN |PARSE-FloatTok| () + (AND (PARSE-NUMBER) + (PUSH-REDUCTION '|PARSE-FloatTok| + (IF $BOOT (POP-STACK-1) (BFP- (POP-STACK-1)))))) + + +(DEFUN |PARSE-FormalParameter| () (|PARSE-FormalParameterTok|)) + + +(DEFUN |PARSE-FormalParameterTok| () (PARSE-ARGUMENT-DESIGNATOR)) + + +(DEFUN |PARSE-Quad| () + (OR (AND (MATCH-ADVANCE-STRING "$") + (PUSH-REDUCTION '|PARSE-Quad| '$)) + (AND $BOOT (|PARSE-GliphTok| '|.|) + (PUSH-REDUCTION '|PARSE-Quad| '|.|)))) + + +(DEFUN |PARSE-String| () (PARSE-SPADSTRING)) + + +(DEFUN |PARSE-VarForm| () + (AND (|PARSE-Name|) + (OPTIONAL + (AND (|PARSE-Scripts|) + (PUSH-REDUCTION '|PARSE-VarForm| + (CONS '|Scripts| + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + (PUSH-REDUCTION '|PARSE-VarForm| (POP-STACK-1)))) + + +(DEFUN |PARSE-Scripts| () + (AND NONBLANK (MATCH-ADVANCE-STRING "[") (MUST (|PARSE-ScriptItem|)) + (MUST (MATCH-ADVANCE-STRING "]")))) + + +(DEFUN |PARSE-ScriptItem| () + (OR (AND (|PARSE-Expr| 90) + (OPTIONAL + (AND (STAR REPEATOR + (AND (MATCH-ADVANCE-STRING ";") + (MUST (|PARSE-ScriptItem|)))) + (PUSH-REDUCTION '|PARSE-ScriptItem| + (CONS '|;| + (CONS (POP-STACK-2) + (APPEND (POP-STACK-1) NIL))))))) + (AND (MATCH-ADVANCE-STRING ";") (MUST (|PARSE-ScriptItem|)) + (PUSH-REDUCTION '|PARSE-ScriptItem| + (CONS '|PrefixSC| (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Name| () + (AND (PARSE-IDENTIFIER) (PUSH-REDUCTION '|PARSE-Name| (POP-STACK-1)))) + + +(DEFUN |PARSE-Data| () + (AND (ACTION (SETQ LABLASOC NIL)) (|PARSE-Sexpr|) + (PUSH-REDUCTION '|PARSE-Data| + (CONS 'QUOTE (CONS (TRANSLABEL (POP-STACK-1) LABLASOC) NIL))))) + + +(DEFUN |PARSE-Sexpr| () + (AND (ACTION (ADVANCE-TOKEN)) (|PARSE-Sexpr1|))) + + +(DEFUN |PARSE-Sexpr1| () + (OR (AND (|PARSE-AnyId|) + (OPTIONAL + (AND (|PARSE-NBGliphTok| '=) (MUST (|PARSE-Sexpr1|)) + (ACTION (SETQ LABLASOC + (CONS (CONS (POP-STACK-2) + (NTH-STACK 1)) + LABLASOC)))))) + (AND (MATCH-ADVANCE-STRING "'") (MUST (|PARSE-Sexpr1|)) + (PUSH-REDUCTION '|PARSE-Sexpr1| + (CONS 'QUOTE (CONS (POP-STACK-1) NIL)))) + (|PARSE-IntegerTok|) + (AND (MATCH-ADVANCE-STRING "-") (MUST (|PARSE-IntegerTok|)) + (PUSH-REDUCTION '|PARSE-Sexpr1| (MINUS (POP-STACK-1)))) + (|PARSE-String|) + (AND (MATCH-ADVANCE-STRING "<") + (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-Sexpr1|)))) + (MUST (MATCH-ADVANCE-STRING ">")) + (PUSH-REDUCTION '|PARSE-Sexpr1| (LIST2VEC (POP-STACK-1)))) + (AND (MATCH-ADVANCE-STRING "(") + (BANG FIL_TEST + (OPTIONAL + (AND (STAR REPEATOR (|PARSE-Sexpr1|)) + (OPTIONAL + (AND (|PARSE-GliphTok| '|.|) + (MUST (|PARSE-Sexpr1|)) + (PUSH-REDUCTION '|PARSE-Sexpr1| + (NCONC (POP-STACK-2) (POP-STACK-1)))))))) + (MUST (MATCH-ADVANCE-STRING ")"))))) + + +(DEFUN |PARSE-NBGliphTok| (|tok|) + (DECLARE (SPECIAL |tok|)) + (AND (MATCH-CURRENT-TOKEN 'GLIPH |tok|) NONBLANK + (ACTION (ADVANCE-TOKEN)))) + + +(DEFUN |PARSE-GliphTok| (|tok|) + (DECLARE (SPECIAL |tok|)) + (AND (MATCH-CURRENT-TOKEN 'GLIPH |tok|) (ACTION (ADVANCE-TOKEN)))) + + +(DEFUN |PARSE-AnyId| () + (OR (PARSE-IDENTIFIER) + (OR (AND (MATCH-STRING "$") + (PUSH-REDUCTION '|PARSE-AnyId| (CURRENT-SYMBOL)) + (ACTION (ADVANCE-TOKEN))) + (PARSE-KEYWORD)))) + + +(DEFUN |PARSE-Sequence| () + (OR (AND (|PARSE-OpenBracket|) (MUST (|PARSE-Sequence1|)) + (MUST (MATCH-ADVANCE-STRING "]"))) + (AND (|PARSE-OpenBrace|) (MUST (|PARSE-Sequence1|)) + (MUST (MATCH-ADVANCE-STRING "}")) + (PUSH-REDUCTION '|PARSE-Sequence| + (CONS '|brace| (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Sequence1| () + (AND (OR (AND (|PARSE-Expression|) + (PUSH-REDUCTION '|PARSE-Sequence1| + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))) + (PUSH-REDUCTION '|PARSE-Sequence1| (CONS (POP-STACK-1) NIL))) + (OPTIONAL + (AND (|PARSE-IteratorTail|) + (PUSH-REDUCTION '|PARSE-Sequence1| + (CONS 'COLLECT + (APPEND (POP-STACK-1) + (CONS (POP-STACK-1) NIL)))))))) + + +(DEFUN |PARSE-OpenBracket| () + (PROG (G1) + (RETURN + (AND (EQ (|getToken| (SETQ G1 (CURRENT-SYMBOL))) '[) + (MUST (OR (AND (EQCAR G1 '|elt|) + (PUSH-REDUCTION '|PARSE-OpenBracket| + (CONS '|elt| + (CONS (CADR G1) + (CONS '|construct| NIL))))) + (PUSH-REDUCTION '|PARSE-OpenBracket| '|construct|))) + (ACTION (ADVANCE-TOKEN)))))) + + +(DEFUN |PARSE-OpenBrace| () + (PROG (G1) + (RETURN + (AND (EQ (|getToken| (SETQ G1 (CURRENT-SYMBOL))) '{) + (MUST (OR (AND (EQCAR G1 '|elt|) + (PUSH-REDUCTION '|PARSE-OpenBrace| + (CONS '|elt| + (CONS (CADR G1) + (CONS '|brace| NIL))))) + (PUSH-REDUCTION '|PARSE-OpenBrace| '|construct|))) + (ACTION (ADVANCE-TOKEN)))))) + + +(DEFUN |PARSE-IteratorTail| () + (OR (AND (MATCH-ADVANCE-STRING "repeat") + (BANG FIL_TEST + (OPTIONAL (STAR REPEATOR (|PARSE-Iterator|))))) + (STAR REPEATOR (|PARSE-Iterator|)))) + diff --git a/src/interp/fnewmeta.lisp.pamphlet b/src/interp/fnewmeta.lisp.pamphlet deleted file mode 100644 index be041a6a..00000000 --- a/src/interp/fnewmeta.lisp.pamphlet +++ /dev/null @@ -1,1012 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp fnewmeta.lisp} -\author{William Burge} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -<>= -% Scratchpad II Boot Language Grammar, Common Lisp Version -% IBM Thomas J. Watson Research Center -% Summer, 1986 -% -% NOTE: Substantially different from VM/LISP version, due to -% different parser and attempt to render more within META proper. - -.META(New NewExpr Process) -.PACKAGE 'BOOT' -.DECLARE(tmptok TOK ParseMode DEFINITION_NAME LABLASOC) -.PREFIX 'PARSE-' - -NewExpr: =')' .(processSynonyms) Command - / .(SETQ DEFINITION_NAME (CURRENT-SYMBOL)) Statement ; - -Command: ')' SpecialKeyWord SpecialCommand +() ; - -SpecialKeyWord: =(MATCH-CURRENT-TOKEN "IDENTIFIER) - .(SETF (TOKEN-SYMBOL (CURRENT-TOKEN)) (unAbbreviateKeyword (CURRENT-SYMBOL))) ; - -SpecialCommand: 'show' <'?' / Expression>! +(show #1) CommandTail - / ?(MEMBER (CURRENT-SYMBOL) \$noParseCommands) - .(FUNCALL (CURRENT-SYMBOL)) - / ?(MEMBER (CURRENT-SYMBOL) \$tokenCommands) TokenList - TokenCommandTail - / PrimaryOrQM* CommandTail ; - -TokenList: (^?(isTokenDelimiter) +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN))* ; - -TokenCommandTail: - ! ?(atEndOfLine) +(#2 -#1) .(systemCommand #1) ; - -TokenOption: ')' TokenList ; - -CommandTail: ! ?(atEndOfLine) +(#2 -#1) .(systemCommand #1) ; - -PrimaryOrQM: '?' +\? / Primary ; - -Option: ')' PrimaryOrQM* ; - -Statement: Expr{0} <(',' Expr{0})* +(Series #2 -#1)>; - -InfixWith: With +(Join #2 #1) ; - -With: 'with' Category +(with #1) ; - -Category: 'if' Expression 'then' Category <'else' Category>! +(if #3 #2 #1) - / '(' Category <(';' Category)*>! ')' +(CATEGORY #2 -#1) - / .(SETQ $1 (LINE-NUMBER CURRENT-LINE)) Application - ( ':' Expression +(Signature #2 #1) - .(recordSignatureDocumentation ##1 $1) - / +(Attribute #1) - .(recordAttributeDocumentation ##1 $1)); - -Expression: Expr{(PARSE-rightBindingPowerOf (MAKE-SYMBOL-OF PRIOR-TOKEN) ParseMode)} - +#1 ; - -Import: 'import' Expr{1000} <(',' Expr{1000})*>! +(import #2 -#1) ; - -Infix: =TRUE +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) - Expression +(#2 #2 #1) ; - -Prefix: =TRUE +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) - Expression +(#2 #1) ; - -Suffix: +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) +(#1 #1) ; - -TokTail: ?(AND (NULL \$BOOT) (EQ (CURRENT-SYMBOL) "\$) - (OR (ALPHA-CHAR-P (CURRENT-CHAR)) - (CHAR-EQ (CURRENT-CHAR) '$') - (CHAR-EQ (CURRENT-CHAR) '\%') - (CHAR-EQ (CURRENT-CHAR) '('))) - .(SETQ $1 (COPY-TOKEN PRIOR-TOKEN)) Qualification - .(SETQ PRIOR-TOKEN $1) ; - -Qualification: '$' Primary1 +=(dollarTran #1 #1) ; - -SemiColon: ';' (Expr{82} / + \/throwAway) +(\; #2 #1) ; - -Return: 'return' Expression +(return #1) ; - -Exit: 'exit' (Expression / +\$NoValue) +(exit #1) ; - -Leave: 'leave' ( Expression / +\$NoValue ) - ('from' Label +(leaveFrom #1 #1) / +(leave #1)) ; - -Seg: GliphTok{"\.\.} ! +(SEGMENT #2 #1) ; - -Conditional: 'if' Expression 'then' Expression <'else' ElseClause>! - +(if #3 #2 #1) ; - -ElseClause: ?(EQ (CURRENT-SYMBOL) "if) Conditional / Expression ; - -Loop: Iterator* 'repeat' Expr{110} +(REPEAT -#2 #1) - / 'repeat' Expr{110} +(REPEAT #1) ; - -Iterator: 'for' Primary 'in' Expression - ( 'by' Expr{200} +(INBY #3 #2 #1) / +(IN #2 #1) ) - < '\|' Expr{111} +(\| #1) > - / 'while' Expr{190} +(WHILE #1) - / 'until' Expr{190} +(UNTIL #1) ; - -Expr{RBP}: NudPart{RBP} * +#1; - -LabelExpr: Label Expr{120} +(LABEL #2 #1) ; - -Label: '<<' Name '>>' ; - -LedPart{RBP}: Operation{"Led RBP} +#1; - -NudPart{RBP}: (Operation{"Nud RBP} / Reduction / Form) +#1 ; - -Operation{ParseMode RBP}: - ^?(MATCH-CURRENT-TOKEN "IDENTIFIER) - ?(GETL (SETQ tmptok (CURRENT-SYMBOL)) ParseMode) - ?(LT RBP (PARSE-leftBindingPowerOf tmptok ParseMode)) - .(SETQ RBP (PARSE-rightBindingPowerOf tmptok ParseMode)) - getSemanticForm{tmptok ParseMode (ELEMN (GETL tmptok ParseMode) 5 NIL)} ; - -% Binding powers stored under the Led and Red properties of an operator -% are set up by the file BOTTOMUP.LISP. The format for a Led property -% is , and the same for a Nud, except that -% it may also have a fourth component . ELEMN attempts to -% get the Nth indicator, counting from 1. - -leftBindingPowerOf{X IND}: =(LET ((Y (GETL X IND))) (IF Y (ELEMN Y 3 0) 0)) ; - -rightBindingPowerOf{X IND}: =(LET ((Y (GETL X IND))) (IF Y (ELEMN Y 4 105) 105)) ; - -getSemanticForm{X IND Y}: - ?(AND Y (EVAL Y)) / ?(EQ IND "Nud) Prefix / ?(EQ IND "Led) Infix ; - - -Reduction: ReductionOp Expr{1000} +(Reduce #2 #1) ; - -ReductionOp: ?(AND (GETL (CURRENT-SYMBOL) "Led) - (MATCH-NEXT-TOKEN "SPECIAL-CHAR (CODE-CHAR 47))) % Forgive me! - +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) .(ADVANCE-TOKEN) ; - -Form: 'iterate' < 'from' Label +(#1) >! +(iterate -#1) - / 'yield' Application +(yield #1) - / Application ; - -Application: Primary * ; - -Selector: ?NONBLANK ?(EQ (CURRENT-SYMBOL) "\.) ?(CHAR-NE (CURRENT-CHAR) "\ ) - '.' PrimaryNoFloat (=\$BOOT +(ELT #2 #1)/ +(#2 #1)) - / (Float /'.' Primary) (=\$BOOT +(ELT #2 #1)/ +(#2 #1)); - -PrimaryNoFloat: Primary1 ; - -Primary: Float /PrimaryNoFloat ; - -Primary1: VarForm <=(AND NONBLANK (EQ (CURRENT-SYMBOL) "\()) Primary1 +(#2 #1)> - /Quad - /String - /IntegerTok - /FormalParameter - /='\'' (?\$BOOT Data / '\'' Expr{999} +(QUOTE #1)) - /Sequence - /Enclosure ; - -Float: FloatBase (?NONBLANK FloatExponent / +0) +=(MAKE-FLOAT #4 #2 #2 #1) ; - -FloatBase: ?(FIXP (CURRENT-SYMBOL)) ?(CHAR-EQ (CURRENT-CHAR) '.') - ?(CHAR-NE (NEXT-CHAR) '.') - IntegerTok FloatBasePart - /?(FIXP (CURRENT-SYMBOL)) ?(CHAR-EQ (CHAR-UPCASE (CURRENT-CHAR)) "E) - IntegerTok +0 +0 - /?(DIGITP (CURRENT-CHAR)) ?(EQ (CURRENT-SYMBOL) "\.) - +0 FloatBasePart ; - -FloatBasePart: '.' - (?(DIGITP (CURRENT-CHAR)) +=(TOKEN-NONBLANK (CURRENT-TOKEN)) IntegerTok - / +0 +0); - - -FloatExponent: =(AND (MEMBER (CURRENT-SYMBOL) "(E e)) - (FIND (CURRENT-CHAR) '+-')) - .(ADVANCE-TOKEN) - (IntegerTok/'+' IntegerTok/'-' IntegerTok +=(MINUS #1)/+0) - /?(IDENTP (CURRENT-SYMBOL)) =(SETQ $1 (FLOATEXPID (CURRENT-SYMBOL))) - .(ADVANCE-TOKEN) +=$1 ; - -Enclosure: '(' ( Expr{6} ')' / ')' +(Tuple) ) - / '{' ( Expr{6} '}' +(brace (construct #1)) / '}' +(brace)) ; - -IntegerTok: NUMBER ; - -FloatTok: NUMBER +=(IF \$BOOT #1 (BFP- #1)) ; - -FormalParameter: FormalParameterTok ; - -FormalParameterTok: ARGUMENT-DESIGNATOR ; - -Quad: '$' +\$ / ?\$BOOT GliphTok{"\.} +\. ; - -String: SPADSTRING ; - -VarForm: Name +#1 ; - -Scripts: ?NONBLANK '[' ScriptItem ']' ; - -ScriptItem: Expr{90} <(';' ScriptItem)* +(\; #2 -#1)> - / ';' ScriptItem +(PrefixSC #1) ; - -Name: IDENTIFIER +#1 ; - -Data: .(SETQ LABLASOC NIL) Sexpr +(QUOTE =(TRANSLABEL #1 LABLASOC)) ; - -Sexpr: .(ADVANCE-TOKEN) Sexpr1 ; - -Sexpr1: AnyId - < NBGliphTok{"\=} Sexpr1 - .(SETQ LABLASOC (CONS (CONS #2 ##1) LABLASOC))> - / '\'' Sexpr1 +(QUOTE #1) - / IntegerTok - / '-' IntegerTok +=(MINUS #1) - / String - / '<' ! '>' +=(LIST2VEC #1) - / '(' >! ')' ; - -NBGliphTok{tok}: ?(AND (MATCH-CURRENT-TOKEN "GLIPH tok) NONBLANK) - .(ADVANCE-TOKEN) ; - -GliphTok{tok}: ?(MATCH-CURRENT-TOKEN "GLIPH tok) .(ADVANCE-TOKEN) ; - -AnyId: IDENTIFIER - / (='$' +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) / KEYWORD) ; - -Sequence: OpenBracket Sequence1 ']' - / OpenBrace Sequence1 '}' +(brace #1) ; - -Sequence1: (Expression +(#2 #1) / +(#1)) ; - -OpenBracket: =(EQ (getToken (SETQ $1 (CURRENT-SYMBOL))) "\[ ) - (=(EQCAR $1 "elt) +(elt =(CADR $1) construct) - / +construct) .(ADVANCE-TOKEN) ; - -OpenBrace: =(EQ (getToken (SETQ $1 (CURRENT-SYMBOL))) "\{ ) - (=(EQCAR $1 "elt) +(elt =(CADR $1) brace) - / +construct) .(ADVANCE-TOKEN) ; - -IteratorTail: ('repeat' ! / Iterator*) ; - -.FIN ; - - -@ -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -(IMPORT-MODULE "parsing") -(IN-PACKAGE "BOOT" ) - - -(DEFPARAMETER |tmptok| NIL) -(DEFPARAMETER TOK NIL) -(DEFPARAMETER |ParseMode| NIL) -(DEFPARAMETER DEFINITION_NAME NIL) -(DEFPARAMETER LABLASOC NIL) - -(defun |isTokenDelimiter| () - (MEMBER (CURRENT-SYMBOL) '(\) END\_UNIT NIL))) - - -(DEFUN |PARSE-NewExpr| () - (OR (AND (MATCH-STRING ")") (ACTION (|processSynonyms|)) - (MUST (|PARSE-Command|))) - (AND (ACTION (SETQ DEFINITION_NAME (CURRENT-SYMBOL))) - (|PARSE-Statement|)))) - - -(DEFUN |PARSE-Command| () - (AND (MATCH-ADVANCE-STRING ")") (MUST (|PARSE-SpecialKeyWord|)) - (MUST (|PARSE-SpecialCommand|)) - (PUSH-REDUCTION '|PARSE-Command| NIL))) - - -(DEFUN |PARSE-SpecialKeyWord| () - (AND (MATCH-CURRENT-TOKEN 'IDENTIFIER) - (ACTION (SETF (TOKEN-SYMBOL (CURRENT-TOKEN)) - (|unAbbreviateKeyword| (CURRENT-SYMBOL)))))) - - -(DEFUN |PARSE-SpecialCommand| () - (OR (AND (MATCH-ADVANCE-STRING "show") - (BANG FIL_TEST - (OPTIONAL - (OR (MATCH-ADVANCE-STRING "?") - (|PARSE-Expression|)))) - (PUSH-REDUCTION '|PARSE-SpecialCommand| - (CONS '|show| (CONS (POP-STACK-1) NIL))) - (MUST (|PARSE-CommandTail|))) - (AND (MEMBER (CURRENT-SYMBOL) |$noParseCommands|) - (ACTION (FUNCALL (CURRENT-SYMBOL)))) - (AND (MEMBER (CURRENT-SYMBOL) |$tokenCommands|) - (|PARSE-TokenList|) (MUST (|PARSE-TokenCommandTail|))) - (AND (STAR REPEATOR (|PARSE-PrimaryOrQM|)) - (MUST (|PARSE-CommandTail|))))) - - -(DEFUN |PARSE-TokenList| () - (STAR REPEATOR - (AND (NOT (|isTokenDelimiter|)) - (PUSH-REDUCTION '|PARSE-TokenList| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN))))) - - -(DEFUN |PARSE-TokenCommandTail| () - (AND (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-TokenOption|)))) - (|atEndOfLine|) - (PUSH-REDUCTION '|PARSE-TokenCommandTail| - (CONS (POP-STACK-2) (APPEND (POP-STACK-1) NIL))) - (ACTION (|systemCommand| (POP-STACK-1))))) - - -(DEFUN |PARSE-TokenOption| () - (AND (MATCH-ADVANCE-STRING ")") (MUST (|PARSE-TokenList|)))) - - -(DEFUN |PARSE-CommandTail| () - (AND (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-Option|)))) - (|atEndOfLine|) - (PUSH-REDUCTION '|PARSE-CommandTail| - (CONS (POP-STACK-2) (APPEND (POP-STACK-1) NIL))) - (ACTION (|systemCommand| (POP-STACK-1))))) - - -(DEFUN |PARSE-PrimaryOrQM| () - (OR (AND (MATCH-ADVANCE-STRING "?") - (PUSH-REDUCTION '|PARSE-PrimaryOrQM| '?)) - (|PARSE-Primary|))) - - -(DEFUN |PARSE-Option| () - (AND (MATCH-ADVANCE-STRING ")") - (MUST (STAR REPEATOR (|PARSE-PrimaryOrQM|))))) - - -(DEFUN |PARSE-Statement| () - (AND (|PARSE-Expr| 0) - (OPTIONAL - (AND (STAR REPEATOR - (AND (MATCH-ADVANCE-STRING ",") - (MUST (|PARSE-Expr| 0)))) - (PUSH-REDUCTION '|PARSE-Statement| - (CONS '|Series| - (CONS (POP-STACK-2) - (APPEND (POP-STACK-1) NIL)))))))) - - -(DEFUN |PARSE-InfixWith| () - (AND (|PARSE-With|) - (PUSH-REDUCTION '|PARSE-InfixWith| - (CONS '|Join| (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-With| () - (AND (MATCH-ADVANCE-STRING "with") (MUST (|PARSE-Category|)) - (PUSH-REDUCTION '|PARSE-With| - (CONS '|with| (CONS (POP-STACK-1) NIL))))) - - -(DEFUN |PARSE-Category| () - (PROG (G1) - (RETURN - (OR (AND (MATCH-ADVANCE-STRING "if") (MUST (|PARSE-Expression|)) - (MUST (MATCH-ADVANCE-STRING "then")) - (MUST (|PARSE-Category|)) - (BANG FIL_TEST - (OPTIONAL - (AND (MATCH-ADVANCE-STRING "else") - (MUST (|PARSE-Category|))))) - (PUSH-REDUCTION '|PARSE-Category| - (CONS '|if| - (CONS (POP-STACK-3) - (CONS (POP-STACK-2) - (CONS (POP-STACK-1) NIL)))))) - (AND (MATCH-ADVANCE-STRING "(") (MUST (|PARSE-Category|)) - (BANG FIL_TEST - (OPTIONAL - (STAR REPEATOR - (AND (MATCH-ADVANCE-STRING ";") - (MUST (|PARSE-Category|)))))) - (MUST (MATCH-ADVANCE-STRING ")")) - (PUSH-REDUCTION '|PARSE-Category| - (CONS 'CATEGORY - (CONS (POP-STACK-2) - (APPEND (POP-STACK-1) NIL))))) - (AND (ACTION (SETQ G1 (LINE-NUMBER CURRENT-LINE))) - (|PARSE-Application|) - (MUST (OR (AND (MATCH-ADVANCE-STRING ":") - (MUST (|PARSE-Expression|)) - (PUSH-REDUCTION '|PARSE-Category| - (CONS '|Signature| - (CONS (POP-STACK-2) - (CONS (POP-STACK-1) NIL)))) - (ACTION (|recordSignatureDocumentation| - (NTH-STACK 1) G1))) - (AND (PUSH-REDUCTION '|PARSE-Category| - (CONS '|Attribute| - (CONS (POP-STACK-1) NIL))) - (ACTION (|recordAttributeDocumentation| - (NTH-STACK 1) G1)))))))))) - - -(DEFUN |PARSE-Expression| () - (AND (|PARSE-Expr| - (|PARSE-rightBindingPowerOf| (MAKE-SYMBOL-OF PRIOR-TOKEN) - |ParseMode|)) - (PUSH-REDUCTION '|PARSE-Expression| (POP-STACK-1)))) - - -(DEFUN |PARSE-Import| () - (AND (MATCH-ADVANCE-STRING "import") (MUST (|PARSE-Expr| 1000)) - (BANG FIL_TEST - (OPTIONAL - (STAR REPEATOR - (AND (MATCH-ADVANCE-STRING ",") - (MUST (|PARSE-Expr| 1000)))))) - (PUSH-REDUCTION '|PARSE-Import| - (CONS '|import| - (CONS (POP-STACK-2) (APPEND (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Infix| () - (AND (PUSH-REDUCTION '|PARSE-Infix| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN)) (OPTIONAL (|PARSE-TokTail|)) - (MUST (|PARSE-Expression|)) - (PUSH-REDUCTION '|PARSE-Infix| - (CONS (POP-STACK-2) - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Prefix| () - (AND (PUSH-REDUCTION '|PARSE-Prefix| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN)) (OPTIONAL (|PARSE-TokTail|)) - (MUST (|PARSE-Expression|)) - (PUSH-REDUCTION '|PARSE-Prefix| - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL))))) - - -(DEFUN |PARSE-Suffix| () - (AND (PUSH-REDUCTION '|PARSE-Suffix| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN)) (OPTIONAL (|PARSE-TokTail|)) - (PUSH-REDUCTION '|PARSE-Suffix| - (CONS (POP-STACK-1) (CONS (POP-STACK-1) NIL))))) - - -(DEFUN |PARSE-TokTail| () - (PROG (G1) - (RETURN - (AND (NULL $BOOT) (EQ (CURRENT-SYMBOL) '$) - (OR (ALPHA-CHAR-P (CURRENT-CHAR)) - (CHAR-EQ (CURRENT-CHAR) "$") - (CHAR-EQ (CURRENT-CHAR) "%") - (CHAR-EQ (CURRENT-CHAR) "(")) - (ACTION (SETQ G1 (COPY-TOKEN PRIOR-TOKEN))) - (|PARSE-Qualification|) (ACTION (SETQ PRIOR-TOKEN G1)))))) - - -(DEFUN |PARSE-Qualification| () - (AND (MATCH-ADVANCE-STRING "$") (MUST (|PARSE-Primary1|)) - (PUSH-REDUCTION '|PARSE-Qualification| - (|dollarTran| (POP-STACK-1) (POP-STACK-1))))) - - -(DEFUN |PARSE-SemiColon| () - (AND (MATCH-ADVANCE-STRING ";") - (MUST (OR (|PARSE-Expr| 82) - (PUSH-REDUCTION '|PARSE-SemiColon| '|/throwAway|))) - (PUSH-REDUCTION '|PARSE-SemiColon| - (CONS '|;| (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Return| () - (AND (MATCH-ADVANCE-STRING "return") (MUST (|PARSE-Expression|)) - (PUSH-REDUCTION '|PARSE-Return| - (CONS '|return| (CONS (POP-STACK-1) NIL))))) - - -(DEFUN |PARSE-Exit| () - (AND (MATCH-ADVANCE-STRING "exit") - (MUST (OR (|PARSE-Expression|) - (PUSH-REDUCTION '|PARSE-Exit| '|$NoValue|))) - (PUSH-REDUCTION '|PARSE-Exit| - (CONS '|exit| (CONS (POP-STACK-1) NIL))))) - - -(DEFUN |PARSE-Leave| () - (AND (MATCH-ADVANCE-STRING "leave") - (MUST (OR (|PARSE-Expression|) - (PUSH-REDUCTION '|PARSE-Leave| '|$NoValue|))) - (MUST (OR (AND (MATCH-ADVANCE-STRING "from") - (MUST (|PARSE-Label|)) - (PUSH-REDUCTION '|PARSE-Leave| - (CONS '|leaveFrom| - (CONS (POP-STACK-1) - (CONS (POP-STACK-1) NIL))))) - (PUSH-REDUCTION '|PARSE-Leave| - (CONS '|leave| (CONS (POP-STACK-1) NIL))))))) - - -(DEFUN |PARSE-Seg| () - (AND (|PARSE-GliphTok| '|..|) - (BANG FIL_TEST (OPTIONAL (|PARSE-Expression|))) - (PUSH-REDUCTION '|PARSE-Seg| - (CONS 'SEGMENT - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Conditional| () - (AND (MATCH-ADVANCE-STRING "if") (MUST (|PARSE-Expression|)) - (MUST (MATCH-ADVANCE-STRING "then")) (MUST (|PARSE-Expression|)) - (BANG FIL_TEST - (OPTIONAL - (AND (MATCH-ADVANCE-STRING "else") - (MUST (|PARSE-ElseClause|))))) - (PUSH-REDUCTION '|PARSE-Conditional| - (CONS '|if| - (CONS (POP-STACK-3) - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL))))))) - - -(DEFUN |PARSE-ElseClause| () - (OR (AND (EQ (CURRENT-SYMBOL) '|if|) (|PARSE-Conditional|)) - (|PARSE-Expression|))) - - -(DEFUN |PARSE-Loop| () - (OR (AND (STAR REPEATOR (|PARSE-Iterator|)) - (MUST (MATCH-ADVANCE-STRING "repeat")) - (MUST (|PARSE-Expr| 110)) - (PUSH-REDUCTION '|PARSE-Loop| - (CONS 'REPEAT - (APPEND (POP-STACK-2) (CONS (POP-STACK-1) NIL))))) - (AND (MATCH-ADVANCE-STRING "repeat") (MUST (|PARSE-Expr| 110)) - (PUSH-REDUCTION '|PARSE-Loop| - (CONS 'REPEAT (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Iterator| () - (OR (AND (MATCH-ADVANCE-STRING "for") (MUST (|PARSE-Primary|)) - (MUST (MATCH-ADVANCE-STRING "in")) - (MUST (|PARSE-Expression|)) - (MUST (OR (AND (MATCH-ADVANCE-STRING "by") - (MUST (|PARSE-Expr| 200)) - (PUSH-REDUCTION '|PARSE-Iterator| - (CONS 'INBY - (CONS (POP-STACK-3) - (CONS (POP-STACK-2) - (CONS (POP-STACK-1) NIL)))))) - (PUSH-REDUCTION '|PARSE-Iterator| - (CONS 'IN - (CONS (POP-STACK-2) - (CONS (POP-STACK-1) NIL)))))) - (OPTIONAL - (AND (MATCH-ADVANCE-STRING "|") - (MUST (|PARSE-Expr| 111)) - (PUSH-REDUCTION '|PARSE-Iterator| - (CONS '|\|| (CONS (POP-STACK-1) NIL)))))) - (AND (MATCH-ADVANCE-STRING "while") (MUST (|PARSE-Expr| 190)) - (PUSH-REDUCTION '|PARSE-Iterator| - (CONS 'WHILE (CONS (POP-STACK-1) NIL)))) - (AND (MATCH-ADVANCE-STRING "until") (MUST (|PARSE-Expr| 190)) - (PUSH-REDUCTION '|PARSE-Iterator| - (CONS 'UNTIL (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Expr| (RBP) - (DECLARE (SPECIAL RBP)) - (AND (|PARSE-NudPart| RBP) - (OPTIONAL (STAR OPT_EXPR (|PARSE-LedPart| RBP))) - (PUSH-REDUCTION '|PARSE-Expr| (POP-STACK-1)))) - - -(DEFUN |PARSE-LabelExpr| () - (AND (|PARSE-Label|) (MUST (|PARSE-Expr| 120)) - (PUSH-REDUCTION '|PARSE-LabelExpr| - (CONS 'LABEL (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Label| () - (AND (MATCH-ADVANCE-STRING "<<") (MUST (|PARSE-Name|)) - (MUST (MATCH-ADVANCE-STRING ">>")))) - - -(DEFUN |PARSE-LedPart| (RBP) - (DECLARE (SPECIAL RBP)) - (AND (|PARSE-Operation| '|Led| RBP) - (PUSH-REDUCTION '|PARSE-LedPart| (POP-STACK-1)))) - - -(DEFUN |PARSE-NudPart| (RBP) - (DECLARE (SPECIAL RBP)) - (AND (OR (|PARSE-Operation| '|Nud| RBP) (|PARSE-Reduction|) - (|PARSE-Form|)) - (PUSH-REDUCTION '|PARSE-NudPart| (POP-STACK-1)))) - - -(DEFUN |PARSE-Operation| (|ParseMode| RBP) - (DECLARE (SPECIAL |ParseMode| RBP)) - (AND (NOT (MATCH-CURRENT-TOKEN 'IDENTIFIER)) - (GETL (SETQ |tmptok| (CURRENT-SYMBOL)) |ParseMode|) - (LT RBP (|PARSE-leftBindingPowerOf| |tmptok| |ParseMode|)) - (ACTION (SETQ RBP - (|PARSE-rightBindingPowerOf| |tmptok| |ParseMode|))) - (|PARSE-getSemanticForm| |tmptok| |ParseMode| - (ELEMN (GETL |tmptok| |ParseMode|) 5 NIL)))) - - -(DEFUN |PARSE-leftBindingPowerOf| (X IND) - (DECLARE (SPECIAL X IND)) - (LET ((Y (GETL X IND))) (IF Y (ELEMN Y 3 0) 0))) - - -(DEFUN |PARSE-rightBindingPowerOf| (X IND) - (DECLARE (SPECIAL X IND)) - (LET ((Y (GETL X IND))) (IF Y (ELEMN Y 4 105) 105))) - - -(DEFUN |PARSE-getSemanticForm| (X IND Y) - (DECLARE (SPECIAL X IND Y)) - (OR (AND Y (EVAL Y)) (AND (EQ IND '|Nud|) (|PARSE-Prefix|)) - (AND (EQ IND '|Led|) (|PARSE-Infix|)))) - - -(DEFUN |PARSE-Reduction| () - (AND (|PARSE-ReductionOp|) (MUST (|PARSE-Expr| 1000)) - (PUSH-REDUCTION '|PARSE-Reduction| - (CONS '|Reduce| - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-ReductionOp| () - (AND (GETL (CURRENT-SYMBOL) '|Led|) - (MATCH-NEXT-TOKEN 'SPECIAL-CHAR (CODE-CHAR 47)) - (PUSH-REDUCTION '|PARSE-ReductionOp| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN)) (ACTION (ADVANCE-TOKEN)))) - - -(DEFUN |PARSE-Form| () - (OR (AND (MATCH-ADVANCE-STRING "iterate") - (BANG FIL_TEST - (OPTIONAL - (AND (MATCH-ADVANCE-STRING "from") - (MUST (|PARSE-Label|)) - (PUSH-REDUCTION '|PARSE-Form| - (CONS (POP-STACK-1) NIL))))) - (PUSH-REDUCTION '|PARSE-Form| - (CONS '|iterate| (APPEND (POP-STACK-1) NIL)))) - (AND (MATCH-ADVANCE-STRING "yield") (MUST (|PARSE-Application|)) - (PUSH-REDUCTION '|PARSE-Form| - (CONS '|yield| (CONS (POP-STACK-1) NIL)))) - (|PARSE-Application|))) - - -(DEFUN |PARSE-Application| () - (AND (|PARSE-Primary|) (OPTIONAL (STAR OPT_EXPR (|PARSE-Selector|))) - (OPTIONAL - (AND (|PARSE-Application|) - (PUSH-REDUCTION '|PARSE-Application| - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL))))))) - - -(DEFUN |PARSE-Selector| () - (OR (AND NONBLANK (EQ (CURRENT-SYMBOL) '|.|) - (CHAR-NE (CURRENT-CHAR) '| |) (MATCH-ADVANCE-STRING ".") - (MUST (|PARSE-PrimaryNoFloat|)) - (MUST (OR (AND $BOOT - (PUSH-REDUCTION '|PARSE-Selector| - (CONS 'ELT - (CONS (POP-STACK-2) - (CONS (POP-STACK-1) NIL))))) - (PUSH-REDUCTION '|PARSE-Selector| - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - (AND (OR (|PARSE-Float|) - (AND (MATCH-ADVANCE-STRING ".") - (MUST (|PARSE-Primary|)))) - (MUST (OR (AND $BOOT - (PUSH-REDUCTION '|PARSE-Selector| - (CONS 'ELT - (CONS (POP-STACK-2) - (CONS (POP-STACK-1) NIL))))) - (PUSH-REDUCTION '|PARSE-Selector| - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))))) - - -(DEFUN |PARSE-PrimaryNoFloat| () - (AND (|PARSE-Primary1|) (OPTIONAL (|PARSE-TokTail|)))) - - -(DEFUN |PARSE-Primary| () - (OR (|PARSE-Float|) (|PARSE-PrimaryNoFloat|))) - - -(DEFUN |PARSE-Primary1| () - (OR (AND (|PARSE-VarForm|) - (OPTIONAL - (AND NONBLANK (EQ (CURRENT-SYMBOL) '|(|) - (MUST (|PARSE-Primary1|)) - (PUSH-REDUCTION '|PARSE-Primary1| - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - (|PARSE-Quad|) (|PARSE-String|) (|PARSE-IntegerTok|) - (|PARSE-FormalParameter|) - (AND (MATCH-STRING "'") - (MUST (OR (AND $BOOT (|PARSE-Data|)) - (AND (MATCH-ADVANCE-STRING "'") - (MUST (|PARSE-Expr| 999)) - (PUSH-REDUCTION '|PARSE-Primary1| - (CONS 'QUOTE (CONS (POP-STACK-1) NIL))))))) - (|PARSE-Sequence|) (|PARSE-Enclosure|))) - - -(DEFUN |PARSE-Float| () - (AND (|PARSE-FloatBase|) - (MUST (OR (AND NONBLANK (|PARSE-FloatExponent|)) - (PUSH-REDUCTION '|PARSE-Float| 0))) - (PUSH-REDUCTION '|PARSE-Float| - (MAKE-FLOAT (POP-STACK-4) (POP-STACK-2) (POP-STACK-2) - (POP-STACK-1))))) - - -(DEFUN |PARSE-FloatBase| () - (OR (AND (FIXP (CURRENT-SYMBOL)) (CHAR-EQ (CURRENT-CHAR) ".") - (CHAR-NE (NEXT-CHAR) ".") (|PARSE-IntegerTok|) - (MUST (|PARSE-FloatBasePart|))) - (AND (FIXP (CURRENT-SYMBOL)) - (CHAR-EQ (CHAR-UPCASE (CURRENT-CHAR)) 'E) - (|PARSE-IntegerTok|) (PUSH-REDUCTION '|PARSE-FloatBase| 0) - (PUSH-REDUCTION '|PARSE-FloatBase| 0)) - (AND (DIGITP (CURRENT-CHAR)) (EQ (CURRENT-SYMBOL) '|.|) - (PUSH-REDUCTION '|PARSE-FloatBase| 0) - (|PARSE-FloatBasePart|)))) - - -(DEFUN |PARSE-FloatBasePart| () - (AND (MATCH-ADVANCE-STRING ".") - (MUST (OR (AND (DIGITP (CURRENT-CHAR)) - (PUSH-REDUCTION '|PARSE-FloatBasePart| - (TOKEN-NONBLANK (CURRENT-TOKEN))) - (|PARSE-IntegerTok|)) - (AND (PUSH-REDUCTION '|PARSE-FloatBasePart| 0) - (PUSH-REDUCTION '|PARSE-FloatBasePart| 0)))))) - - -(DEFUN |PARSE-FloatExponent| () - (PROG (G1) - (RETURN - (OR (AND (MEMBER (CURRENT-SYMBOL) '(E |e|)) - (FIND (CURRENT-CHAR) "+-") (ACTION (ADVANCE-TOKEN)) - (MUST (OR (|PARSE-IntegerTok|) - (AND (MATCH-ADVANCE-STRING "+") - (MUST (|PARSE-IntegerTok|))) - (AND (MATCH-ADVANCE-STRING "-") - (MUST (|PARSE-IntegerTok|)) - (PUSH-REDUCTION '|PARSE-FloatExponent| - (MINUS (POP-STACK-1)))) - (PUSH-REDUCTION '|PARSE-FloatExponent| 0)))) - (AND (IDENTP (CURRENT-SYMBOL)) - (SETQ G1 (FLOATEXPID (CURRENT-SYMBOL))) - (ACTION (ADVANCE-TOKEN)) - (PUSH-REDUCTION '|PARSE-FloatExponent| G1)))))) - - -(DEFUN |PARSE-Enclosure| () - (OR (AND (MATCH-ADVANCE-STRING "(") - (MUST (OR (AND (|PARSE-Expr| 6) - (MUST (MATCH-ADVANCE-STRING ")"))) - (AND (MATCH-ADVANCE-STRING ")") - (PUSH-REDUCTION '|PARSE-Enclosure| - (CONS '|Tuple| NIL)))))) - (AND (MATCH-ADVANCE-STRING "{") - (MUST (OR (AND (|PARSE-Expr| 6) - (MUST (MATCH-ADVANCE-STRING "}")) - (PUSH-REDUCTION '|PARSE-Enclosure| - (CONS '|brace| - (CONS - (CONS '|construct| - (CONS (POP-STACK-1) NIL)) - NIL)))) - (AND (MATCH-ADVANCE-STRING "}") - (PUSH-REDUCTION '|PARSE-Enclosure| - (CONS '|brace| NIL)))))))) - - -(DEFUN |PARSE-IntegerTok| () (PARSE-NUMBER)) - - -(DEFUN |PARSE-FloatTok| () - (AND (PARSE-NUMBER) - (PUSH-REDUCTION '|PARSE-FloatTok| - (IF $BOOT (POP-STACK-1) (BFP- (POP-STACK-1)))))) - - -(DEFUN |PARSE-FormalParameter| () (|PARSE-FormalParameterTok|)) - - -(DEFUN |PARSE-FormalParameterTok| () (PARSE-ARGUMENT-DESIGNATOR)) - - -(DEFUN |PARSE-Quad| () - (OR (AND (MATCH-ADVANCE-STRING "$") - (PUSH-REDUCTION '|PARSE-Quad| '$)) - (AND $BOOT (|PARSE-GliphTok| '|.|) - (PUSH-REDUCTION '|PARSE-Quad| '|.|)))) - - -(DEFUN |PARSE-String| () (PARSE-SPADSTRING)) - - -(DEFUN |PARSE-VarForm| () - (AND (|PARSE-Name|) - (OPTIONAL - (AND (|PARSE-Scripts|) - (PUSH-REDUCTION '|PARSE-VarForm| - (CONS '|Scripts| - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - (PUSH-REDUCTION '|PARSE-VarForm| (POP-STACK-1)))) - - -(DEFUN |PARSE-Scripts| () - (AND NONBLANK (MATCH-ADVANCE-STRING "[") (MUST (|PARSE-ScriptItem|)) - (MUST (MATCH-ADVANCE-STRING "]")))) - - -(DEFUN |PARSE-ScriptItem| () - (OR (AND (|PARSE-Expr| 90) - (OPTIONAL - (AND (STAR REPEATOR - (AND (MATCH-ADVANCE-STRING ";") - (MUST (|PARSE-ScriptItem|)))) - (PUSH-REDUCTION '|PARSE-ScriptItem| - (CONS '|;| - (CONS (POP-STACK-2) - (APPEND (POP-STACK-1) NIL))))))) - (AND (MATCH-ADVANCE-STRING ";") (MUST (|PARSE-ScriptItem|)) - (PUSH-REDUCTION '|PARSE-ScriptItem| - (CONS '|PrefixSC| (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Name| () - (AND (PARSE-IDENTIFIER) (PUSH-REDUCTION '|PARSE-Name| (POP-STACK-1)))) - - -(DEFUN |PARSE-Data| () - (AND (ACTION (SETQ LABLASOC NIL)) (|PARSE-Sexpr|) - (PUSH-REDUCTION '|PARSE-Data| - (CONS 'QUOTE (CONS (TRANSLABEL (POP-STACK-1) LABLASOC) NIL))))) - - -(DEFUN |PARSE-Sexpr| () - (AND (ACTION (ADVANCE-TOKEN)) (|PARSE-Sexpr1|))) - - -(DEFUN |PARSE-Sexpr1| () - (OR (AND (|PARSE-AnyId|) - (OPTIONAL - (AND (|PARSE-NBGliphTok| '=) (MUST (|PARSE-Sexpr1|)) - (ACTION (SETQ LABLASOC - (CONS (CONS (POP-STACK-2) - (NTH-STACK 1)) - LABLASOC)))))) - (AND (MATCH-ADVANCE-STRING "'") (MUST (|PARSE-Sexpr1|)) - (PUSH-REDUCTION '|PARSE-Sexpr1| - (CONS 'QUOTE (CONS (POP-STACK-1) NIL)))) - (|PARSE-IntegerTok|) - (AND (MATCH-ADVANCE-STRING "-") (MUST (|PARSE-IntegerTok|)) - (PUSH-REDUCTION '|PARSE-Sexpr1| (MINUS (POP-STACK-1)))) - (|PARSE-String|) - (AND (MATCH-ADVANCE-STRING "<") - (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-Sexpr1|)))) - (MUST (MATCH-ADVANCE-STRING ">")) - (PUSH-REDUCTION '|PARSE-Sexpr1| (LIST2VEC (POP-STACK-1)))) - (AND (MATCH-ADVANCE-STRING "(") - (BANG FIL_TEST - (OPTIONAL - (AND (STAR REPEATOR (|PARSE-Sexpr1|)) - (OPTIONAL - (AND (|PARSE-GliphTok| '|.|) - (MUST (|PARSE-Sexpr1|)) - (PUSH-REDUCTION '|PARSE-Sexpr1| - (NCONC (POP-STACK-2) (POP-STACK-1)))))))) - (MUST (MATCH-ADVANCE-STRING ")"))))) - - -(DEFUN |PARSE-NBGliphTok| (|tok|) - (DECLARE (SPECIAL |tok|)) - (AND (MATCH-CURRENT-TOKEN 'GLIPH |tok|) NONBLANK - (ACTION (ADVANCE-TOKEN)))) - - -(DEFUN |PARSE-GliphTok| (|tok|) - (DECLARE (SPECIAL |tok|)) - (AND (MATCH-CURRENT-TOKEN 'GLIPH |tok|) (ACTION (ADVANCE-TOKEN)))) - - -(DEFUN |PARSE-AnyId| () - (OR (PARSE-IDENTIFIER) - (OR (AND (MATCH-STRING "$") - (PUSH-REDUCTION '|PARSE-AnyId| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN))) - (PARSE-KEYWORD)))) - - -(DEFUN |PARSE-Sequence| () - (OR (AND (|PARSE-OpenBracket|) (MUST (|PARSE-Sequence1|)) - (MUST (MATCH-ADVANCE-STRING "]"))) - (AND (|PARSE-OpenBrace|) (MUST (|PARSE-Sequence1|)) - (MUST (MATCH-ADVANCE-STRING "}")) - (PUSH-REDUCTION '|PARSE-Sequence| - (CONS '|brace| (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Sequence1| () - (AND (OR (AND (|PARSE-Expression|) - (PUSH-REDUCTION '|PARSE-Sequence1| - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))) - (PUSH-REDUCTION '|PARSE-Sequence1| (CONS (POP-STACK-1) NIL))) - (OPTIONAL - (AND (|PARSE-IteratorTail|) - (PUSH-REDUCTION '|PARSE-Sequence1| - (CONS 'COLLECT - (APPEND (POP-STACK-1) - (CONS (POP-STACK-1) NIL)))))))) - - -(DEFUN |PARSE-OpenBracket| () - (PROG (G1) - (RETURN - (AND (EQ (|getToken| (SETQ G1 (CURRENT-SYMBOL))) '[) - (MUST (OR (AND (EQCAR G1 '|elt|) - (PUSH-REDUCTION '|PARSE-OpenBracket| - (CONS '|elt| - (CONS (CADR G1) - (CONS '|construct| NIL))))) - (PUSH-REDUCTION '|PARSE-OpenBracket| '|construct|))) - (ACTION (ADVANCE-TOKEN)))))) - - -(DEFUN |PARSE-OpenBrace| () - (PROG (G1) - (RETURN - (AND (EQ (|getToken| (SETQ G1 (CURRENT-SYMBOL))) '{) - (MUST (OR (AND (EQCAR G1 '|elt|) - (PUSH-REDUCTION '|PARSE-OpenBrace| - (CONS '|elt| - (CONS (CADR G1) - (CONS '|brace| NIL))))) - (PUSH-REDUCTION '|PARSE-OpenBrace| '|construct|))) - (ACTION (ADVANCE-TOKEN)))))) - - -(DEFUN |PARSE-IteratorTail| () - (OR (AND (MATCH-ADVANCE-STRING "repeat") - (BANG FIL_TEST - (OPTIONAL (STAR REPEATOR (|PARSE-Iterator|))))) - (STAR REPEATOR (|PARSE-Iterator|)))) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/foam_l.lisp b/src/interp/foam_l.lisp new file mode 100644 index 00000000..57e0f5bd --- /dev/null +++ b/src/interp/foam_l.lisp @@ -0,0 +1,909 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + +;; +;; FOAM is the intermediate language for the aldor compiler. FOAM +;; means "first order abstract machine" and functions similar to +;; RTL for the GCC compiler. It is a "machine" that is used as the +;; target for meta-assembler level statments. These are eventually +;; expanded for the real target machine (or interpreted directly) +;; + +;;; +;;; FOAM Operations for Common Lisp +;;; + +;; +;; Client files should begin with +;; (in-package "FOAM-USER" :use '("FOAM" "LISP")) +;; +;; +;; To Do: +;; Test cases. +;; Scan and format functions need to be rewritten to handle complete syntax. +;; Deftypes for each Foam type? +;; + +#+:common-lisp (in-package "COMMON-LISP-USER") +#-:common-lisp (in-package "USER") + +(defpackage "FOAM" + #+:common-lisp (:use "COMMON-LISP") + #-:common-lisp (:use "LISP")) + + +;; FOAM-USER is the package containing foam statements and macros +;; that get inserted into user code versus the foam package which +;; provides support for compiler code. + +(defpackage "FOAM-USER" + #+:common-lisp (:use "COMMON-LISP") + #-:common-lisp (:use "LISP") + (:use "FOAM")) + +(in-package "FOAM") + +(export '( + compile-as-file cases + + |Clos| |Char| |Bool| |Byte| |HInt| |SInt| |BInt| |SFlo| |DFlo| |Ptr| + |Word| |Arb| |Env| |Level| |Arr| |Record| + + |ClosInit| |CharInit| |BoolInit| |ByteInit| |HIntInit| |SIntInit| + |BIntInit| |SFloInit| |DFloInit| |PtrInit| |WordInit| |ArbInit| |EnvInit| + |ArrInit| |RecordInit| |LevelInit| + + |BoolFalse| |BoolTrue| |BoolNot| |BoolAnd| |BoolOr| |BoolEQ| |BoolNE| + + |CharSpace| |CharNewline| |CharMin| |CharMax| |CharIsDigit| + |CharIsLetter| |CharEQ| |CharNE| |CharLT| |CharLE| + |CharLower| |CharUpper| |CharOrd| |CharNum| |CharCode0| + + |SFlo0| |SFlo1| |SFloMin| |SFloMax| |SFloEpsilon| |SFloIsZero| + |SFloIsNeg| |SFloIsPos| |SFloEQ| |SFloNE| |SFloLT| + |SFloLE| |SFloNegate| |SFloPrev| |SFloNext| |SFloPlus| + |SFloMinus| |SFloTimes| |SFloTimesPlus| |SFloDivide| + |SFloRPlus| |SFloRMinus| |SFloRTimes| |SFloRTimesPlus| + |SFloRDivide| |SFloDissemble| |SFloAssemble| + + |DFlo0| |DFlo1| |DFloMin| |DFloMax| |DFloEpsilon| + |DFloIsZero| |DFloIsNeg| |DFloIsPos| |DFloEQ| |DFloNE| + |DFloLT| |DFloLE| |DFloNegate| |DFloPrev| |DFloNext| + |DFloPlus| |DFloMinus| |DFloTimes| |DFloTimesPlus| + |DFloDivide| |DFloRPlus| |DFloRMinus| |DFloRTimes| + |DFloRTimesPlus| |DFloRDivide| |DFloDissemble| + |DFloAssemble| |Byte0| |Byte1| |ByteMin| |ByteMax| + + |HInt0| |HInt1| |HIntMin| |HIntMax| + + |SInt0| |SInt1| |SIntMin| |SIntMax| |SIntIsZero| |SIntIsNeg| + |SIntIsPos| |SIntIsEven| |SIntIsOdd| |SIntEQ| |SIntNE| + |SIntLT| |SIntLE| |SIntNegate| |SIntPrev| |SIntNext| + |SIntPlus| |SIntMinus| |SIntTimes| |SIntTimesPlus| + |SIntMod| |SIntQuo| |SIntRem| |SIntDivide| |SIntGcd| + |SIntPlusMod| |SIntMinusMod| |SIntTimesMod| + |SIntTimesModInv| |SIntLength| |SIntShiftUp| + |SIntShiftDn| |SIntBit| |SIntNot| |SIntAnd| |SIntOr| + + |WordTimesDouble| |WordDivideDouble| |WordPlusStep| |WordTimesStep| + + |BInt0| |BInt1| |BIntIsZero| |BIntIsNeg| |BIntIsPos| |BIntIsEven| + |BIntIsOdd| |BIntIsSingle| |BIntEQ| |BIntNE| |BIntLT| + |BIntLE| |BIntNegate| |BIntPrev| |BIntNext| |BIntPlus| + |BIntMinus| |BIntTimes| |BIntTimesPlus| |BIntMod| + |BIntQuo| |BIntRem| |BIntDivide| |BIntGcd| + |BIntSIPower| |BIntBIPower| |BIntLength| |BIntShiftUp| + |BIntShiftDn| |BIntBit| + + |PtrNil| |PtrIsNil| |PtrMagicEQ| |PtrEQ| |PtrNE| + + |FormatSFlo| |FormatDFlo| |FormatSInt| |FormatBInt| + |fgetss| |fputss| + + |ScanSFlo| |ScanDFlo| |ScanSInt| |ScanBInt| + + |SFloToDFlo| |DFloToSFlo| |ByteToSInt| |SIntToByte| |HIntToSInt| + |SIntToHInt| |SIntToBInt| |BIntToSInt| |SIntToSFlo| + |SIntToDFlo| |BIntToSFlo| |BIntToDFlo| |PtrToSInt| + |SIntToPtr| |BoolToSInt| + + |ArrToSFlo| |ArrToDFlo| |ArrToSInt| |ArrToBInt| + + |PlatformRTE| |PlatformOS| |Halt| + + |Clos| |CCall| |ClosEnv| |ClosFun| |SetClosEnv| |SetClosFun| + |DDecl| |RNew| |ANew| |RElt| |EElt| |AElt| |Lex| + |SetLex| |SetRElt| |SetAElt| |SetEElt| + |FoamFree| + + declare-prog declare-type + defprog ignore-var block-return + defspecials file-exports file-imports + typed-let foamfn |FoamProg| |alloc-prog-info| + + |MakeEnv| |EnvLevel| |EnvNext| |EnvInfo| |SetEnvInfo| |FoamEnvEnsure| + |MakeLit| |MakeLevel| + |printNewLine| |printChar| |printString| |printSInt| |printBInt| |printSFloat| + |printDFloat| + |strLength| |formatSInt| |formatBInt| |formatSFloat| |formatDFloat| + + |ProgHashCode| |SetProgHashCode| |ProgFun| + |G-mainArgc| |G-mainArgv| + |stdinFile| |stdoutFile| |stderrFile| + |fputc| |fputs| |foamfun| + + + ;; trancendental functions + |sqrt| |pow| |log| |exp| |sin| |cos| |tan| |sinh| |cosh| |tanh| + |asin| |acos| |atan| |atan2| + + ;; debuging + |fiSetDebugVar| |fiGetDebugVar| |fiSetDebugger| |fiGetDebugger| + ;; Blatent hacks.. + |G-stdoutVar| |G-stdinVar| |G-stderrVar| + |fiStrHash| + + axiomxl-file-init-name + axiomxl-global-name +)) + + +;; type defs for Foam types +(deftype |Char| () 'character) +(deftype |Clos| () 'list) +(deftype |Bool| () '(member t nil)) +(deftype |Byte| () 'unsigned-byte) +(deftype |HInt| () '(integer #.(- (expt 2 15)) #.(1- (expt 2 15)))) +(deftype |SInt| () 'fixnum) + +#+:AKCL +(deftype |BInt| () t) +#-:AKCL +(deftype |BInt| () 'integer) + +(deftype |SFlo| () 'short-float) + +#+:AKCL +(deftype |DFlo| () t) +#-:AKCL +(deftype |DFlo| () 'long-float) + +(deftype |Level| () t) ;; structure?? + +(deftype |Nil| () t) +(deftype |Ptr| () t) +(deftype |Word| () t) +(deftype |Arr| () t) +(deftype |Record| () t) +(deftype |Arb| () t) +(deftype |Env| () t) ; (or cons nil) + +;; default values for types. Used as initializers in lets. +(defconstant |CharInit| (the |Char| '#\Space)) +(defconstant |ClosInit| (the |Clos| nil)) +(defconstant |BoolInit| (the |Bool| nil)) +(defconstant |ByteInit| (the |Byte| 0)) +(defconstant |HIntInit| (the |HInt| 0)) +(defconstant |SIntInit| (the |SInt| 0)) +(defconstant |BIntInit| (the |BInt| 0)) +(defconstant |SFloInit| (the |SFlo| 0.0s0)) +;; FIXME: Revisit the definition of DFlo as long-double. +(defconstant |DFloInit| (the |DFlo| 0.0l0)) +(defconstant |PtrInit| (the |Ptr| nil)) +(defconstant |ArrInit| (the |Arr| nil)) +(defconstant |RecordInit| (the |Record| nil)) +(defconstant |WordInit| (the |Word| nil)) +(defconstant |ArbInit| (the |Arb| nil)) +(defconstant |EnvInit| (the |Env| nil)) +(defconstant |LevelInit| (the |Level| nil)) + +;; Bool values are assumed to be either 'T or NIL. +;; Thus non-nil values are canonically represented. +(defmacro |BoolFalse| () NIL) +(defmacro |BoolTrue| () 'T) +(defmacro |BoolNot| (x) `(NOT ,x)) +(defmacro |BoolAnd| (x y) + `(let ((xx ,x) (yy ,y)) (AND xx yy))) ;; force evaluation of both args +(defmacro |BoolOr| (x y) + `(let ((xx ,x) (yy ,y)) (OR xx yy))) ;; force evaluation of both args +(defmacro |BoolEQ| (x y) `(EQ ,x ,y)) +(defmacro |BoolNE| (x y) `(NOT (|BoolEQ| ,x ,y))) + +(defconstant |CharCode0| (code-char 0)) + +(defmacro |CharSpace| () '#\Space) +(defmacro |CharNewline| () '#\Newline) +(defmacro |CharMin| () |CharCode0|) +(defmacro |CharMax| () #.(code-char (1- char-code-limit))) +(defmacro |CharIsDigit| (x) `(if (DIGIT-CHAR-P (the |Char| ,x)) 't nil)) +(defmacro |CharIsLetter|(x) `(ALPHA-CHAR-P (the |Char| ,x))) +(defmacro |CharLT| (x y) `(CHAR< (the |Char| ,x) (the |Char| ,y))) +(defmacro |CharLE| (x y) `(CHAR<= (the |Char| ,x) (the |Char| ,y))) +(defmacro |CharEQ| (x y) `(CHAR= (the |Char| ,x) (the |Char| ,y))) +(defmacro |CharNE| (x y) `(CHAR/= (the |Char| ,x) (the |Char| ,y))) +(defmacro |CharLower| (x) `(the |Char| (CHAR-DOWNCASE (the |Char| ,x)))) +(defmacro |CharUpper| (x) `(the |Char| (CHAR-UPCASE (the |Char| ,x)))) +(defmacro |CharOrd| (x) `(CHAR-INT (the |Char| ,x))) +(defmacro |CharNum| (x) `(INT-CHAR (the |SInt| ,x))) + +(defmacro |SFlo0| () 0.0s0) +(defmacro |SFlo1| () 1.0s0) +(defmacro |SFloMin| () most-negative-short-float) +(defmacro |SFloMax| () most-positive-short-float) +(defmacro |SFloEpsilon| () short-float-epsilon) +(defmacro |SFloIsZero| (x) `(zerop (the |SFlo| ,x))) +(defmacro |SFloIsNeg| (x) `(minusp (the |SFlo| ,x))) +(defmacro |SFloIsPos| (x) `(plusp (the |SFlo| ,x))) +(defmacro |SFloLT| (x y) `(< (the |SFlo| ,x) (the |SFlo| ,y))) +(defmacro |SFloLE| (x y) `(<= (the |SFlo| ,x) (the |SFlo| ,y))) +(defmacro |SFloEQ| (x y) `(= (the |SFlo| ,x) (the |SFlo| ,y))) +(defmacro |SFloNE| (x y) `(/= (the |SFlo| ,x) (the |SFlo| ,y))) +(defmacro |SFloNegate| (x) `(the |SFlo| (- (the |SFlo| ,x)))) +(defmacro |SFloNext| (x) `(the |SFlo| (+ (the |SFlo| ,x) 1.0s0))) +(defmacro |SFloPrev| (x) `(the |SFlo| (- (the |SFlo| ,x) 1.0s0))) +(defmacro |SFloMinus| (x y) `(the |SFlo| (- (the |SFlo| ,x) (the |SFlo| ,y)))) +(defmacro |SFloTimes| (x y) `(the |SFlo| (* (the |SFlo| ,x) (the |SFlo| ,y)))) +(defmacro |SFloTimesPlus| (x y z) + `(the |SFlo| (+ (* (the |SFlo| ,x) (the |SFlo| ,y)) (the |SFlo| ,z)))) +(defmacro |SFloDivide| (x y) `(the |SFlo| (/ (the |SFlo| ,x) (the |SFlo| ,y)))) +(defmacro |SFloRPlus| (x y r) `(error "unimplemented operation -- SFloRPlus")) +(defmacro |SFloRMinus| (x y r) `(error "unimplemented operation -- SFloRTimes")) +(defmacro |SFloRTimes| (x y r) `(error "unimplemented operation -- SFloRTimes")) +(defmacro |SFloRTimesPlus| (x y z r) `(error "unimplemented operation -- SFloTimesPlus")) +(defmacro |SFloRDivide|(x y r) `(error "unimplemented operation -- SFloDivide")) +(defmacro |SFloDissemble| (x) `(error "unimplemented operation -- SFloDissemble")) +(defmacro |SFloAssemble| (w x y) `(error "unimplemented operation -- SFloAssemble")) + +;; These are no longer foam builtins +;;(defmacro |SFloRound| (x) `(the |BInt| (round (the |SFlo| ,x)))) +;;(defmacro |SFloTruncate| (x) `(the |BInt| (truncate (the |SFlo| ,x)))) +;;(defmacro |SFloFloor| (x) `(the |BInt| (floor (the |SFlo| ,x)))) +;;(defmacro |SFloCeiling| (x) `(the |BInt| (ceiling (the |SFlo| ,x)))) + +(defmacro |DFlo0| () 0.0d0) +(defmacro |DFlo1| () 1.0d0) +(defmacro |DFloMin| () most-negative-long-float) +(defmacro |DFloMax| () most-positive-long-float) +(defmacro |DFloEpsilon| () long-float-epsilon) +(defmacro |DFloIsZero| (x) `(zerop (the |DFlo| ,x))) +(defmacro |DFloIsNeg| (x) `(minusp (the |DFlo| ,x))) +(defmacro |DFloIsPos| (x) `(plusp (the |DFlo| ,x))) +(defmacro |DFloLE| (x y) `(<= (the |DFlo| ,x) (the |DFlo| ,y))) +(defmacro |DFloEQ| (x y) `(= (the |DFlo| ,x) (the |DFlo| ,y))) +(defmacro |DFloLT| (x y) `(< (the |DFlo| ,x) (the |DFlo| ,y))) +(defmacro |DFloNE| (x y) `(/= (the |DFlo| ,x) (the |DFlo| ,y))) +(defmacro |DFloNegate| (x) `(the |DFlo| (- (the |DFlo| ,x)))) +(defmacro |DFloNext| (x) `(the |DFlo| (+ (the |DFlo| ,x) 1.0d0))) +(defmacro |DFloPrev| (x) `(the |DFlo| (- (the |DFlo| ,x) 1.0d0))) +(defmacro |DFloPlus| (x y) `(the |DFlo| (+ (the |DFlo| ,x) (the |DFlo| ,y)))) +(defmacro |DFloMinus| (x y) `(the |DFlo| (- (the |DFlo| ,x) (the |DFlo| ,y)))) +(defmacro |DFloTimes| (x y) `(the |DFlo| (* (the |DFlo| ,x) (the |DFlo| ,y)))) +(defmacro |DFloDivide| (x y) `(the |DFlo| (/ (the |DFlo| ,x) (the |DFlo| ,y)))) +(defmacro |DFloTimesPlus| (x y z) + `(the |DFlo| (+ (* (the |DFlo| ,x) (the |DFlo| ,y)) (the |DFlo| ,z)))) + +(defmacro |DFloRPlus| (x y r) `(error "unimplemented operation -- DFloRPlus")) +(defmacro |DFloRMinus| (x y r) `(error "unimplemented operation -- DFloRTimes")) +(defmacro |DFloRTimes| (x y r) `(error "unimplemented operation -- DFloRTimes")) +(defmacro |DFloRTimesPlus| (x y z r) `(error "unimplemented operation -- DFloTimesPlus")) +(defmacro |DFloRDivide|(x y r) `(error "unimplemented operation -- DFloDivide")) + +(defmacro |DFloDissemble| (x) `(error "unimplemented operation -- DFloDissemble")) +(defmacro |DFloAssemble| (w x y z) `(error "unimplemented operation -- DFloAssemble")) + +;; Not builtins anymore +;;(defmacro |DFloRound| (x) `(the |BInt| (round (the |DFlo| ,x)))) +;;(defmacro |DFloTruncate| (x) `(the |BInt| (truncate (the |DFlo| ,x)))) +;;(defmacro |DFloFloor| (x) `(the |BInt| (floor (the |DFlo| ,x)))) +;;(defmacro |DFloCeiling| (x) `(the |BInt| (ceiling (the |DFlo| ,x)))) + +(defmacro |Byte0| () 0) +(defmacro |Byte1| () 1) +(defmacro |ByteMin| () 0) +(defmacro |ByteMax| () 255) + +(defmacro |HInt0| () 0) +(defmacro |HInt1| () 1) +(defmacro |HIntMin| () #.(- (expt 2 15))) +(defmacro |HIntMax| () #.(1- (expt 2 15))) + +(defmacro |SInt0| () 0) +(defmacro |SInt1| () 1) +(defmacro |SIntMin| () `(the |SInt| most-negative-fixnum)) +(defmacro |SIntMax| () `(the |SInt| most-positive-fixnum)) +(defmacro |SIntIsZero| (x) `(zerop (the |SInt| ,x))) +(defmacro |SIntIsNeg| (x) `(minusp (the |SInt| ,x))) +(defmacro |SIntIsPos| (x) `(plusp (the |SInt| ,x))) +(defmacro |SIntIsEven| (x) `(evenp (the |SInt| ,x))) +(defmacro |SIntIsOdd| (x) `(oddp (the |SInt| ,x))) +(defmacro |SIntLE| (x y) `(<= (the |SInt| ,x) (the |SInt| ,y))) +(defmacro |SIntEQ| (x y) `(= (the |SInt| ,x) (the |SInt| ,y))) +(defmacro |SIntLT| (x y) `(< (the |SInt| ,x) (the |SInt| ,y))) +(defmacro |SIntNE| (x y) `(/= (the |SInt| ,x) (the |SInt| ,y))) +(defmacro |SIntNegate| (x) `(the |SInt| (- (the |SInt| ,x)))) +(defmacro |SIntPrev| (x) `(the |SInt| (1- (the |SInt| ,x)))) +(defmacro |SIntNext| (x) `(the |SInt| (1+ (the |SInt| ,x)))) +(defmacro |SIntPlus| (x y) `(the |SInt| (+ (the |SInt| ,x) (the |SInt| ,y)))) +(defmacro |SIntMinus| (x y) `(the |SInt| (- (the |SInt| ,x) (the |SInt| ,y)))) +(defmacro |SIntTimes| (x y) `(the |SInt| (* (the |SInt| ,x) (the |SInt| ,y)))) +(defmacro |SIntTimesPlus| (x y z) + `(the |SInt| (+ (* (the |SInt| ,x) (the |SInt| ,y)) (the |SInt| ,z)))) +(defmacro |SIntMod| (x y) `(the |SInt| (mod(the |SInt| ,x)(the |SInt| ,y)))) +(defmacro |SIntQuo| (x y) + `(the |SInt| (values (truncate (the |SInt| ,x) (the |SInt| ,y))))) +(defmacro |SIntRem| (x y) `(the |SInt| (rem(the |SInt| ,x)(the |SInt| ,y)))) +;;! declare all let variables +(defmacro |SIntDivide| (x y) `(truncate (the |SInt| ,x) (the |SInt| ,y))) +(defmacro |SIntGcd| (x y) `(the |SInt| (gcd (the |SInt| ,x) (the |SInt| ,y)))) + +(defmacro |SIntPlusMod| (a b c) + `(the |SInt| (mod (+ (the |SInt| ,a) (the |SInt| ,b)) (the |SInt| ,c)))) +(defmacro |SIntMinusMod| (a b c) + `(the |SInt| (mod (- (the |SInt| ,a) (the |SInt| ,b)) (the |SInt| ,c)))) +(defmacro |SIntTimesMod| (a b c) + `(the |SInt| (mod (* (the |SInt| ,a) (the |SInt| ,b)) (the |SInt| ,c)))) +;; |SIntTimesModInv| +(defmacro |SIntLength| (x) `(the |SInt| (integer-length (the |SInt| ,x)))) +(defmacro |SIntShiftUp| (x y) `(the |SInt| (ash (the |SInt| ,x) (the |SInt| ,y)))) +(defmacro |SIntShiftDn| (x y) `(the |SInt| (ash (the |SInt| ,x) (the |SInt| (- (the |SInt| ,y)))))) + +(defmacro |SIntBit| (x i) + `(let ((xx ,x) (ii ,i)) (declare (type |SInt| xx ii)) (logbitp ii xx))) +(defmacro |SIntNot| (a) `(the |SInt| (lognot (the |SInt| ,a)))) +(defmacro |SIntAnd| (a b) + `(the |SInt| (logand (the |SInt| ,a) (the |SInt| ,b)))) +(defmacro |SIntOr| (a b) + `(the |SInt| (logior (the |SInt| ,a) (the |SInt| ,b)))) + +;; WordTimesDouble +;; WordDivideDouble +;; WordPlusStep +;; WordTimesStep + +(defmacro |SIntSIPower| (x y) + `(let ((xx ,x) (yy ,y)) + (declare (type |SInt| xx yy)) + (if (minusp yy) (error "cannot raise integers to negative powers") + (the |SInt| (expt xx yy))))) +(defmacro |SIntBIPower| (x y) + `(let ((xx ,x) (yy ,y)) + (declare (type |SInt| xx)) + (declare (type |BInt| yy)) + (if (minusp yy) (error "cannot raise integers to negative powers") + (the |SInt| (expt xx yy))))) + +(defmacro |BInt0| () 0) +(defmacro |BInt1| () 1) +(defmacro |BIntIsZero| (x) `(zerop (the |BInt| ,x))) +(defmacro |BIntIsNeg| (x) `(minusp(the |BInt| ,x))) +(defmacro |BIntIsPos| (x) `(plusp (the |BInt| ,x))) +(defmacro |BIntIsEven| (x) `(evenp (the |BInt| ,x))) +(defmacro |BIntIsOdd| (x) `(oddp (the |BInt| ,x))) +(defmacro |BIntIsSingle| (x) `(typep ,x '|SInt|)) +(defmacro |BIntLE| (x y) `(<= (the |BInt| ,x) (the |BInt| ,y))) +(defmacro |BIntEQ| (x y) `(= (the |BInt| ,x) (the |BInt| ,y))) +(defmacro |BIntLT| (x y) `(< (the |BInt| ,x) (the |BInt| ,y))) +(defmacro |BIntNE| (x y) `(/= (the |BInt| ,x) (the |BInt| ,y))) +(defmacro |BIntNegate| (x) `(the |BInt| (- (the |BInt| ,x)))) +(defmacro |BIntPrev| (x) `(the |BInt| (1- (the |BInt| ,x)))) +(defmacro |BIntNext| (x) `(the |BInt| (1+ (the |BInt| ,x)))) +(defmacro |BIntPlus| (x y) `(the |BInt| (+ (the |BInt| ,x) (the |BInt| ,y)))) +(defmacro |BIntMinus| (x y) `(the |BInt| (- (the |BInt| ,x) (the |BInt| ,y)))) +(defmacro |BIntTimes| (x y) `(the |BInt| (* (the |BInt| ,x) (the |BInt| ,y)))) +(defmacro |BIntTimesPlus| (x y z) + `(the |BInt| (+ (* (the |BInt| ,x) (the |BInt| ,y)) (the |BInt| ,z)))) +(defmacro |BIntMod| (x y) `(the |BInt| (mod(the |BInt| ,x)(the |BInt| ,y)))) +(defmacro |BIntQuo| (x y) + `(the |BInt| (values (truncate (the |BInt| ,x) (the |BInt| ,y))))) +(defmacro |BIntRem| (x y) + `(the |BInt| (rem (the |BInt| ,x) (the |BInt| ,y)))) +(defmacro |BIntDivide| (x y) `(truncate (the |BInt| ,x) (the |BInt| ,y))) +(defmacro |BIntGcd| (x y) + `(the |BInt| (gcd (the |BInt| ,x) (the |BInt| ,y)))) +(defmacro |BIntSIPower| (x y) + `(let ((xx ,x) (yy ,y)) + (declare (type |BInt| xx)) + (declare (type |SInt| yy)) + (if (minusp yy) (error "cannot raise integers to negative powers") + (the |BInt| (expt xx yy))))) +(defmacro |BIntBIPower| (x y) + `(let ((xx ,x) (yy ,y)) + (declare (type |BInt| xx)) + (declare (type |BInt| yy)) + (if (minusp yy) (error "cannot raise integers to negative powers") + (the |BInt| (expt xx yy))))) +(defmacro |BIntLength| (x) `(the |SInt| (integer-length (the |BInt| ,x)))) +(defmacro |BIntShiftUp| (x y) `(the |BInt| (ash (the |BInt| ,x)(the |SInt| ,y)))) +(defmacro |BIntShiftDn| (x y) `(the |BInt| (ash (the |BInt| ,x) (the |SInt| (- (the |SInt| ,y)))))) + +(defmacro |BIntBit| (x i) + `(let ((xx ,x) (ii ,i)) (declare (type |BInt| xx) (type |SInt| ii)) + (logbitp ii xx))) +;;(defmacro |BIntAbs| (x) `(the |BInt| (abs (the |BInt| ,x)))) + +(defmacro |PtrNil| () ()) +(defmacro |PtrIsNil| (x) `(NULL ,x)) +(defmacro |PtrEQ| (x y) `(eq ,x ,y)) +(defmacro |PtrNE| (x y) `(not (eq ,x ,y))) + +;; |WordTimesDouble| |WordDivideDouble| |WordPlusStep| |WordTimesStep| + + +;;(defvar |FoamOutputString| +;; (make-array 80 :element-type 'string-char :adjustable t :fill-pointer 0)) +(defun |FormatNumber| (c arr i) + (setq str (format nil "~a" c)) + (replace arr str :start1 i) +;; (incf i (fill-pointer |FoamOutputString|)) +;; (if (> i (length arr)) (error "not enough space")) +;; (setf (fill-pointer |FoamOutputString|) 0) + (+ i (length str))) + +(defmacro |FormatSFlo| (c arr i) `(|FormatNumber| ,c ,arr ,i)) +(defmacro |FormatDFlo| (c arr i) `(|FormatNumber| ,c ,arr ,i)) +(defmacro |FormatSInt| (c arr i) `(|FormatNumber| ,c ,arr ,i)) +(defmacro |FormatBInt| (c arr i) `(|FormatNumber| ,c ,arr ,i)) + +(set-syntax-from-char (code-char 0) #\space) ;;makes null char act like white space + +(defmacro |ScanSFlo| (arr i) + `(read-from-string ,arr nil (|SFlo0|) + :start ,i :preserve-whitespace t)) +(defmacro |ScanDFlo| (arr i) + `(read-from-string ,arr nil (|DFlo0|) + :start ,i :preserve-whitespace t)) +(defmacro |ScanSInt| (arr i) + `(parse-integer ,arr :start ,i :junk-allowed t)) +(defmacro |ScanBInt| (arr i) + `(parse-integer ,arr :start ,i :junk-allowed t)) + +;; 18/8/93: Evil bug in genfoam---nil generated. +(defmacro hacked-the (type x) + (if x `(the ,type ,x) `(the ,type 0))) + +(defmacro |ByteToSInt| (x) `(coerce (hacked-the |Byte| ,x) '|SInt|)) +(defmacro |BoolToSInt| (x) `(if ,x 1 0)) +(defmacro |BIntToSInt| (x) `(hacked-the |SInt| ,x)) +(defmacro |SIntToBInt| (x) `(hacked-the |BInt| ,x)) +(defmacro |SIntToSFlo| (x) `(coerce (hacked-the |SInt| ,x) '|SFlo|)) +(defmacro |SIntToByte| (x) `(coerce (hacked-the |SInt| ,x) '|Byte|)) +(defmacro |SIntToHInt| (x) `(coerce (hacked-the |SInt| ,x) '|HInt|)) +(defmacro |SIntToDFlo| (x) `(coerce (hacked-the |SInt| ,x) '|DFlo|)) +(defmacro |BIntToSFlo| (x) `(coerce (hacked-the |BInt| ,x) '|SFlo|)) +(defmacro |BIntToDFlo| (x) `(coerce (hacked-the |BInt| ,x) '|DFlo|)) +(defmacro |ArrToSFlo| (x) `(read-from-string ,x nil (|SFlo0|))) +(defmacro |ArrToDFlo| (x) `(read-from-string ,x nil (|DFlo0|))) +(defmacro |ArrToSInt| (x) `(read-from-string ,x nil (|SInt0|))) +(defmacro |ArrToBInt| (x) `(read-from-string ,x nil (|BInt0|))) + +(defmacro |Clos| (x y) `(let ((xx ,x) (yy #',y)) (cons yy xx))) +(defmacro |ClosFun| (x) `(car ,x)) +(defmacro |ClosEnv| (x) `(cdr ,x)) +(defmacro |SetClosFun| (x y) `(rplaca ,x ,y)) +(defmacro |SetClosEnv| (x y) `(rplacd ,x ,y)) + +(defmacro |MakeEnv| (x y) + `(let ((xx ,x) (yy ,y)) (cons yy (cons xx nil)))) + +(defmacro |EnvLevel| (x) `(car ,x)) +(defmacro |EnvNext| (x) `(cadr ,x)) +(defmacro |EnvInfo| (x) `(if (and (consp ,x) (consp (cdr ,x))) + (cddr ,x) nil)) +(defmacro |SetEnvInfo| (x val) `(rplacd (cdr ,x) ,val)) + +#+:CCL +(defmacro |FoamEnvEnsure| (e) + `(let ((einf (|EnvInfo| ,e))) + (if einf (|CCall| einf) nil))) +#-:CCL +(defmacro |FoamEnvEnsure| (e) + `(if (|EnvInfo| ,e) (|CCall| (|EnvInfo| ,e)) nil)) + +(defconstant null-char-string (string (code-char 0))) +(defmacro |MakeLit| (s) `(concatenate 'string ,s null-char-string)) + +;; functions are represented by symbols, with the symbol-value being some +;; information, and the symbol-function is the function itself. +;; 1-valued lisp should represent progs as either a pair or defstruct. + +(defmacro |FunProg| (x) x) + +(defstruct FoamProgInfoStruct + (funcall nil :type function) + (hashval 0 :type |SInt|)) + +(defun |ProgHashCode| (x) + (let ((aa (foam-function-info x))) + (if (null aa) 0 + (FoamProgInfoStruct-hashval aa)))) + +(defun |SetProgHashCode| (x y) + (let ((aa (foam-function-info x))) + (if (null aa) 0 + (setf (FoamProgInfoStruct-hashval aa) y)))) + +;; In a hurry -> O(n) lookup.. +(defvar foam-function-list ()) + +(defun alloc-prog-info (fun val) + (setq foam-function-list (cons (cons fun val) foam-function-list))) + +(defun foam-function-info (fun) + (let ((xx (assoc fun foam-function-list))) + (if (null xx) nil + (cdr xx)))) + +;; Accessors and constructors +(defmacro |DDecl| (name &rest args) + (setf (get name 'struct-args) args) + `(defstruct ,name ,@(insert-types args))) + +(defun insert-types (slots) + (mapcar #'(lambda (slot) + `(,(car slot) ,(type2init (cadr slot)) + :type ,(cadr slot))) + slots)) + +(defmacro |RNew| (name) + (let* ((struct-args (get name 'struct-args)) + (init-args (mapcar #'(lambda (x) (type2init (cadr x))) + struct-args)) + (count (length struct-args))) + (cond ((> count 2) `(vector ,@init-args)) + ((= count 2) `(cons ,@init-args)) + (t `(list ,@init-args))))) + +(defmacro |RElt| (name field index rec) + (let ((count (length (get name 'struct-args)))) + (cond ((> count 2) `(svref ,rec ,index)) + ((= count 2) + (if (zerop index) `(car ,rec) `(cdr ,rec))) + (t `(car ,rec))))) + +(defmacro |SetRElt| (name field index rec val) + (let ((count (length (get name 'struct-args)))) + (cond ((> count 2) `(setf (svref ,rec ,index) ,val)) + ((= count 2) + (if (zerop index) `(rplaca ,rec ,val) `(rplacd ,rec ,val))) + (t `(rplaca ,rec ,val))))) + +(defmacro |AElt| (name index) + `(aref ,name ,index)) + +(defmacro |SetAElt| (name index val) + `(setf (aref ,name ,index) ,val)) + +(defmacro |MakeLevel| (builder struct) + (if (get struct 'struct-args) + `(,builder) + 'nil)) + + +(defmacro |EElt| (accessor n var) + `(,accessor ,var)) + +(defmacro |SetEElt| (accessor n var val) + `(setf (,accessor ,var) ,val)) + +(defmacro |Lex| (accessor n var) + `(,accessor ,var)) + +(defmacro |SetLex| (accessor n var val) + `(progn ;; (print ',accessor) + (setf (,accessor ,var) ,val))) + +;; Atomic arguments for fun don't need a let to hold the fun. +;; CCall's with arguments need a let to hold the prog and the env. +(defmacro |CCall| (fun &rest args) + (cond ((and (atom fun) (null args)) + `(funcall (|FunProg| (|ClosFun| ,fun)) (|ClosEnv| ,fun))) + ((null args) + `(let ((c ,fun)) + (funcall (|FunProg| (|ClosFun| c)) (|ClosEnv| c)))) + ((atom fun) + `(let ((fun (|FunProg| (|ClosFun| ,fun))) + (env (|ClosEnv| ,fun))) + (funcall fun ,@args env))) + (t + `(let ((c ,fun)) + (let ((fun (|FunProg| (|ClosFun| c))) + (env (|ClosEnv| c))) + (funcall fun ,@args env)))))) + +(defmacro |FoamFree| (o) '()) + +;; macros for defining things + +(defmacro declare-prog (name-result params) + `(proclaim '(function ,(car name-result) ,params ,@(cdr name-result)))) + +(defmacro declare-type (name type) + `(proclaim '(type ,name ,type))) + +(defmacro defprog (type temps &rest body) + `(progn (defun ,(caar type) ,(mapcar #'car (cadr type)) + (typed-let ,temps ,@body)) + (alloc-prog-info #',(caar type) (make-FoamProgInfoStruct)))) + +(defmacro defspecials (&rest lst) + `(proclaim '(special ,@lst))) + +(defmacro top-level-define (&rest junk) + `(setq ,@junk)) + +;; Runtime macros + +;; control transfer +(defmacro block-return (obj val) + `(return-from ,obj ,val)) + +#-:CCL +(defmacro typed-let (letvars &rest forms) + `(let ,(mapcar #'(lambda (var) + (list (car var) (type2init (cadr var)))) + letvars ) + (declare ,@(mapcar #'(lambda (var) + (list 'type (cadr var) (car var))) + letvars)) + ,@forms)) + +#+:CCL +(defmacro typed-let (letvars &rest forms) + `(let ,(mapcar #'(lambda (var) (car var)) + letvars ) + ,@forms)) + +(defmacro cases (&rest junk) + `(case ,@junk)) + + +;;; Boot macros +(defmacro file-exports (lst) + `(eval-when (load eval) + (when (fboundp 'process-export-entry) + (mapcar #'process-export-entry ,lst)) + nil)) + +(defmacro file-imports (lst) + `(eval-when (load eval) + (when (fboundp 'process-import-entry) + (mapcar #'process-import-entry ,lst)) + nil)) + +(defmacro ignore-var (var) + `(declare (ignore ,var))) + +(defmacro |ANew| (type size) + (if (eq type '|Char|) + `(make-string ,size) + `(make-array ,size + :element-type ',type + :initial-element ,(type2init type)))) + +#-:CCL +(defun type2init (x) + (cond + ((eq x '|Char|) '|CharInit|) + ((eq x '|Clos|) '|ClosInit|) + ((eq x '|Bool|) '|BoolInit|) + ((eq x '|Byte|) '|ByteInit|) + ((eq x '|HInt|) '|HIntInit|) + ((eq x '|SInt|) '|SIntInit|) + ((eq x '|BInt|) '|BIntInit|) + ((eq x '|SFlo|) '|SFloInit|) + ((eq x '|DFlo|) '|DFloInit|) + ((eq x '|Ptr|) '|PtrInit|) + ((eq x '|Word|) '|WordInit|) + ((eq x '|Arr|) '|ArrInit|) + ((eq x '|Record|) '|RecordInit|) + ((eq x '|Arb|) '|ArbInit|) + ((eq x '|Env|) '|EnvInit|) + ((eq x '|Level|) '|LevelInit|) + ((eq x '|Nil|) nil) + (t nil))) + +#+:CCL +(defun type2init (x) nil) + +;; opsys interface +(defvar |G-mainArgc| 0) +(defvar |G-mainArgv| (vector)) +(defmacro |stdinFile| () '*standard-input*) +(defmacro |stdoutFile| () '*standard-output*) +(defmacro |stderrFile| () '*error-output*) + +;; Format functions +;needs to stop when it gets a null character +(defun |strLength| (s) + (dotimes (i (length s)) + (let ((c (schar s i))) + (if (char= c |CharCode0|) + (return i)))) + (length s)) + +(defun |formatSInt| (n) (format nil "~D" n)) +(defun |formatBInt| (n) (format nil "~D" n)) +(defun |formatSFloat| (x) (format nil "~G" x)) +(defun |formatDFloat| (x) (format nil "~G" x)) + + +;; Printing functions +(defun |printNewLine| (cs) (terpri cs)) +(defun |printChar| (cs c) (princ c cs)) + +;needs to stop when it gets a null character +(defun |printString| (cs s) + (dotimes (i (length s)) + (let ((c (schar s i))) + (if (char= c |CharCode0|) + (return i) + (princ c cs))))) + +(defun |printSInt| (cs n) (format cs "~D" n)) +(defun |printBInt| (cs n) (format cs "~D" n)) +(defun |printSFloat| (cs x) (format cs "~G" x)) +(defun |printDFloat| (cs x) (format cs "~G" x)) + +(defun |fputc| (si cs) + (|printChar| cs (code-char si)) + si) + +(defun |fputs| (s cs) + (|printString| cs s)) + +;; read a string into s starting at pos i1, ending at i2 +;; we should probably macro-out cases where args are constant + +;; fill s[i1..i2] with a null terminated string read from +;; the given input stream +(defun |fgetss| (s i1 i2 f) + (labels ((aux (n) + (if (= n i2) + (progn (setf (schar s n) (code-char 0)) + (- n i1)) + (let ((c (read-char f))) + (setf (schar s n) c) + (if (equal c #\newline) + (progn (setf (char s (+ n 1)) (code-char 0)) + (- n i1)) + (aux (+ n 1))))))) + (aux i1))) + +;; write s[i1..i2) to the output stream f +;; stop on any null characters + +(defun |fputss| (s i1 i2 f) + (labels ((aux (n) + (if (= n i2) (- n i1) + (let ((c (schar s n))) + (if (equal (code-char 0) c) + (- n i1) + (progn (princ c f) + (aux (+ n 1)))))))) + (setq i2 (if (minusp i2) (|strLength| s) + (min i2 (|strLength| s)))) + (aux i1))) + +;; function for compiling and loading from lisp + +(defun compile-as-file (file &optional (opts nil)) + (let* ((path (pathname file)) + (name (pathname-name path)) + (dir (pathname-directory path)) + (type (pathname-type path)) + (lpath (make-pathname :name name :type "l")) + (cpath (make-pathname :name name :type "o"))) + (if (null type) + (setq path (make-pathname :directory dir :name name :type "as"))) + (if opts + (system (format nil "axiomxl ~A -Flsp ~A" opts (namestring path))) + (system (format nil "axiomxl -Flsp ~A" (namestring path)))) + (compile-file (namestring lpath)) + (load (namestring cpath)))) + + +;; given the name of a file (a string), return the name of the AXIOM-XL function +;; that initialises the file. +(defun axiomxl-file-init-name (filename) + (intern (format nil "G-~a" (string-downcase filename)) 'foam-user)) + +;; given the name of the file, id name, and hashcode, return the +;; AXIOM-XL identifier for that object + +(defun axiomxl-global-name (file id hashcode) + (intern (format nil "G-~a_~a_~9,'0d" (string-downcase file) id hashcode) 'foam-user)) + +;; double float elementary functions +(defmacro |sqrt| (x) `(sqrt ,x)) +(defmacro |pow| (a b) `(expt ,a ,b)) +(defmacro |log| (a) `(log ,a)) +(defmacro |exp| (a) `(exp ,a)) + +(defmacro |sin| (a) `(sin ,a)) +(defmacro |cos| (a) `(cos ,a)) +(defmacro |tan| (a) `(tan ,a)) + +(defmacro |sinh| (a) `(sinh ,a)) +(defmacro |cosh| (a) `(cosh ,a)) +(defmacro |tanh| (a) `(tanh ,a)) + +(defmacro |asin| (a) `(asin ,a)) +(defmacro |acos| (a) `(acos ,a)) +(defmacro |atan| (a) `(atan ,a)) +(defmacro |atan2| (a b) `(atan ,a ,b)) + +(defun |Halt| (n) + (error (cond ((= n 101) "System Error: Unfortunate use of dependant type") + ((= n 102) "User error: Reached a 'never'") + ((= n 103) "User error: Bad union branch") + ((= n 104) "User error: Assertion failed") + (t (format nil "Unknown halt condition ~a" n))))) +;; debuging +(defvar *foam-debug-var* nil) +(defun |fiGetDebugVar| () *foam-debug-var*) + +(defun |fiSetDebugVar| (x) (setq *foam-debug-var* x)) +(defun |fiSetDebugger| (x y) ()) +(defun |fiGetDebugger| (x) ()) + +;; Output ports +(setq |G-stdoutVar| t) +(setq |G-stdinVar| t) +(setq |G-stderrVar| t) + +;; !! Not portable !! +(defun foam::|fiStrHash| (x) (boot::|hashString| (subseq x 0 (- (length x) 1)))) + +;; These three functions check that two cons's contain identical entries. +;; We use EQL to test numbers and EQ everywhere else. If the structure +;; of the two items is different, or any elements are different, we +;; return false. +(defmacro |politicallySound| (u v) + `(or (eql ,u ,v) (eq ,u ,v))) + +(defun |PtrMagicEQ| (u v) +;; I find (as-eg4) that these buggers can be numbers + (cond ( (or (NULL u) (NULL v)) nil) + ( (and (ATOM u) (ATOM v)) (eql u v)) + ( (or (ATOM u) (ATOM v)) nil) +;; removed for Aldor integration +;; ( (equal (length u) (length v)) (|magicEq1| u v)) + (t (eq u v) ))) + +(defun |magicEq1| (u v) + (cond ( (and (atom u) (atom v)) (|politicallySound| u v)) + ( (or (atom u) (atom v)) nil) + ( (|politicallySound| (car u) (car v)) (|magicEq1| (cdr u) (cdr v))) + nil )) + diff --git a/src/interp/foam_l.lisp.pamphlet b/src/interp/foam_l.lisp.pamphlet deleted file mode 100644 index 7bf48022..00000000 --- a/src/interp/foam_l.lisp.pamphlet +++ /dev/null @@ -1,945 +0,0 @@ -%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/foam\_l.lisp} Pamphlet} -\author{Stephen M. Watt, Timothy Daly} - -\begin{document} -\maketitle - -\begin{abstract} -\end{abstract} - - -\tableofcontents -\eject - -\section{License} - -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ - - - -\section{The [[FOAM]] package} - -FOAM is the intermediate language for the aldor compiler. FOAM -means "first order abstract machine" and functions similar to -RTL for the GCC compiler. It is a "machine" that is used as the -target for meta-assembler level statments. These are eventually -expanded for the real target machine (or interpreted directly) -<>= -#+:common-lisp (in-package "COMMON-LISP-USER") -#-:common-lisp (in-package "USER") - -(defpackage "FOAM" - #+:common-lisp (:use "COMMON-LISP") - #-:common-lisp (:use "LISP")) - -@ - -\section{The [[FOAM-USER]] package} - -FOAM-USER is the package containing foam statements and macros -that get inserted into user code versus the foam package which -provides support for compiler code. -<>= -(defpackage "FOAM-USER" - #+:common-lisp (:use "COMMON-LISP") - #-:common-lisp (:use "LISP") - (:use "FOAM")) - -@ - - -<<*>>= -<> -;;; -;;; FOAM Operations for Common Lisp -;;; - -;; -;; Client files should begin with -;; (in-package "FOAM-USER" :use '("FOAM" "LISP")) -;; -;; -;; To Do: -;; Test cases. -;; Scan and format functions need to be rewritten to handle complete syntax. -;; Deftypes for each Foam type? -;; - -<> -(in-package "FOAM") - -(export '( - compile-as-file cases - - |Clos| |Char| |Bool| |Byte| |HInt| |SInt| |BInt| |SFlo| |DFlo| |Ptr| - |Word| |Arb| |Env| |Level| |Arr| |Record| - - |ClosInit| |CharInit| |BoolInit| |ByteInit| |HIntInit| |SIntInit| - |BIntInit| |SFloInit| |DFloInit| |PtrInit| |WordInit| |ArbInit| |EnvInit| - |ArrInit| |RecordInit| |LevelInit| - - |BoolFalse| |BoolTrue| |BoolNot| |BoolAnd| |BoolOr| |BoolEQ| |BoolNE| - - |CharSpace| |CharNewline| |CharMin| |CharMax| |CharIsDigit| - |CharIsLetter| |CharEQ| |CharNE| |CharLT| |CharLE| - |CharLower| |CharUpper| |CharOrd| |CharNum| |CharCode0| - - |SFlo0| |SFlo1| |SFloMin| |SFloMax| |SFloEpsilon| |SFloIsZero| - |SFloIsNeg| |SFloIsPos| |SFloEQ| |SFloNE| |SFloLT| - |SFloLE| |SFloNegate| |SFloPrev| |SFloNext| |SFloPlus| - |SFloMinus| |SFloTimes| |SFloTimesPlus| |SFloDivide| - |SFloRPlus| |SFloRMinus| |SFloRTimes| |SFloRTimesPlus| - |SFloRDivide| |SFloDissemble| |SFloAssemble| - - |DFlo0| |DFlo1| |DFloMin| |DFloMax| |DFloEpsilon| - |DFloIsZero| |DFloIsNeg| |DFloIsPos| |DFloEQ| |DFloNE| - |DFloLT| |DFloLE| |DFloNegate| |DFloPrev| |DFloNext| - |DFloPlus| |DFloMinus| |DFloTimes| |DFloTimesPlus| - |DFloDivide| |DFloRPlus| |DFloRMinus| |DFloRTimes| - |DFloRTimesPlus| |DFloRDivide| |DFloDissemble| - |DFloAssemble| |Byte0| |Byte1| |ByteMin| |ByteMax| - - |HInt0| |HInt1| |HIntMin| |HIntMax| - - |SInt0| |SInt1| |SIntMin| |SIntMax| |SIntIsZero| |SIntIsNeg| - |SIntIsPos| |SIntIsEven| |SIntIsOdd| |SIntEQ| |SIntNE| - |SIntLT| |SIntLE| |SIntNegate| |SIntPrev| |SIntNext| - |SIntPlus| |SIntMinus| |SIntTimes| |SIntTimesPlus| - |SIntMod| |SIntQuo| |SIntRem| |SIntDivide| |SIntGcd| - |SIntPlusMod| |SIntMinusMod| |SIntTimesMod| - |SIntTimesModInv| |SIntLength| |SIntShiftUp| - |SIntShiftDn| |SIntBit| |SIntNot| |SIntAnd| |SIntOr| - - |WordTimesDouble| |WordDivideDouble| |WordPlusStep| |WordTimesStep| - - |BInt0| |BInt1| |BIntIsZero| |BIntIsNeg| |BIntIsPos| |BIntIsEven| - |BIntIsOdd| |BIntIsSingle| |BIntEQ| |BIntNE| |BIntLT| - |BIntLE| |BIntNegate| |BIntPrev| |BIntNext| |BIntPlus| - |BIntMinus| |BIntTimes| |BIntTimesPlus| |BIntMod| - |BIntQuo| |BIntRem| |BIntDivide| |BIntGcd| - |BIntSIPower| |BIntBIPower| |BIntLength| |BIntShiftUp| - |BIntShiftDn| |BIntBit| - - |PtrNil| |PtrIsNil| |PtrMagicEQ| |PtrEQ| |PtrNE| - - |FormatSFlo| |FormatDFlo| |FormatSInt| |FormatBInt| - |fgetss| |fputss| - - |ScanSFlo| |ScanDFlo| |ScanSInt| |ScanBInt| - - |SFloToDFlo| |DFloToSFlo| |ByteToSInt| |SIntToByte| |HIntToSInt| - |SIntToHInt| |SIntToBInt| |BIntToSInt| |SIntToSFlo| - |SIntToDFlo| |BIntToSFlo| |BIntToDFlo| |PtrToSInt| - |SIntToPtr| |BoolToSInt| - - |ArrToSFlo| |ArrToDFlo| |ArrToSInt| |ArrToBInt| - - |PlatformRTE| |PlatformOS| |Halt| - - |Clos| |CCall| |ClosEnv| |ClosFun| |SetClosEnv| |SetClosFun| - |DDecl| |RNew| |ANew| |RElt| |EElt| |AElt| |Lex| - |SetLex| |SetRElt| |SetAElt| |SetEElt| - |FoamFree| - - declare-prog declare-type - defprog ignore-var block-return - defspecials file-exports file-imports - typed-let foamfn |FoamProg| |alloc-prog-info| - - |MakeEnv| |EnvLevel| |EnvNext| |EnvInfo| |SetEnvInfo| |FoamEnvEnsure| - |MakeLit| |MakeLevel| - |printNewLine| |printChar| |printString| |printSInt| |printBInt| |printSFloat| - |printDFloat| - |strLength| |formatSInt| |formatBInt| |formatSFloat| |formatDFloat| - - |ProgHashCode| |SetProgHashCode| |ProgFun| - |G-mainArgc| |G-mainArgv| - |stdinFile| |stdoutFile| |stderrFile| - |fputc| |fputs| |foamfun| - - - ;; trancendental functions - |sqrt| |pow| |log| |exp| |sin| |cos| |tan| |sinh| |cosh| |tanh| - |asin| |acos| |atan| |atan2| - - ;; debuging - |fiSetDebugVar| |fiGetDebugVar| |fiSetDebugger| |fiGetDebugger| - ;; Blatent hacks.. - |G-stdoutVar| |G-stdinVar| |G-stderrVar| - |fiStrHash| - - axiomxl-file-init-name - axiomxl-global-name -)) - - -;; type defs for Foam types -(deftype |Char| () 'character) -(deftype |Clos| () 'list) -(deftype |Bool| () '(member t nil)) -(deftype |Byte| () 'unsigned-byte) -(deftype |HInt| () '(integer #.(- (expt 2 15)) #.(1- (expt 2 15)))) -(deftype |SInt| () 'fixnum) - -#+:AKCL -(deftype |BInt| () t) -#-:AKCL -(deftype |BInt| () 'integer) - -(deftype |SFlo| () 'short-float) - -#+:AKCL -(deftype |DFlo| () t) -#-:AKCL -(deftype |DFlo| () 'long-float) - -(deftype |Level| () t) ;; structure?? - -(deftype |Nil| () t) -(deftype |Ptr| () t) -(deftype |Word| () t) -(deftype |Arr| () t) -(deftype |Record| () t) -(deftype |Arb| () t) -(deftype |Env| () t) ; (or cons nil) - -;; default values for types. Used as initializers in lets. -(defconstant |CharInit| (the |Char| '#\Space)) -(defconstant |ClosInit| (the |Clos| nil)) -(defconstant |BoolInit| (the |Bool| nil)) -(defconstant |ByteInit| (the |Byte| 0)) -(defconstant |HIntInit| (the |HInt| 0)) -(defconstant |SIntInit| (the |SInt| 0)) -(defconstant |BIntInit| (the |BInt| 0)) -(defconstant |SFloInit| (the |SFlo| 0.0s0)) -;; FIXME: Revisit the definition of DFlo as long-double. -(defconstant |DFloInit| (the |DFlo| 0.0l0)) -(defconstant |PtrInit| (the |Ptr| nil)) -(defconstant |ArrInit| (the |Arr| nil)) -(defconstant |RecordInit| (the |Record| nil)) -(defconstant |WordInit| (the |Word| nil)) -(defconstant |ArbInit| (the |Arb| nil)) -(defconstant |EnvInit| (the |Env| nil)) -(defconstant |LevelInit| (the |Level| nil)) - -;; Bool values are assumed to be either 'T or NIL. -;; Thus non-nil values are canonically represented. -(defmacro |BoolFalse| () NIL) -(defmacro |BoolTrue| () 'T) -(defmacro |BoolNot| (x) `(NOT ,x)) -(defmacro |BoolAnd| (x y) - `(let ((xx ,x) (yy ,y)) (AND xx yy))) ;; force evaluation of both args -(defmacro |BoolOr| (x y) - `(let ((xx ,x) (yy ,y)) (OR xx yy))) ;; force evaluation of both args -(defmacro |BoolEQ| (x y) `(EQ ,x ,y)) -(defmacro |BoolNE| (x y) `(NOT (|BoolEQ| ,x ,y))) - -(defconstant |CharCode0| (code-char 0)) - -(defmacro |CharSpace| () '#\Space) -(defmacro |CharNewline| () '#\Newline) -(defmacro |CharMin| () |CharCode0|) -(defmacro |CharMax| () #.(code-char (1- char-code-limit))) -(defmacro |CharIsDigit| (x) `(if (DIGIT-CHAR-P (the |Char| ,x)) 't nil)) -(defmacro |CharIsLetter|(x) `(ALPHA-CHAR-P (the |Char| ,x))) -(defmacro |CharLT| (x y) `(CHAR< (the |Char| ,x) (the |Char| ,y))) -(defmacro |CharLE| (x y) `(CHAR<= (the |Char| ,x) (the |Char| ,y))) -(defmacro |CharEQ| (x y) `(CHAR= (the |Char| ,x) (the |Char| ,y))) -(defmacro |CharNE| (x y) `(CHAR/= (the |Char| ,x) (the |Char| ,y))) -(defmacro |CharLower| (x) `(the |Char| (CHAR-DOWNCASE (the |Char| ,x)))) -(defmacro |CharUpper| (x) `(the |Char| (CHAR-UPCASE (the |Char| ,x)))) -(defmacro |CharOrd| (x) `(CHAR-INT (the |Char| ,x))) -(defmacro |CharNum| (x) `(INT-CHAR (the |SInt| ,x))) - -(defmacro |SFlo0| () 0.0s0) -(defmacro |SFlo1| () 1.0s0) -(defmacro |SFloMin| () most-negative-short-float) -(defmacro |SFloMax| () most-positive-short-float) -(defmacro |SFloEpsilon| () short-float-epsilon) -(defmacro |SFloIsZero| (x) `(zerop (the |SFlo| ,x))) -(defmacro |SFloIsNeg| (x) `(minusp (the |SFlo| ,x))) -(defmacro |SFloIsPos| (x) `(plusp (the |SFlo| ,x))) -(defmacro |SFloLT| (x y) `(< (the |SFlo| ,x) (the |SFlo| ,y))) -(defmacro |SFloLE| (x y) `(<= (the |SFlo| ,x) (the |SFlo| ,y))) -(defmacro |SFloEQ| (x y) `(= (the |SFlo| ,x) (the |SFlo| ,y))) -(defmacro |SFloNE| (x y) `(/= (the |SFlo| ,x) (the |SFlo| ,y))) -(defmacro |SFloNegate| (x) `(the |SFlo| (- (the |SFlo| ,x)))) -(defmacro |SFloNext| (x) `(the |SFlo| (+ (the |SFlo| ,x) 1.0s0))) -(defmacro |SFloPrev| (x) `(the |SFlo| (- (the |SFlo| ,x) 1.0s0))) -(defmacro |SFloMinus| (x y) `(the |SFlo| (- (the |SFlo| ,x) (the |SFlo| ,y)))) -(defmacro |SFloTimes| (x y) `(the |SFlo| (* (the |SFlo| ,x) (the |SFlo| ,y)))) -(defmacro |SFloTimesPlus| (x y z) - `(the |SFlo| (+ (* (the |SFlo| ,x) (the |SFlo| ,y)) (the |SFlo| ,z)))) -(defmacro |SFloDivide| (x y) `(the |SFlo| (/ (the |SFlo| ,x) (the |SFlo| ,y)))) -(defmacro |SFloRPlus| (x y r) `(error "unimplemented operation -- SFloRPlus")) -(defmacro |SFloRMinus| (x y r) `(error "unimplemented operation -- SFloRTimes")) -(defmacro |SFloRTimes| (x y r) `(error "unimplemented operation -- SFloRTimes")) -(defmacro |SFloRTimesPlus| (x y z r) `(error "unimplemented operation -- SFloTimesPlus")) -(defmacro |SFloRDivide|(x y r) `(error "unimplemented operation -- SFloDivide")) -(defmacro |SFloDissemble| (x) `(error "unimplemented operation -- SFloDissemble")) -(defmacro |SFloAssemble| (w x y) `(error "unimplemented operation -- SFloAssemble")) - -;; These are no longer foam builtins -;;(defmacro |SFloRound| (x) `(the |BInt| (round (the |SFlo| ,x)))) -;;(defmacro |SFloTruncate| (x) `(the |BInt| (truncate (the |SFlo| ,x)))) -;;(defmacro |SFloFloor| (x) `(the |BInt| (floor (the |SFlo| ,x)))) -;;(defmacro |SFloCeiling| (x) `(the |BInt| (ceiling (the |SFlo| ,x)))) - -(defmacro |DFlo0| () 0.0d0) -(defmacro |DFlo1| () 1.0d0) -(defmacro |DFloMin| () most-negative-long-float) -(defmacro |DFloMax| () most-positive-long-float) -(defmacro |DFloEpsilon| () long-float-epsilon) -(defmacro |DFloIsZero| (x) `(zerop (the |DFlo| ,x))) -(defmacro |DFloIsNeg| (x) `(minusp (the |DFlo| ,x))) -(defmacro |DFloIsPos| (x) `(plusp (the |DFlo| ,x))) -(defmacro |DFloLE| (x y) `(<= (the |DFlo| ,x) (the |DFlo| ,y))) -(defmacro |DFloEQ| (x y) `(= (the |DFlo| ,x) (the |DFlo| ,y))) -(defmacro |DFloLT| (x y) `(< (the |DFlo| ,x) (the |DFlo| ,y))) -(defmacro |DFloNE| (x y) `(/= (the |DFlo| ,x) (the |DFlo| ,y))) -(defmacro |DFloNegate| (x) `(the |DFlo| (- (the |DFlo| ,x)))) -(defmacro |DFloNext| (x) `(the |DFlo| (+ (the |DFlo| ,x) 1.0d0))) -(defmacro |DFloPrev| (x) `(the |DFlo| (- (the |DFlo| ,x) 1.0d0))) -(defmacro |DFloPlus| (x y) `(the |DFlo| (+ (the |DFlo| ,x) (the |DFlo| ,y)))) -(defmacro |DFloMinus| (x y) `(the |DFlo| (- (the |DFlo| ,x) (the |DFlo| ,y)))) -(defmacro |DFloTimes| (x y) `(the |DFlo| (* (the |DFlo| ,x) (the |DFlo| ,y)))) -(defmacro |DFloDivide| (x y) `(the |DFlo| (/ (the |DFlo| ,x) (the |DFlo| ,y)))) -(defmacro |DFloTimesPlus| (x y z) - `(the |DFlo| (+ (* (the |DFlo| ,x) (the |DFlo| ,y)) (the |DFlo| ,z)))) - -(defmacro |DFloRPlus| (x y r) `(error "unimplemented operation -- DFloRPlus")) -(defmacro |DFloRMinus| (x y r) `(error "unimplemented operation -- DFloRTimes")) -(defmacro |DFloRTimes| (x y r) `(error "unimplemented operation -- DFloRTimes")) -(defmacro |DFloRTimesPlus| (x y z r) `(error "unimplemented operation -- DFloTimesPlus")) -(defmacro |DFloRDivide|(x y r) `(error "unimplemented operation -- DFloDivide")) - -(defmacro |DFloDissemble| (x) `(error "unimplemented operation -- DFloDissemble")) -(defmacro |DFloAssemble| (w x y z) `(error "unimplemented operation -- DFloAssemble")) - -;; Not builtins anymore -;;(defmacro |DFloRound| (x) `(the |BInt| (round (the |DFlo| ,x)))) -;;(defmacro |DFloTruncate| (x) `(the |BInt| (truncate (the |DFlo| ,x)))) -;;(defmacro |DFloFloor| (x) `(the |BInt| (floor (the |DFlo| ,x)))) -;;(defmacro |DFloCeiling| (x) `(the |BInt| (ceiling (the |DFlo| ,x)))) - -(defmacro |Byte0| () 0) -(defmacro |Byte1| () 1) -(defmacro |ByteMin| () 0) -(defmacro |ByteMax| () 255) - -(defmacro |HInt0| () 0) -(defmacro |HInt1| () 1) -(defmacro |HIntMin| () #.(- (expt 2 15))) -(defmacro |HIntMax| () #.(1- (expt 2 15))) - -(defmacro |SInt0| () 0) -(defmacro |SInt1| () 1) -(defmacro |SIntMin| () `(the |SInt| most-negative-fixnum)) -(defmacro |SIntMax| () `(the |SInt| most-positive-fixnum)) -(defmacro |SIntIsZero| (x) `(zerop (the |SInt| ,x))) -(defmacro |SIntIsNeg| (x) `(minusp (the |SInt| ,x))) -(defmacro |SIntIsPos| (x) `(plusp (the |SInt| ,x))) -(defmacro |SIntIsEven| (x) `(evenp (the |SInt| ,x))) -(defmacro |SIntIsOdd| (x) `(oddp (the |SInt| ,x))) -(defmacro |SIntLE| (x y) `(<= (the |SInt| ,x) (the |SInt| ,y))) -(defmacro |SIntEQ| (x y) `(= (the |SInt| ,x) (the |SInt| ,y))) -(defmacro |SIntLT| (x y) `(< (the |SInt| ,x) (the |SInt| ,y))) -(defmacro |SIntNE| (x y) `(/= (the |SInt| ,x) (the |SInt| ,y))) -(defmacro |SIntNegate| (x) `(the |SInt| (- (the |SInt| ,x)))) -(defmacro |SIntPrev| (x) `(the |SInt| (1- (the |SInt| ,x)))) -(defmacro |SIntNext| (x) `(the |SInt| (1+ (the |SInt| ,x)))) -(defmacro |SIntPlus| (x y) `(the |SInt| (+ (the |SInt| ,x) (the |SInt| ,y)))) -(defmacro |SIntMinus| (x y) `(the |SInt| (- (the |SInt| ,x) (the |SInt| ,y)))) -(defmacro |SIntTimes| (x y) `(the |SInt| (* (the |SInt| ,x) (the |SInt| ,y)))) -(defmacro |SIntTimesPlus| (x y z) - `(the |SInt| (+ (* (the |SInt| ,x) (the |SInt| ,y)) (the |SInt| ,z)))) -(defmacro |SIntMod| (x y) `(the |SInt| (mod(the |SInt| ,x)(the |SInt| ,y)))) -(defmacro |SIntQuo| (x y) - `(the |SInt| (values (truncate (the |SInt| ,x) (the |SInt| ,y))))) -(defmacro |SIntRem| (x y) `(the |SInt| (rem(the |SInt| ,x)(the |SInt| ,y)))) -;;! declare all let variables -(defmacro |SIntDivide| (x y) `(truncate (the |SInt| ,x) (the |SInt| ,y))) -(defmacro |SIntGcd| (x y) `(the |SInt| (gcd (the |SInt| ,x) (the |SInt| ,y)))) - -(defmacro |SIntPlusMod| (a b c) - `(the |SInt| (mod (+ (the |SInt| ,a) (the |SInt| ,b)) (the |SInt| ,c)))) -(defmacro |SIntMinusMod| (a b c) - `(the |SInt| (mod (- (the |SInt| ,a) (the |SInt| ,b)) (the |SInt| ,c)))) -(defmacro |SIntTimesMod| (a b c) - `(the |SInt| (mod (* (the |SInt| ,a) (the |SInt| ,b)) (the |SInt| ,c)))) -;; |SIntTimesModInv| -(defmacro |SIntLength| (x) `(the |SInt| (integer-length (the |SInt| ,x)))) -(defmacro |SIntShiftUp| (x y) `(the |SInt| (ash (the |SInt| ,x) (the |SInt| ,y)))) -(defmacro |SIntShiftDn| (x y) `(the |SInt| (ash (the |SInt| ,x) (the |SInt| (- (the |SInt| ,y)))))) - -(defmacro |SIntBit| (x i) - `(let ((xx ,x) (ii ,i)) (declare (type |SInt| xx ii)) (logbitp ii xx))) -(defmacro |SIntNot| (a) `(the |SInt| (lognot (the |SInt| ,a)))) -(defmacro |SIntAnd| (a b) - `(the |SInt| (logand (the |SInt| ,a) (the |SInt| ,b)))) -(defmacro |SIntOr| (a b) - `(the |SInt| (logior (the |SInt| ,a) (the |SInt| ,b)))) - -;; WordTimesDouble -;; WordDivideDouble -;; WordPlusStep -;; WordTimesStep - -(defmacro |SIntSIPower| (x y) - `(let ((xx ,x) (yy ,y)) - (declare (type |SInt| xx yy)) - (if (minusp yy) (error "cannot raise integers to negative powers") - (the |SInt| (expt xx yy))))) -(defmacro |SIntBIPower| (x y) - `(let ((xx ,x) (yy ,y)) - (declare (type |SInt| xx)) - (declare (type |BInt| yy)) - (if (minusp yy) (error "cannot raise integers to negative powers") - (the |SInt| (expt xx yy))))) - -(defmacro |BInt0| () 0) -(defmacro |BInt1| () 1) -(defmacro |BIntIsZero| (x) `(zerop (the |BInt| ,x))) -(defmacro |BIntIsNeg| (x) `(minusp(the |BInt| ,x))) -(defmacro |BIntIsPos| (x) `(plusp (the |BInt| ,x))) -(defmacro |BIntIsEven| (x) `(evenp (the |BInt| ,x))) -(defmacro |BIntIsOdd| (x) `(oddp (the |BInt| ,x))) -(defmacro |BIntIsSingle| (x) `(typep ,x '|SInt|)) -(defmacro |BIntLE| (x y) `(<= (the |BInt| ,x) (the |BInt| ,y))) -(defmacro |BIntEQ| (x y) `(= (the |BInt| ,x) (the |BInt| ,y))) -(defmacro |BIntLT| (x y) `(< (the |BInt| ,x) (the |BInt| ,y))) -(defmacro |BIntNE| (x y) `(/= (the |BInt| ,x) (the |BInt| ,y))) -(defmacro |BIntNegate| (x) `(the |BInt| (- (the |BInt| ,x)))) -(defmacro |BIntPrev| (x) `(the |BInt| (1- (the |BInt| ,x)))) -(defmacro |BIntNext| (x) `(the |BInt| (1+ (the |BInt| ,x)))) -(defmacro |BIntPlus| (x y) `(the |BInt| (+ (the |BInt| ,x) (the |BInt| ,y)))) -(defmacro |BIntMinus| (x y) `(the |BInt| (- (the |BInt| ,x) (the |BInt| ,y)))) -(defmacro |BIntTimes| (x y) `(the |BInt| (* (the |BInt| ,x) (the |BInt| ,y)))) -(defmacro |BIntTimesPlus| (x y z) - `(the |BInt| (+ (* (the |BInt| ,x) (the |BInt| ,y)) (the |BInt| ,z)))) -(defmacro |BIntMod| (x y) `(the |BInt| (mod(the |BInt| ,x)(the |BInt| ,y)))) -(defmacro |BIntQuo| (x y) - `(the |BInt| (values (truncate (the |BInt| ,x) (the |BInt| ,y))))) -(defmacro |BIntRem| (x y) - `(the |BInt| (rem (the |BInt| ,x) (the |BInt| ,y)))) -(defmacro |BIntDivide| (x y) `(truncate (the |BInt| ,x) (the |BInt| ,y))) -(defmacro |BIntGcd| (x y) - `(the |BInt| (gcd (the |BInt| ,x) (the |BInt| ,y)))) -(defmacro |BIntSIPower| (x y) - `(let ((xx ,x) (yy ,y)) - (declare (type |BInt| xx)) - (declare (type |SInt| yy)) - (if (minusp yy) (error "cannot raise integers to negative powers") - (the |BInt| (expt xx yy))))) -(defmacro |BIntBIPower| (x y) - `(let ((xx ,x) (yy ,y)) - (declare (type |BInt| xx)) - (declare (type |BInt| yy)) - (if (minusp yy) (error "cannot raise integers to negative powers") - (the |BInt| (expt xx yy))))) -(defmacro |BIntLength| (x) `(the |SInt| (integer-length (the |BInt| ,x)))) -(defmacro |BIntShiftUp| (x y) `(the |BInt| (ash (the |BInt| ,x)(the |SInt| ,y)))) -(defmacro |BIntShiftDn| (x y) `(the |BInt| (ash (the |BInt| ,x) (the |SInt| (- (the |SInt| ,y)))))) - -(defmacro |BIntBit| (x i) - `(let ((xx ,x) (ii ,i)) (declare (type |BInt| xx) (type |SInt| ii)) - (logbitp ii xx))) -;;(defmacro |BIntAbs| (x) `(the |BInt| (abs (the |BInt| ,x)))) - -(defmacro |PtrNil| () ()) -(defmacro |PtrIsNil| (x) `(NULL ,x)) -(defmacro |PtrEQ| (x y) `(eq ,x ,y)) -(defmacro |PtrNE| (x y) `(not (eq ,x ,y))) - -;; |WordTimesDouble| |WordDivideDouble| |WordPlusStep| |WordTimesStep| - - -;;(defvar |FoamOutputString| -;; (make-array 80 :element-type 'string-char :adjustable t :fill-pointer 0)) -(defun |FormatNumber| (c arr i) - (setq str (format nil "~a" c)) - (replace arr str :start1 i) -;; (incf i (fill-pointer |FoamOutputString|)) -;; (if (> i (length arr)) (error "not enough space")) -;; (setf (fill-pointer |FoamOutputString|) 0) - (+ i (length str))) - -(defmacro |FormatSFlo| (c arr i) `(|FormatNumber| ,c ,arr ,i)) -(defmacro |FormatDFlo| (c arr i) `(|FormatNumber| ,c ,arr ,i)) -(defmacro |FormatSInt| (c arr i) `(|FormatNumber| ,c ,arr ,i)) -(defmacro |FormatBInt| (c arr i) `(|FormatNumber| ,c ,arr ,i)) - -(set-syntax-from-char (code-char 0) #\space) ;;makes null char act like white space - -(defmacro |ScanSFlo| (arr i) - `(read-from-string ,arr nil (|SFlo0|) - :start ,i :preserve-whitespace t)) -(defmacro |ScanDFlo| (arr i) - `(read-from-string ,arr nil (|DFlo0|) - :start ,i :preserve-whitespace t)) -(defmacro |ScanSInt| (arr i) - `(parse-integer ,arr :start ,i :junk-allowed t)) -(defmacro |ScanBInt| (arr i) - `(parse-integer ,arr :start ,i :junk-allowed t)) - -;; 18/8/93: Evil bug in genfoam---nil generated. -(defmacro hacked-the (type x) - (if x `(the ,type ,x) `(the ,type 0))) - -(defmacro |ByteToSInt| (x) `(coerce (hacked-the |Byte| ,x) '|SInt|)) -(defmacro |BoolToSInt| (x) `(if ,x 1 0)) -(defmacro |BIntToSInt| (x) `(hacked-the |SInt| ,x)) -(defmacro |SIntToBInt| (x) `(hacked-the |BInt| ,x)) -(defmacro |SIntToSFlo| (x) `(coerce (hacked-the |SInt| ,x) '|SFlo|)) -(defmacro |SIntToByte| (x) `(coerce (hacked-the |SInt| ,x) '|Byte|)) -(defmacro |SIntToHInt| (x) `(coerce (hacked-the |SInt| ,x) '|HInt|)) -(defmacro |SIntToDFlo| (x) `(coerce (hacked-the |SInt| ,x) '|DFlo|)) -(defmacro |BIntToSFlo| (x) `(coerce (hacked-the |BInt| ,x) '|SFlo|)) -(defmacro |BIntToDFlo| (x) `(coerce (hacked-the |BInt| ,x) '|DFlo|)) -(defmacro |ArrToSFlo| (x) `(read-from-string ,x nil (|SFlo0|))) -(defmacro |ArrToDFlo| (x) `(read-from-string ,x nil (|DFlo0|))) -(defmacro |ArrToSInt| (x) `(read-from-string ,x nil (|SInt0|))) -(defmacro |ArrToBInt| (x) `(read-from-string ,x nil (|BInt0|))) - -(defmacro |Clos| (x y) `(let ((xx ,x) (yy #',y)) (cons yy xx))) -(defmacro |ClosFun| (x) `(car ,x)) -(defmacro |ClosEnv| (x) `(cdr ,x)) -(defmacro |SetClosFun| (x y) `(rplaca ,x ,y)) -(defmacro |SetClosEnv| (x y) `(rplacd ,x ,y)) - -(defmacro |MakeEnv| (x y) - `(let ((xx ,x) (yy ,y)) (cons yy (cons xx nil)))) - -(defmacro |EnvLevel| (x) `(car ,x)) -(defmacro |EnvNext| (x) `(cadr ,x)) -(defmacro |EnvInfo| (x) `(if (and (consp ,x) (consp (cdr ,x))) - (cddr ,x) nil)) -(defmacro |SetEnvInfo| (x val) `(rplacd (cdr ,x) ,val)) - -#+:CCL -(defmacro |FoamEnvEnsure| (e) - `(let ((einf (|EnvInfo| ,e))) - (if einf (|CCall| einf) nil))) -#-:CCL -(defmacro |FoamEnvEnsure| (e) - `(if (|EnvInfo| ,e) (|CCall| (|EnvInfo| ,e)) nil)) - -(defconstant null-char-string (string (code-char 0))) -(defmacro |MakeLit| (s) `(concatenate 'string ,s null-char-string)) - -;; functions are represented by symbols, with the symbol-value being some -;; information, and the symbol-function is the function itself. -;; 1-valued lisp should represent progs as either a pair or defstruct. - -(defmacro |FunProg| (x) x) - -(defstruct FoamProgInfoStruct - (funcall nil :type function) - (hashval 0 :type |SInt|)) - -(defun |ProgHashCode| (x) - (let ((aa (foam-function-info x))) - (if (null aa) 0 - (FoamProgInfoStruct-hashval aa)))) - -(defun |SetProgHashCode| (x y) - (let ((aa (foam-function-info x))) - (if (null aa) 0 - (setf (FoamProgInfoStruct-hashval aa) y)))) - -;; In a hurry -> O(n) lookup.. -(defvar foam-function-list ()) - -(defun alloc-prog-info (fun val) - (setq foam-function-list (cons (cons fun val) foam-function-list))) - -(defun foam-function-info (fun) - (let ((xx (assoc fun foam-function-list))) - (if (null xx) nil - (cdr xx)))) - -;; Accessors and constructors -(defmacro |DDecl| (name &rest args) - (setf (get name 'struct-args) args) - `(defstruct ,name ,@(insert-types args))) - -(defun insert-types (slots) - (mapcar #'(lambda (slot) - `(,(car slot) ,(type2init (cadr slot)) - :type ,(cadr slot))) - slots)) - -(defmacro |RNew| (name) - (let* ((struct-args (get name 'struct-args)) - (init-args (mapcar #'(lambda (x) (type2init (cadr x))) - struct-args)) - (count (length struct-args))) - (cond ((> count 2) `(vector ,@init-args)) - ((= count 2) `(cons ,@init-args)) - (t `(list ,@init-args))))) - -(defmacro |RElt| (name field index rec) - (let ((count (length (get name 'struct-args)))) - (cond ((> count 2) `(svref ,rec ,index)) - ((= count 2) - (if (zerop index) `(car ,rec) `(cdr ,rec))) - (t `(car ,rec))))) - -(defmacro |SetRElt| (name field index rec val) - (let ((count (length (get name 'struct-args)))) - (cond ((> count 2) `(setf (svref ,rec ,index) ,val)) - ((= count 2) - (if (zerop index) `(rplaca ,rec ,val) `(rplacd ,rec ,val))) - (t `(rplaca ,rec ,val))))) - -(defmacro |AElt| (name index) - `(aref ,name ,index)) - -(defmacro |SetAElt| (name index val) - `(setf (aref ,name ,index) ,val)) - -(defmacro |MakeLevel| (builder struct) - (if (get struct 'struct-args) - `(,builder) - 'nil)) - - -(defmacro |EElt| (accessor n var) - `(,accessor ,var)) - -(defmacro |SetEElt| (accessor n var val) - `(setf (,accessor ,var) ,val)) - -(defmacro |Lex| (accessor n var) - `(,accessor ,var)) - -(defmacro |SetLex| (accessor n var val) - `(progn ;; (print ',accessor) - (setf (,accessor ,var) ,val))) - -;; Atomic arguments for fun don't need a let to hold the fun. -;; CCall's with arguments need a let to hold the prog and the env. -(defmacro |CCall| (fun &rest args) - (cond ((and (atom fun) (null args)) - `(funcall (|FunProg| (|ClosFun| ,fun)) (|ClosEnv| ,fun))) - ((null args) - `(let ((c ,fun)) - (funcall (|FunProg| (|ClosFun| c)) (|ClosEnv| c)))) - ((atom fun) - `(let ((fun (|FunProg| (|ClosFun| ,fun))) - (env (|ClosEnv| ,fun))) - (funcall fun ,@args env))) - (t - `(let ((c ,fun)) - (let ((fun (|FunProg| (|ClosFun| c))) - (env (|ClosEnv| c))) - (funcall fun ,@args env)))))) - -(defmacro |FoamFree| (o) '()) - -;; macros for defining things - -(defmacro declare-prog (name-result params) - `(proclaim '(function ,(car name-result) ,params ,@(cdr name-result)))) - -(defmacro declare-type (name type) - `(proclaim '(type ,name ,type))) - -(defmacro defprog (type temps &rest body) - `(progn (defun ,(caar type) ,(mapcar #'car (cadr type)) - (typed-let ,temps ,@body)) - (alloc-prog-info #',(caar type) (make-FoamProgInfoStruct)))) - -(defmacro defspecials (&rest lst) - `(proclaim '(special ,@lst))) - -(defmacro top-level-define (&rest junk) - `(setq ,@junk)) - -;; Runtime macros - -;; control transfer -(defmacro block-return (obj val) - `(return-from ,obj ,val)) - -#-:CCL -(defmacro typed-let (letvars &rest forms) - `(let ,(mapcar #'(lambda (var) - (list (car var) (type2init (cadr var)))) - letvars ) - (declare ,@(mapcar #'(lambda (var) - (list 'type (cadr var) (car var))) - letvars)) - ,@forms)) - -#+:CCL -(defmacro typed-let (letvars &rest forms) - `(let ,(mapcar #'(lambda (var) (car var)) - letvars ) - ,@forms)) - -(defmacro cases (&rest junk) - `(case ,@junk)) - - -;;; Boot macros -(defmacro file-exports (lst) - `(eval-when (load eval) - (when (fboundp 'process-export-entry) - (mapcar #'process-export-entry ,lst)) - nil)) - -(defmacro file-imports (lst) - `(eval-when (load eval) - (when (fboundp 'process-import-entry) - (mapcar #'process-import-entry ,lst)) - nil)) - -(defmacro ignore-var (var) - `(declare (ignore ,var))) - -(defmacro |ANew| (type size) - (if (eq type '|Char|) - `(make-string ,size) - `(make-array ,size - :element-type ',type - :initial-element ,(type2init type)))) - -#-:CCL -(defun type2init (x) - (cond - ((eq x '|Char|) '|CharInit|) - ((eq x '|Clos|) '|ClosInit|) - ((eq x '|Bool|) '|BoolInit|) - ((eq x '|Byte|) '|ByteInit|) - ((eq x '|HInt|) '|HIntInit|) - ((eq x '|SInt|) '|SIntInit|) - ((eq x '|BInt|) '|BIntInit|) - ((eq x '|SFlo|) '|SFloInit|) - ((eq x '|DFlo|) '|DFloInit|) - ((eq x '|Ptr|) '|PtrInit|) - ((eq x '|Word|) '|WordInit|) - ((eq x '|Arr|) '|ArrInit|) - ((eq x '|Record|) '|RecordInit|) - ((eq x '|Arb|) '|ArbInit|) - ((eq x '|Env|) '|EnvInit|) - ((eq x '|Level|) '|LevelInit|) - ((eq x '|Nil|) nil) - (t nil))) - -#+:CCL -(defun type2init (x) nil) - -;; opsys interface -(defvar |G-mainArgc| 0) -(defvar |G-mainArgv| (vector)) -(defmacro |stdinFile| () '*standard-input*) -(defmacro |stdoutFile| () '*standard-output*) -(defmacro |stderrFile| () '*error-output*) - -;; Format functions -;needs to stop when it gets a null character -(defun |strLength| (s) - (dotimes (i (length s)) - (let ((c (schar s i))) - (if (char= c |CharCode0|) - (return i)))) - (length s)) - -(defun |formatSInt| (n) (format nil "~D" n)) -(defun |formatBInt| (n) (format nil "~D" n)) -(defun |formatSFloat| (x) (format nil "~G" x)) -(defun |formatDFloat| (x) (format nil "~G" x)) - - -;; Printing functions -(defun |printNewLine| (cs) (terpri cs)) -(defun |printChar| (cs c) (princ c cs)) - -;needs to stop when it gets a null character -(defun |printString| (cs s) - (dotimes (i (length s)) - (let ((c (schar s i))) - (if (char= c |CharCode0|) - (return i) - (princ c cs))))) - -(defun |printSInt| (cs n) (format cs "~D" n)) -(defun |printBInt| (cs n) (format cs "~D" n)) -(defun |printSFloat| (cs x) (format cs "~G" x)) -(defun |printDFloat| (cs x) (format cs "~G" x)) - -(defun |fputc| (si cs) - (|printChar| cs (code-char si)) - si) - -(defun |fputs| (s cs) - (|printString| cs s)) - -;; read a string into s starting at pos i1, ending at i2 -;; we should probably macro-out cases where args are constant - -;; fill s[i1..i2] with a null terminated string read from -;; the given input stream -(defun |fgetss| (s i1 i2 f) - (labels ((aux (n) - (if (= n i2) - (progn (setf (schar s n) (code-char 0)) - (- n i1)) - (let ((c (read-char f))) - (setf (schar s n) c) - (if (equal c #\newline) - (progn (setf (char s (+ n 1)) (code-char 0)) - (- n i1)) - (aux (+ n 1))))))) - (aux i1))) - -;; write s[i1..i2) to the output stream f -;; stop on any null characters - -(defun |fputss| (s i1 i2 f) - (labels ((aux (n) - (if (= n i2) (- n i1) - (let ((c (schar s n))) - (if (equal (code-char 0) c) - (- n i1) - (progn (princ c f) - (aux (+ n 1)))))))) - (setq i2 (if (minusp i2) (|strLength| s) - (min i2 (|strLength| s)))) - (aux i1))) - -;; function for compiling and loading from lisp - -(defun compile-as-file (file &optional (opts nil)) - (let* ((path (pathname file)) - (name (pathname-name path)) - (dir (pathname-directory path)) - (type (pathname-type path)) - (lpath (make-pathname :name name :type "l")) - (cpath (make-pathname :name name :type "o"))) - (if (null type) - (setq path (make-pathname :directory dir :name name :type "as"))) - (if opts - (system (format nil "axiomxl ~A -Flsp ~A" opts (namestring path))) - (system (format nil "axiomxl -Flsp ~A" (namestring path)))) - (compile-file (namestring lpath)) - (load (namestring cpath)))) - - -;; given the name of a file (a string), return the name of the AXIOM-XL function -;; that initialises the file. -(defun axiomxl-file-init-name (filename) - (intern (format nil "G-~a" (string-downcase filename)) 'foam-user)) - -;; given the name of the file, id name, and hashcode, return the -;; AXIOM-XL identifier for that object - -(defun axiomxl-global-name (file id hashcode) - (intern (format nil "G-~a_~a_~9,'0d" (string-downcase file) id hashcode) 'foam-user)) - -;; double float elementary functions -(defmacro |sqrt| (x) `(sqrt ,x)) -(defmacro |pow| (a b) `(expt ,a ,b)) -(defmacro |log| (a) `(log ,a)) -(defmacro |exp| (a) `(exp ,a)) - -(defmacro |sin| (a) `(sin ,a)) -(defmacro |cos| (a) `(cos ,a)) -(defmacro |tan| (a) `(tan ,a)) - -(defmacro |sinh| (a) `(sinh ,a)) -(defmacro |cosh| (a) `(cosh ,a)) -(defmacro |tanh| (a) `(tanh ,a)) - -(defmacro |asin| (a) `(asin ,a)) -(defmacro |acos| (a) `(acos ,a)) -(defmacro |atan| (a) `(atan ,a)) -(defmacro |atan2| (a b) `(atan ,a ,b)) - -(defun |Halt| (n) - (error (cond ((= n 101) "System Error: Unfortunate use of dependant type") - ((= n 102) "User error: Reached a 'never'") - ((= n 103) "User error: Bad union branch") - ((= n 104) "User error: Assertion failed") - (t (format nil "Unknown halt condition ~a" n))))) -;; debuging -(defvar *foam-debug-var* nil) -(defun |fiGetDebugVar| () *foam-debug-var*) - -(defun |fiSetDebugVar| (x) (setq *foam-debug-var* x)) -(defun |fiSetDebugger| (x y) ()) -(defun |fiGetDebugger| (x) ()) - -;; Output ports -(setq |G-stdoutVar| t) -(setq |G-stdinVar| t) -(setq |G-stderrVar| t) - -;; !! Not portable !! -(defun foam::|fiStrHash| (x) (boot::|hashString| (subseq x 0 (- (length x) 1)))) - -;; These three functions check that two cons's contain identical entries. -;; We use EQL to test numbers and EQ everywhere else. If the structure -;; of the two items is different, or any elements are different, we -;; return false. -(defmacro |politicallySound| (u v) - `(or (eql ,u ,v) (eq ,u ,v))) - -(defun |PtrMagicEQ| (u v) -;; I find (as-eg4) that these buggers can be numbers - (cond ( (or (NULL u) (NULL v)) nil) - ( (and (ATOM u) (ATOM v)) (eql u v)) - ( (or (ATOM u) (ATOM v)) nil) -;; removed for Aldor integration -;; ( (equal (length u) (length v)) (|magicEq1| u v)) - (t (eq u v) ))) - -(defun |magicEq1| (u v) - (cond ( (and (atom u) (atom v)) (|politicallySound| u v)) - ( (or (atom u) (atom v)) nil) - ( (|politicallySound| (car u) (car v)) (|magicEq1| (cdr u) (cdr v))) - nil )) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/ggreater.lisp b/src/interp/ggreater.lisp index a77438c0..c27ff31e 100644 --- a/src/interp/ggreater.lisp +++ b/src/interp/ggreater.lisp @@ -1,5 +1,7 @@ ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are diff --git a/src/interp/hash.lisp b/src/interp/hash.lisp new file mode 100644 index 00000000..b462a621 --- /dev/null +++ b/src/interp/hash.lisp @@ -0,0 +1,123 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + +(IMPORT-MODULE "vmlisp") +(in-package "BOOT") + +(export '(MAKE-HASHTABLE HGET HKEYS HCOUNT HPUT HPUT* HREM HCLEAR HREMPROP + HASHEQ HASHUEQUAL HASHCVEC HASHID HASHTABLEP CVEC UEQUAL ID HPUTPROP + HASHTABLE-CLASS)) + +;17.0 Operations on Hashtables +;17.1 Creation + +(defun MAKE-HASHTABLE (id1 &optional (id2 nil)) + (declare (ignore id2)) + (let ((test (case id1 + ((EQ ID) #'eq) + (CVEC #'equal) + (EQL #'eql) + #+Lucid ((UEQUAL EQUALP) #'EQUALP) + #-Lucid ((UEQUAL EQUAL) #'equal) + (otherwise (error "bad arg to make-hashtable"))))) + (make-hash-table :test test))) + +;17.2 Accessing + +(defmacro HGET (table key &rest default) + `(gethash ,key ,table ,@default)) + +(defun HKEYS (table) + (let (keys) + (maphash + #'(lambda (key val) (declare (ignore val)) (push key keys)) table) + keys)) + +#+Lucid +(define-function 'HASHTABLE-CLASS #'system::hash-table-test) + +#+AKCL +(clines "int mem_value(x ,i)object x;int i; { return ((short *)x)[i];}") +#+AKCL +(defentry memory-value-short(object int) (int "mem_value")) + +;(memory-value-short (make-hash-table :test 'equal) 12) is 0,1,or 2 +;depending on whether the test is eq,eql or equal. +#+AKCL +(defun HASHTABLE-CLASS (table) + (case (memory-value-short table 12) + (0 'EQ) + (1 'EQL) + (2 'EQUAL) + (t "error unknown hash table class"))) + +#+:CCL +(defun HASHTABLE-CLASS (table) + (case (hashtable-flavour table) + (0 'EQ) + (1 'EQL) + (2 'EQUAL) + (t (format nil "error unknown hash table class ~a" (hashtable-flavour table))))) + +(define-function 'HCOUNT #'hash-table-count) + +;17.4 Searching and Updating + +(defun HPUT (table key value) (setf (gethash key table) value)) + +(defun HPUT* (table alist) + (mapc #'(lambda (pair) (hput table (car pair) (cdr pair))) alist)) + +(defmacro HREM (table key) `(remhash ,key ,table)) + +(defun HREMPROP (table key property) + (let ((plist (gethash key table))) + (if plist (setf (gethash key table) + (delete property plist :test #'equal :key #'car))))) + +;17.5 Updating + +(define-function 'HCLEAR #'clrhash) + +;17.6 Miscellaneous + +(define-function 'HASHTABLEP #'hash-table-p) + +(define-function 'HASHEQ #'sxhash) + +(define-function 'HASHUEQUAL #'sxhash) + +(define-function 'HASHCVEC #'sxhash) + +(define-function 'HASHID #'sxhash) diff --git a/src/interp/hash.lisp.pamphlet b/src/interp/hash.lisp.pamphlet deleted file mode 100644 index be039807..00000000 --- a/src/interp/hash.lisp.pamphlet +++ /dev/null @@ -1,147 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/hash.lisp} Pamphlet} -\author{Timothy Daly} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} - -\tableofcontents -\eject - -\section{License} - -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -(IMPORT-MODULE "vmlisp") -(in-package "BOOT") - -(export '(MAKE-HASHTABLE HGET HKEYS HCOUNT HPUT HPUT* HREM HCLEAR HREMPROP - HASHEQ HASHUEQUAL HASHCVEC HASHID HASHTABLEP CVEC UEQUAL ID HPUTPROP - HASHTABLE-CLASS)) - -;17.0 Operations on Hashtables -;17.1 Creation - -(defun MAKE-HASHTABLE (id1 &optional (id2 nil)) - (declare (ignore id2)) - (let ((test (case id1 - ((EQ ID) #'eq) - (CVEC #'equal) - (EQL #'eql) - #+Lucid ((UEQUAL EQUALP) #'EQUALP) - #-Lucid ((UEQUAL EQUAL) #'equal) - (otherwise (error "bad arg to make-hashtable"))))) - (make-hash-table :test test))) - -;17.2 Accessing - -(defmacro HGET (table key &rest default) - `(gethash ,key ,table ,@default)) - -(defun HKEYS (table) - (let (keys) - (maphash - #'(lambda (key val) (declare (ignore val)) (push key keys)) table) - keys)) - -#+Lucid -(define-function 'HASHTABLE-CLASS #'system::hash-table-test) - -#+AKCL -(clines "int mem_value(x ,i)object x;int i; { return ((short *)x)[i];}") -#+AKCL -(defentry memory-value-short(object int) (int "mem_value")) - -;(memory-value-short (make-hash-table :test 'equal) 12) is 0,1,or 2 -;depending on whether the test is eq,eql or equal. -#+AKCL -(defun HASHTABLE-CLASS (table) - (case (memory-value-short table 12) - (0 'EQ) - (1 'EQL) - (2 'EQUAL) - (t "error unknown hash table class"))) - -#+:CCL -(defun HASHTABLE-CLASS (table) - (case (hashtable-flavour table) - (0 'EQ) - (1 'EQL) - (2 'EQUAL) - (t (format nil "error unknown hash table class ~a" (hashtable-flavour table))))) - -(define-function 'HCOUNT #'hash-table-count) - -;17.4 Searching and Updating - -(defun HPUT (table key value) (setf (gethash key table) value)) - -(defun HPUT* (table alist) - (mapc #'(lambda (pair) (hput table (car pair) (cdr pair))) alist)) - -(defmacro HREM (table key) `(remhash ,key ,table)) - -(defun HREMPROP (table key property) - (let ((plist (gethash key table))) - (if plist (setf (gethash key table) - (delete property plist :test #'equal :key #'car))))) - -;17.5 Updating - -(define-function 'HCLEAR #'clrhash) - -;17.6 Miscellaneous - -(define-function 'HASHTABLEP #'hash-table-p) - -(define-function 'HASHEQ #'sxhash) - -(define-function 'HASHUEQUAL #'sxhash) - -(define-function 'HASHCVEC #'sxhash) - -(define-function 'HASHID #'sxhash) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/interp-proclaims.lisp b/src/interp/interp-proclaims.lisp deleted file mode 100644 index 30d61fc7..00000000 --- a/src/interp/interp-proclaims.lisp +++ /dev/null @@ -1,3391 +0,0 @@ - -(IN-PACKAGE "USER") -(PROCLAIM '(FTYPE (FUNCTION (*) (VALUES T T)) BOOT:|ReadLine|)) -(PROCLAIM - '(FTYPE (FUNCTION (T) FUNCTION) FOAM::FOAMPROGINFOSTRUCT-FUNCALL)) -(PROCLAIM - '(FTYPE (FUNCTION (T) FIXNUM) BOOT::LINE-NUMBER BOOT::|eq0| - VMLISP:CHAR2NUM BOOT::|nothingWidth| BOOT::|nothingSub| - BOOT::|nothingSuper| BOOT::LINE-LAST-INDEX - BOOT::LINE-CURRENT-INDEX FOAM:|ProgHashCode| - FOAM:|strLength| BOOT:|StringLength| BOOT::|widthSC|)) -(PROCLAIM - '(FTYPE (FUNCTION (T) FOAM:|SInt|) - FOAM::FOAMPROGINFOSTRUCT-HASHVAL)) -(PROCLAIM - '(FTYPE (FUNCTION (T) (VALUES T T)) BOOT::|mkSharpVar| - BOOT::|makeCharacter| BOOT::|mapCatchName| - BOOT::|queryUser| BOOT:|LispKeyword| BOOT::MONITOR-INFO - BOOT::FILE-GETTER-NAME BOOT::|mkDomainCatName| - FOAM:AXIOMXL-FILE-INIT-NAME BOOT::|getKeyedMsg| - BOOT::|mkCacheName| BOOT::|mkAuxiliaryName|)) -(PROCLAIM - '(FTYPE (FUNCTION ((VECTOR T) (VECTOR T)) T) VMLISP::VGREATERP - VMLISP::LEXVGREATERP)) -(PROCLAIM '(FTYPE (FUNCTION ((VECTOR T)) T) BOOT:TRIMLZ)) -(PROCLAIM - '(FTYPE (FUNCTION (T) (*)) BOOT:|StringToInteger| - BOOT:|StringToFloat|)) -(PROCLAIM '(FTYPE (FUNCTION (T *) (VALUES T T)) VMLISP:|read-line|)) -(PROCLAIM '(FTYPE (FUNCTION (STRING FIXNUM) T) BOOT::|subWord|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T) FIXNUM) VMLISP:QSQUOTIENT - VMLISP:QSREMAINDER VMLISP:QENUM FOAM:|SetProgHashCode| - BOOT:GETCHARN BOOT::|attributeCategoryParentCount|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T) (VALUES T T)) BOOT::|htMakeLabel| - BOOT::|fetchKeyedMsg|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T) *) BOOT::|applpar1| BOOT::|apprpar1| - BOOT::|appargs1| BOOT::|appagg1| BOOT::|matrixBorder| - BOOT::|e02befDefaultSolve| BOOT::|e02agfDefaultSolve| - BOOT::|e02dafDefaultSolve| BOOT::|htQueryPage| - BOOT::|compileAndLink| BOOT::|f04jgfDefaultSolve| - BOOT::|f02aefDefaultSolve| BOOT::|f02agfDefaultSolve| - BOOT::|apphor| BOOT::|appvertline| BOOT::|applpar| - BOOT::|e04jafDefaultSolve| BOOT::|f01brfDefaultSolve| - BOOT::|e04ycfDefaultSolve|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T *) *) VMLISP:CONCAT - BOOT::LOCALDATABASE BOOT::FE BOOT::|ncBug|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T) *) BOOT::|replacePercentByDollar,fn| - BOOT::|getSlotFromDomain| BOOT::|ncGetFunction| - BOOT::|c02affDefaultSolve| BOOT::|c02agfDefaultSolve| - BOOT::|Qf2F| BOOT::|selectOptionLC| BOOT::|compUniquely| - BOOT::|compExpression| BOOT::|e02gafDefaultSolve| - BOOT::|e02aefDefaultSolve| BOOT::|e02bbfDefaultSolve| - BOOT::|asytranForm| BOOT::|asytranFormSpecial| - BOOT::|asytranApplySpecial| BOOT::SOCK-GET-STRING - BOOT::|sockGetString| BOOT::|showIt| BOOT::|pmPreparse,fn| - BOOT::|pmPreparse,gn| BOOT::|dbSearchAbbrev| - BOOT::|mkUpDownPattern,recurse| BOOT::|htMkPath| - BOOT::|getVal| BOOT::|htGlossPage| BOOT::|checkCondition| - BOOT::|compTopLevel| BOOT::GETOP - BOOT::|checkTransformFirsts| BOOT::|parseIf,ifTran| - BOOT::|dbShowOpAllDomains| BOOT::|templateVal| - BOOT::|dbChooseDomainOp| BOOT::|whoUsesOperation| - BOOT::|c05pbfDefaultSolve| BOOT::|c05nbfDefaultSolve| - BOOT::|c06frfDefaultSolve| BOOT::|c06ekfDefaultSolve| - BOOT::|NRTvectorCopy| BOOT::|c06fufDefaultSolve| - BOOT::|c06fpfDefaultSolve| BOOT::|c06fqfDefaultSolve| - BOOT::|applyInPackage| BOOT::|exp2FortSpecial| - BOOT::|f04mcfDefaultSolve| BOOT::|f04atfDefaultSolve| - BOOT::|f04fafDefaultSolve| BOOT::|f02affDefaultSolve| - BOOT::|dbShowCons1| BOOT::|f02aafDefaultSolve| - BOOT::|dbSelectCon| BOOT::|dbShowOperationsFromConform| - BOOT::|genSearch1| BOOT::|dbSearch| - BOOT::|constructorSearch| BOOT::|underscoreDollars,fn| - BOOT::|oSearchGrep| BOOT::|selectOption| - BOOT::|constructorSearchGrep| BOOT::|dbInfoChoose1| - BOOT::|bcDrawIt2| BOOT::|charybdis| BOOT::|bcMkFunction| - BOOT::|charyTop| BOOT::|bcDrawIt| - BOOT::|f01qcfDefaultSolve| BOOT::|e02zafDefaultSolve| - BOOT::|ncloopInclude0| VMLISP:$FCOPY)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T T) *) BOOT::|e02befColdSolve| - BOOT::|e02ahfDefaultSolve| BOOT::|e02akfDefaultSolve| - BOOT::|d02bbfDefaultSolve| BOOT::|d02cjfDefaultSolve| - BOOT::|e01sefDefaultSolve| BOOT::|htSetLiterals| - BOOT::|f04mbfDefaultSolve| BOOT::|f02axfDefaultSolve| - BOOT::|f02akfDefaultSolve| BOOT::|kcaPage1| - BOOT::MAKE-DEPSYS BOOT::|makeLongStatStringByProperty| - BOOT::|f01rdfDefaultSolve| BOOT::|f01qdfDefaultSolve|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T) *) BOOT::|compileConstructorLib| - BOOT::|quoteApp| BOOT::|argsapp| BOOT::|appargs| - BOOT::|inApp| BOOT::|appsc| BOOT::|appfrac| BOOT::|exptApp| - BOOT::|charyTrouble| BOOT::|overbarApp| - BOOT::|appHorizLine| BOOT::|overlabelApp| BOOT::/D-1 - BOOT::|appmat| BOOT::|e01bhfDefaultSolve| - BOOT::|e02adfDefaultSolve| BOOT::|e02bcfDefaultSolve| - BOOT::|makeStream| BOOT::|newExpandLocalTypeArgs| - FOAM:|fputss| FOAM:|fgetss| BOOT::|f01mafDefaultSolve| - BOOT::|conform2StringList| BOOT::|f02abfDefaultSolve| - BOOT::|f02awfDefaultSolve| BOOT::|f02ajfDefaultSolve| - BOOT::|f02adfDefaultSolve| BOOT::|patternCheck,mknew| - BOOT::|kDomainName| BOOT::|koPageAux| BOOT::|dbShowOp1| - BOOT::APP BOOT::|appagg| BOOT::|binomialApp| - BOOT::|charyTrouble1| BOOT::|appsub| BOOT::|slashApp| - BOOT::|appsetq| BOOT::|makeStatString| - BOOT::|e02dffDefaultSolve| BOOT::|e04dgfDefaultSolve| - BOOT::|e04fdfDefaultSolve| BOOT::|e04gcfDefaultSolve| - BOOT::|f01refDefaultSolve| BOOT::|f01qefDefaultSolve|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T T T T) *) BOOT::|makeFortranFun| - BOOT::|d03eefDefaultSolve| BOOT::|e04nafDefaultSolve|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T) *) BOOT::|e02ajfDefaultSolve| - BOOT::|e02dcfDefaultSolve| BOOT::|e02ddfDefaultSolve| - BOOT::|d02ejfDefaultSolve| BOOT::|d02bhfDefaultSolve| - BOOT::|d01fcfDefaultSolve| BOOT::|d01gbfDefaultSolve| - BOOT::|f04qafDefaultSolve| BOOT::|f02bjfDefaultSolve| - BOOT::|f02bbfDefaultSolve| BOOT::|e04mbfDefaultSolve|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T T T T T T T T) *) - BOOT::BUILD-INTERPSYS)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T T) *) BOOT::|e02ddfColdSolve| - BOOT::|f02xefDefaultSolve| BOOT::|f02wefDefaultSolve| - BOOT::BUILD-DEPSYS)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T T T) *) BOOT::|e04ucfDefaultSolve| - BOOT::|e02dcfColdSolve| BOOT::|d02kefDefaultSolve| - BOOT::|d02gbfDefaultSolve| BOOT::|d02gafDefaultSolve|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T T T T T T T) *) - BOOT::|d02rafDefaultSolve|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T) T) BOOT::|mapRecurDepth| BOOT::THETACHECK - BOOT::|flowSegmentedMsg| BOOT::|rewriteMap0| - BOOT::|restoreDependentMapInfo| BOOT::|dcSig| - BOOT::|analyzeNonRecur| BOOT::|addMap| BOOT::|fortCall| - BOOT::|axAddLiteral| BOOT::|writeStringLengths| - BOOT::|writeXDR| BOOT::|deleteMap| BOOT::|fnameNew| - BOOT::|axFormatDefaultOpSig| BOOT::|htpSetProperty| - BOOT::|rewriteMap1| BOOT::|displayMap| - BOOT::|compileDeclaredMap| BOOT::|compileCoerceMap| - BOOT::|displaySingleRule| BOOT::|hasAtt| BOOT::|hasAttSig| - BOOT::SPADRWRITE0 BOOT::SPADRWRITE BOOT::|recordNewValue| - BOOT::|recordOldValue| BOOT::|orderUnionEntries,split| - BOOT::|getSlotNumberFromOperationAlist| - BOOT::|isSuperDomain| BOOT::|recordOldValue0| - BOOT::|PARSE-getSemanticForm| BOOT::|recordNewValue0| - BOOT::|getSlotFromFunctor| BOOT::|addConstructorModemaps| - BOOT::|compDefWhereClause| BOOT::|get1| BOOT::|get2| - BOOT::|get0| BOOT::|throwListOfKeyedMsgs| - BOOT::|getConstructorOpsAndAtts| - BOOT::|mkExplicitCategoryFunction| - BOOT::|findDomainSlotNumber| BOOT::|addIntSymTabBinding| - BOOT::|sigsMatch| BOOT::|compDefineAddSignature| - BOOT::|hasFullSignature| BOOT:ELEMN BOOT::|mkAtree2| - BOOT::|mkAtree3| BOOT::|getValueFromSpecificEnvironment| - BOOT::|compForMode| BOOT::|transferPropsToNode,transfer| - BOOT::|genDomainOps| BOOT::|getOperationAlist| - BOOT::|remprop| BOOT::|setMsgForcedAttr| BOOT::|P2Uts| - BOOT::|Up2FR| BOOT::|mac0Define| BOOT::|getMappingArgValue| - BOOT::|compContained| BOOT::|getArgValueComp| - BOOT::|altTypeOf| BOOT::|mac0InfiniteExpansion| - BOOT::|setMsgUnforcedAttr| BOOT::|genDomainViewList| - BOOT::|compSubDomain| BOOT::|compCapsule| - BOOT::|sideEffectedArg?| BOOT::|evalFormMkValue| - BOOT::|doItIf| BOOT::|compSingleCapsuleItem| - BOOT::|compJoin| BOOT::|rewriteMap| - BOOT::|NRTgetLookupFunction| BOOT::|lisplibWrite| - BOOT::|getLocalMms| BOOT::|makeFunctorArgumentParameters| - BOOT::|selectMmsGen,exact?| BOOT::REDUCE-1 - BOOT::|getLocalMms,f| BOOT::|isOpInDomain| - BOOT::|compDefine| BOOT::|compCategory| - BOOT::|getTargetFromRhs| BOOT::|unifyStructVar| - BOOT::|augmentSub| BOOT::|unifyStruct| BOOT::|compAdd| - BOOT::|filterModemapsFromPackages| BOOT::|constrArg| - BOOT::|evalMmCond0| BOOT::|maprinSpecial| BOOT::|hasCaty| - BOOT::|evalMmCond| BOOT:ADDASSOC BOOT::|hasCate| - BOOT::|matchTypes| BOOT::|findUniqueOpInDomain| - BOOT::|hasSigOr| BOOT::|hasSigAnd| - BOOT::|findCommonSigInDomain| BOOT::|evalMmCat1| - BOOT::|coerceTypeArgs| BOOT::|domArg2| BOOT::|L2Tuple| - BOOT::V2M BOOT::DEF-INNER BOOT::|OV2Sy| BOOT::|Qf2EF| - BOOT::|Sy2P| BOOT::I2NNI BOOT::|Rm2L| BOOT::|Var2OtherPS| - BOOT::|Var2UpS| BOOT::OV2SE BOOT::|NDmp2domain| VMLISP:PUT - BOOT::|Var2Up| BOOT::|Expr2Mp| BOOT::|Expr2Dmp| - BOOT::|Sy2NDmp| VMLISP:DEFIOSTREAM BOOT::|Dmp2P| - BOOT::|Sy2Mp| BOOT::|Var2SUP| BOOT::|Factored2Factored| - VMLISP:EQSUBSTLIST BOOT::I2PI BOOT::|P2Expr| BOOT::|P2Up| - BOOT::|P2Dmp| BOOT::|Var2FS| BOOT::|Sy2Dmp| BOOT::B-MDEF - BOOT::|Ker2Expr| BOOT::|Sy2OV| BOOT::|Var2QF| BOOT::|Sm2V| - BOOT::M2V BOOT::|Var2P| BOOT::I2OI BOOT::P2FR - BOOT::|makeEijSquareMatrix| BOOT::|Set2L| BOOT::|Sm2Rm| - BOOT::DEF BOOT::|Var2NDmp| BOOT::|Dmp2Dmp| - BOOT::|coerceDmp2| BOOT::|rread| BOOT::I2EI BOOT::|Var2Mp| - BOOT::|compCapsuleInner| BOOT::|Mp2FR| BOOT::|Qf2domain| - BOOT::|compCapsuleItems| BOOT::|L2Set| BOOT::|Var2Gdmp| - BOOT::COMP-ILAM BOOT::COMP-SPADSLAM BOOT::|L2Sm| - BOOT::|mkCategoryPackage| BOOT::COMP-SLAM BOOT::L2M - BOOT::|compDefine1| BOOT::|Mp2Expr| BOOT::|Ker2Ker| - BOOT::|Var2Dmp| VMLISP:MSUBST BOOT::|Dmp2NDmp| - BOOT::|Sm2PolyType| BOOT::|Var2OV| - BOOT::|orderPredicateItems| BOOT::|L2Rm| BOOT::|substVars| - BOOT::|OV2poly| BOOT::|Sm2M| - BOOT::|augmentLisplibModemapsFromFunctor| BOOT::OV2P - BOOT::|needBlankForRoot| BOOT::|Rn2F| - BOOT::|getInCoreModemaps| BOOT::|Sm2L| BOOT::|splitConcat| - BOOT::|Un2E| BOOT::|SUP2Up| BOOT::OV2OV - BOOT::|insertAlist,fn| BOOT::|replaceVars| - BOOT::|compFromIf| BOOT::|Scr2Scr| BOOT::|compBoolean| - BOOT::|L2Record| BOOT::|Rm2V| VMLISP:RPLNODE - BOOT::|domain2NDmp| BOOT::|Up2Up| - BOOT::|augLisplibModemapsFromCategory| BOOT::|P2Mp| - BOOT::|compWithMappingMode,FreeList| BOOT::|orderPredTran| - BOOT::|Rm2Sm| BOOT::|Rm2M| BOOT::|Up2SUP| BOOT::|Mp2Up| - BOOT::|Mp2Dmp| BOOT::|LargeMatrixp| BOOT::DP2DP - BOOT::|Dmp2Up| BOOT::|Up2P| BOOT::|Complex2Expr| - BOOT::|seteltModemapFilter| BOOT::/MONITORX BOOT::|P2Upxs| - BOOT::|coerceTraceFunValue2E| BOOT::|Complex2FR| - BOOT::|Up2Mp| BOOT::V2L BOOT::|P2Uls| BOOT::|M2Sm| - BOOT::|coerceTraceArgs2E| BOOT::|Complex2underDomain| - BOOT::|resolveTTRed2| BOOT::|Agg2L2Agg| - BOOT::|resolveTTRed1| BOOT::|fnameMake| - BOOT::MONITOR-PRINARGS VMLISP:HREMPROP - BOOT::|eltModemapFilter| BOOT::|coerceOrCroak| - BOOT::|resolveTTEq2| BOOT::|resolveTTEq1| - BOOT::|matchUpToPatternVars| - BOOT::|getConditionalCategoryOfType| - BOOT::|getSubDomainPredicate| BOOT::|resolveTMEq2| - BOOT::|coerceIntX| BOOT::|compSymbol| - BOOT::|coerceSubDomain| BOOT::|compExpressionList| - BOOT::|NRTcompileEvalForm| BOOT::|setqMultiple,decompose| - BOOT::|permuteToOrder| BOOT::|retractUnderDomain| - BOOT::|compList| BOOT::SMALL-ENOUGH-COUNT - BOOT::|isRectangularList| BOOT::|augModemapsFromDomain1| - BOOT::|canCoerceByFunction1| - BOOT::|sayFunctionSelectionResult| BOOT::|compForm| - BOOT::|compTypeOf| BOOT::|comp3| BOOT::|coerceOrFail| - BOOT::|computeTTTranspositions,compress| BOOT::|algEqual| - BOOT::|compiledLookupCheck| VMLISP:RWRITE - BOOT::|coerceOrThrowFailure| BOOT::|NRTcompiledLookup| - BOOT::|spad2BootCoerce| BOOT::|M2Rm| BOOT::M2M - VMLISP:MACRO-INVALIDARGS BOOT::L2V BOOT::|Mp2P| - BOOT::|Mp2Mp| BOOT::|coerceDmpCoeffs| BOOT::|Expr2Complex| - BOOT::|Dmp2Expr| BOOT::|coerceFFE| BOOT::M2L VMLISP:QESET - BOOT::|V2Sm| BOOT::|isRectangularVector| BOOT::V2DP - BOOT::L2DP BOOT::|Up2Expr| BOOT::|Qf2Qf| BOOT::|NDmp2NDmp| - BOOT::|V2Rm| BOOT::|Qf2PF| BOOT::|Dmp2Mp| BOOT::|Up2Dmp| - BOOT::|Sy2Var| BOOT::|Agg2Agg| BOOT::|Expr2Up| - BOOT::|Sy2Up| VMLISP:HPUT BOOT::|pvarCondList1| - VMLISP:SUBSTRING BOOT::|interpRewriteRule| BOOT::|putAtree| - BOOT::|isEltable| BOOT::|selectMms| BOOT::|throwKeyedMsgSP| - BOOT::|pushDownTargetInfo| - BOOT::|pushDownOnArithmeticVariables| - BOOT::|keyedMsgCompFailureSP| BOOT::|intCodeGenCoerce1| - BOOT::|throwKeyedMsgCannotCoerceWithValue| - BOOT::|asytranForm1| BOOT::|hput| BOOT::|asyCattranOp1| - BOOT::|asyMakeOperationAlist| BOOT::|setVector4| - BOOT::|SetDomainSlots124| BOOT::|asGetExports| - BOOT::|asySig1| BOOT::|ncPutQ| - BOOT::|putConstructorProperty| BOOT::|throwKeyedErrorMsg| - BOOT::|mkUserConstructorAbbreviation| - BOOT::|unabbrevSpecialForms| BOOT::|nAssocQ| - BOOT::|New,ENTRY,2| BOOT::READ-INPUT BOOT::READ-SPAD - BOOT::|errorSupervisor1| BOOT::|argumentDataError| - BOOT::|BesselasymptA| BOOT::|htpSetLabelSpadValue| - BOOT::|optPackageCall| BOOT::|from?| BOOT::|clngamma| - BOOT::|chebevalarr| BOOT::|PsiBack| BOOT::|logH| - BOOT::|PiMinusLogSinPi| BOOT::|besselIcheb| - BOOT::|chebstarevalarr| BOOT::|chebf01coefmake| - BOOT::|clngammacase23| BOOT::|PsiAsymptoticOrder| - BOOT::|grepf| BOOT::|clngammacase1| BOOT::|cotdiffeval| - BOOT::|BesselIAsympt| BOOT::|lffloat| - BOOT::|substringMatch| BOOT::|makeResultRecord| - BOOT::|makeCompilation| BOOT::|extractFileNameFromPath,fn| - BOOT::|makeAspGenerators| BOOT::|makeAspGenerators1| - BOOT::|mkNewUnionFunList| BOOT::|EnumEqual| - BOOT::|cleanUpAfterNagman| BOOT::|sySpecificErrorAtToken| - BOOT::|prepareResults,defaultValue| - BOOT::|setVector4Onecat| BOOT::|pfLambda| BOOT::|pfWIf| - BOOT::|SigSlotsMatch| BOOT::|DomainPrint1| - BOOT::|DescendCodeAdd1,update| BOOT::|CheckVector| - BOOT::|pfTLambda| BOOT::|htSystemVariables,fn| - BOOT::|postCollect,finish| VMLISP:|nsubst| - BOOT::|npBackTrack| BOOT::|bchtMakeButton| - BOOT::|compWhere| BOOT::|compVector| BOOT::|compAtom| - BOOT::|getUniqueModemap| BOOT::|modeIsAggregateOf| - BOOT::|compArgumentsAndTryAgain| VMLISP:MACRO-MISSINGARGS - BOOT::|compForm1| BOOT::|mergeModemap| - BOOT::|compSubsetCategory| BOOT::|compString| - BOOT::|augModemapsFromDomain| BOOT::|compWithMappingMode| - BOOT::|extractCodeAndConstructTriple| BOOT::|compCat| - BOOT::|pfWith| BOOT::|compMakeDeclaration| - BOOT::|extendsCategoryForm| BOOT::|compSeq| - BOOT::|compSeq1| BOOT::|compReturn| BOOT::|isSubset| - BOOT::|getModemapList| BOOT::|compCase1| - BOOT::|compCoerce1| BOOT::|compPretend| BOOT::|compMacro| - BOOT::|compConstructorCategory| BOOT::|compCoerce| - BOOT::|compColon| BOOT::|compSetq| BOOT::|compLeave| - BOOT::|npList| BOOT::|modeEqualSubst| BOOT::|compIf| - BOOT::|compIs| BOOT::|comp2| BOOT::|compImport| - BOOT::|coerce,fn| BOOT::|throwKeyedMsgFromDb| - BOOT::|sayKeyedMsgFromDb| BOOT::|compHas| BOOT::|compExit| - BOOT::|compElt| BOOT::|compConstruct| BOOT::|compCons| - BOOT::|compCons1| BOOT::|compSeqItem| - BOOT::|recordInstantiation1| BOOT::|compCase| - BOOT::|compQuote| BOOT::|recordInstantiation| - BOOT::|compAtSign| BOOT::|compSuchthat| - BOOT::|addToConstructorCache| BOOT::|loadLibNoUpdate| - BOOT::SETDATABASE BOOT::|lassocShiftWithFunction| - BOOT::|assocCache| BOOT::|assocCacheShift| - BOOT::|assocCacheShiftCount| BOOT::|pileForests| - BOOT::|isLegitimateMode;| BOOT::|hasFileProperty;| - BOOT::|coerceConvertMmSelection;| - BOOT::|hasFilePropertyNoCache| BOOT::|writeLib1| - BOOT::|rwrite| BOOT::|putModemapIntoDatabase| - BOOT::|getOplistWithUniqueSignatures| - BOOT::|checkSkipOpToken| BOOT::|checkSkipIdentifierToken| - BOOT::|readLib1| BOOT::|checkSkipBlanks| - BOOT::MAKE-PARSE-FUNC-FLATTEN-1 BOOT::|checkSkipToken| - BOOT::|getDocForCategory| BOOT::|newWordFrom| - BOOT::PRINT-XDR-STREAM BOOT::|getDocForDomain| - BOOT::|getDoc| BOOT::|htcharPosition| - BOOT::|PackageDescendCode| BOOT::|RecordEqual| - BOOT::|processPackage,replace| BOOT::|UnionEqual| - BOOT::|mkEnumerationFunList| BOOT::|mkMappingFunList| - BOOT::|mkUnionFunList| BOOT::|mkRecordFunList| - BOOT::|MappingEqual| BOOT::|CondAncestorP| - BOOT::|updateDatabase| BOOT::|compressSexpr| - BOOT::|parseTypeError| BOOT::|moreGeneralCategoryPredicate| - BOOT::|encodeUnion| BOOT::|makeCatPred| - BOOT::|lookupInDomainByName| BOOT::|simpHasAttribute| - BOOT::|domainHput| BOOT::|simpHasPred,simpHas| - BOOT::|substDollarArgs| BOOT::|NRTisRecurrenceRelation| - BOOT::|dbShowOpSigList| BOOT::|dbSelectData| - BOOT::|dbReduceOpAlist| BOOT::|listOfCategoryEntriesIf| - BOOT::|dbResetOpAlistCondition| - BOOT::|algCoerceInteractive| BOOT::|buildPredVector,fn| - BOOT::|extendsCategoryBasic| BOOT::|catExtendsCat?| - BOOT::|expandType| BOOT::|expandTypeArgs| BOOT::|stuffSlot| - BOOT::|dbPresentOpsSaturn| BOOT::|reduceOpAlistForDomain| - BOOT::|mungeAddGensyms,fn| BOOT::|dbReduceBySelection| - BOOT::|extendsCategoryBasic0| BOOT::|substSlotNumbers| - BOOT::|dbReduceBySignature| BOOT::|extendsCategory| - BOOT::|buildPredVector| BOOT::|dbParts| - BOOT::|NRTextendsCategory1| BOOT::|getSubstQualify| - BOOT::|fortFormatLabelledIfGoto| BOOT::|whoUsesMatch1?| - BOOT::|fullSubstitute| BOOT::|whoUsesMatch?| - BOOT::|getfortarrayexp| BOOT::|addWhereList| - BOOT::|dbGetDisplayFormForOp| - BOOT::|dbGetFormFromDocumentation| BOOT::|anySubstring?| - VMLISP::MAKE-ENTRY BOOT::|NRTsetVector4a| - BOOT::|NRTsetVector4Part1| BOOT::|NRTencode,encode| - BOOT::|consOpSig| BOOT::|genSlotSig| BOOT::|NRTsetVector4| - BOOT::|newExpandGoGetTypeSlot| BOOT::MAKEOP - BOOT::|insertEntry| BOOT::|nextown| BOOT::|mkFortFn| - BOOT::|exp2Fort2| BOOT::|evalQUOTE| BOOT::|evalSEQ| - BOOT::|IFcodeTran| BOOT::|exp2FortFn| - BOOT::|fortFormatHead| BOOT::|addContour,fn1| - BOOT::|traverse,traverseInner| BOOT::|upTableSetelt| - BOOT::|printSignature| BOOT::|addContour,fn3| - BOOT::|commandAmbiguityError| BOOT::|charPosition| - BOOT::|traverse| BOOT::|dbPart| BOOT::|commandErrorMessage| - BOOT::|substituteOp| BOOT::|displayModemap| - BOOT::|displayType| BOOT::|comp| BOOT::|displayMode| - BOOT::|numOfOccurencesOf,fn| VMLISP::QUOREM - BOOT::|pmatchWithSl| BOOT::|displayCondition| - BOOT::|displayValue| - BOOT::|intersectionContour,buildModeAssoc| BOOT::|get| - BOOT::|sigDomainVal| BOOT::GEQNSUBSTLIST - BOOT::|compNoStacking| BOOT::|transImplementation| - BOOT::GEQSUBSTLIST BOOT::|libConstructorSig,g| - BOOT::|coerceable| BOOT::|substituteIntoFunctorModemap| - BOOT::|adjExitLevel| BOOT::|getParentsFor| - BOOT::|asytranApply| BOOT::|explodeIfs,fn| BOOT::|dbSplit| - BOOT::|buildLibAttr| BOOT::|buildLibOp| - BOOT::|transKCatAlist| BOOT::|dbTickIndex| - BOOT::|insertShortAlist| BOOT::|sublisFormal,sublisFormal1| - BOOT::PUTALIST FOAM:|FormatNumber| - BOOT::|dbSetOpAlistCondition| BOOT::|compiledLookup| - BOOT::|insertAlist| BOOT::|reduceAlistForDomain| - BOOT:|StreamCopyChars| BOOT:|StreamCopyBytes| - BOOT::|dbXParts| BOOT::|kePageDisplay| - BOOT::|dbShowOpItems| BOOT::MKPFFLATTEN-1 - BOOT::|dbSearchOrder| BOOT::CARCDRX1 BOOT::SETELTREST - BOOT::SETELTFIRST BOOT::AS-INSERT1 BOOT::AS-INSERT - BOOT::PROPERTY BOOT::|mkDomTypeForm| BOOT::|stringPosition| - BOOT:|StringFromTo| BOOT::|patternCheck,equal| - BOOT:|StringFromLong| BOOT::|rightCharPosition| - BOOT::|infix?| BOOT::|matchSegment?| BOOT::|stringMatch| - BOOT::|skipBlanks| BOOT::|dbPresentConsSaturn| - BOOT::MAKE-DEFUN BOOT::|compOrCroak| BOOT::|profileRecord| - BOOT::|getSignature| BOOT::|traceDomainLocalOps| - BOOT::|getArgumentModeOrMoan| - BOOT::|filterListOfStringsWithFn| - BOOT::|mkGrepPattern1,charPosition| - BOOT::|displayModemap,g| - BOOT::|filterAndFormatConstructors| BOOT::READ-BOOT - BOOT::|userLevelErrorMessage| BOOT::|addBinding| - BOOT::|dbShowConsDoc1| BOOT::|makePathname| - BOOT::|mkConform| BOOT::|dbInfoFindCat| BOOT::|compReduce| - BOOT::|dbShowInfoList| BOOT::|dbShowConditions| - BOOT::|compRepeatOrCollect| BOOT::|dbInfoOrigin| - BOOT::|dbConstructorDoc| BOOT::|interpret2| - BOOT::|htpSetLabelInputString| BOOT::|letPrint2| - BOOT::|letPrint| BOOT::|mapLetPrint| - BOOT::|htpAddInputAreaProp| BOOT::|getOpBindingPower| - BOOT::|infixArgNeedsParens| BOOT::|linearFinalRequest| - BOOT::|bcInputEquations,f| BOOT::|htpSetLabelErrorMsg| - BOOT::|isBreakSegment?| BOOT::|substring?| - BOOT::|sublisMatAlist| BOOT::MAKESPAD - BOOT::|reportCategory| BOOT::|longext| - BOOT::|npParenthesize| BOOT::|bcString2WordList,fn| - VMLISP::ECQGENEXP VMLISP::RCQGENEXP BOOT::|outputString| - BOOT::|outputNumber| VMLISP::DODSETQ - BOOT::|pfInfApplication| BOOT::|insertString| - BOOT::|npAndOr| BOOT::|npListofFun| BOOT::|optSpecialCall| - BOOT::|pfPushBody| BOOT::|pfIf| BOOT::|incZip| - BOOT::|augProplist| BOOT::|augProplistInteractive| - BOOT::|centerString| BOOT::|evalCOLLECT| - BOOT::|interpCOLLECTbody| BOOT::|upLoopIterIN| - BOOT::|position,posn| BOOT::|domainVal| BOOT::|subVecNodes| - BOOT::|addBindingInteractive| BOOT::|interpCOLLECT| - BOOT::|upTaggedUnionConstruct| BOOT::|upRecordConstruct| - BOOT::|newExpandTypeSlot| BOOT::|upNullList| - BOOT::|upStreamIterIN| BOOT::|getCatForm| - BOOT::|oldAxiomAddChild| BOOT::|evalCOERCE| - BOOT::|mkAndApplyZippedPredicates| BOOT::|lookupPred| - BOOT::|oldAxiomDomainHasCategory| BOOT::|mkIterFun| - BOOT::|attributeCategoryBuild| - BOOT::|oldAxiomCategoryBuild| BOOT::|upLETtype| - BOOT::|upLETWithFormOnLhs| BOOT::|lazyMatchAssocV1| - BOOT::|oldAxiomCategoryNthParent| BOOT::|assignSymbol| - BOOT::|evalIsntPredicate| BOOT::|evalIsPredicate| - BOOT::|SpadInterpretStream| BOOT::|upSetelt| BOOT:SUBLISLIS - BOOT::|upNullTuple| BOOT::|evalIF| BOOT::|intloopProcess| - BOOT::|evalis| BOOT::|evalREPEAT| BOOT::|upwhereMain| - BOOT::|upwhereMkAtree| BOOT::|upwhereClause| - BOOT::|intloopInclude0| BOOT::|intloopSpadProcess,interp| - BOOT::|incPrefix?| BOOT::|inclmsgIfSyntax| - BOOT::|renamePatternVariables1| BOOT::|newExpandLocalType| - BOOT::|newExpandLocalTypeForm| - BOOT::|oldAxiomPreCategoryBuild| - BOOT::|getFunctionFromDomain| BOOT::|lazyOldAxiomAddChild| - BOOT:SUBSTEQ BOOT::|getOpCode| BOOT::|lazyDomainSet| - BOOT::|application2String| BOOT::|putI| BOOT::|mkInterpFun| - BOOT::|interpret1| BOOT::|analyzeMap0| - BOOT::|reportOpSymbol,sayMms| BOOT::|findLocalsInLoop|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T) T) BOOT::|analyzeRecursiveMap| - BOOT::|augmentMap| BOOT::|reportFunctionCompilation| - BOOT::|putSrcPos| BOOT::|hasSigInTargetCategory,fn| - BOOT::|encodeFunctionName| BOOT::|getArgValueComp2| - BOOT::|augModemapsFromCategory| BOOT::|compDefineFunctor1| - BOOT::|augModemapsFromCategoryRep| - BOOT::|compDefineFunctor| BOOT::|processFunctor| - BOOT::|buildFunctor| BOOT::|selectMmsGen,matchMms| - BOOT::|makeConstrArg| - BOOT::|commuteSparseUnivariatePolynomial| - BOOT::|commuteUnivariatePolynomial| - BOOT::|commuteSquareMatrix| BOOT::|coerceDmp1| - BOOT::|aggregateApp| BOOT::|compDefineCategory1| - BOOT::|commuteFraction| BOOT::|compDefineCategory| - BOOT::|commuteQuaternion| BOOT::|commuteComplex| - BOOT::|resolveTT2| BOOT::|concatApp1| - BOOT::|compFormPartiallyBottomUp| - BOOT::|canReturn,findThrow| BOOT::|orderMms| - BOOT::|sayFunctionSelection| BOOT::MATCH-FUNCTION-DEF - BOOT::|commuteNewDistributedMultivariatePolynomial| - BOOT::|commuteMPolyCat| - BOOT::|commuteDistributedMultivariatePolynomial| - BOOT::|commuteMultivariatePolynomial| - BOOT::|commutePolynomial| BOOT::|bottomUpDefaultCompile| - BOOT::|bottomUpDefaultEval| BOOT::|bottomUpFormTuple| - BOOT::|bottomUpFormAnyUnionRetract| BOOT::|bottomUpForm| - BOOT::|bottomUpFormUntaggedUnionRetract| - BOOT::|bottomUpFormRetract| BOOT::|bottomUpForm2| - BOOT::|bottomUpForm0| BOOT::|bottomUpForm3| - BOOT::|coerceByTable| BOOT::|compileRecurrenceRelation| - BOOT::|logS| BOOT::|spadify| BOOT::|prepareResults| - BOOT::|DescendCodeAdd1| - BOOT::|htSystemVariables,displayOptions| BOOT::|evalAndSub| - BOOT::FINCOMBLOCK BOOT::|compIf,Env| BOOT::LOCALASY - BOOT::|mkCacheVec| BOOT::LOCALNRLIB BOOT::|selectMms1;| - BOOT::|selectMms2| BOOT::|processPackage| - BOOT::|mkCategory| BOOT::|newCompareSig| - BOOT::|lookupInDomain| BOOT::|fortFormatDo| - BOOT::|newLookupInDomain| BOOT::|getNewDefaultPackage| - BOOT::|printLabelledList| BOOT::|compApplication| - BOOT::|dbExpandOpAlistIfNecessary| BOOT::-REDUCE - BOOT::|compDefineCapsuleFunction| BOOT::|genSearchSay| - BOOT::|compRepeatOrCollect,fn| BOOT::|dbGetDocTable| - BOOT::|apprpar| BOOT::WRITE-TAG-LINE BOOT::|concatTrouble| - BOOT::|charyBinary| BOOT::|split2| BOOT::|needStar| - BOOT::|lazyMatchArg2| BOOT::|newLookupInTable| - BOOT::|hashNewLookupInTable| BOOT::|compileADEFBody| - BOOT::|interpLoopIter| BOOT::|compileIF| - BOOT::|xlCannotRead| BOOT::|xlMsg| BOOT::|xlNoSuchFile| - BOOT::|incLine| BOOT::|xlFileCycle| BOOT::|xlConStill| - BOOT::|xlConActive| BOOT::|xlSay| BOOT::|xlOK1| - BOOT::|incLude| BOOT::|analyzeDeclaredMap|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T) T) BOOT::|analyzeNonRecursiveMap| - BOOT::|makeInternalMapName| BOOT::|printCName| - BOOT::|clearDep1| BOOT::|domArg| BOOT::|mkDomPvar| - BOOT::|hasSig| BOOT::|putIntSymTab| - BOOT::|findConstructorSlotNumber| BOOT::MAKE-FLOAT - BOOT::|getFileProperty| - BOOT::|compDefWhereClause,fetchType| BOOT::|compSubDomain1| - BOOT::|putFileProperty| BOOT::|srcPosNew| - BOOT::|substNames| BOOT::|mac0MLambdaApply| - BOOT::|mac0ExpandBody| BOOT::|genDomainView| - BOOT::|getArgValue2| BOOT::|compFunctorBody| - BOOT::|analyzeMap| BOOT::|defaultTarget| - BOOT::|selectDollarMms| BOOT::|selectMmsGen| - BOOT::|allOrMatchingMms| BOOT::|evalMmCat| - BOOT::|matchMmSig| BOOT::/LOCATE BOOT::|hasCateSpecialNew| - BOOT::|evalMm| BOOT::|evalMmFreeFunction| - BOOT::|hasCateSpecial| BOOT::|hasCate1| BOOT::|boxApp| - BOOT::|concatApp| BOOT::|appsum| BOOT::|altSuperSubApp| - BOOT::|concatbApp| BOOT::|appSum| BOOT::|binomApp| - BOOT::|aggApp| BOOT::|fixUpPredicate| BOOT::|stepApp| - BOOT::|appneg| BOOT::|setqMultipleExplicit| - BOOT::|braceApp| BOOT::|compSetq1| BOOT::|timesApp| - BOOT::|rootApp| BOOT::|bracketApp| BOOT::|plusApp| - BOOT::|appparu1| BOOT::|bigopWidth| BOOT::|P2Us| - BOOT::|pi2App| BOOT::|boxLApp| VMLISP:STRPOSL - BOOT::|compOrCroak1| BOOT::|piApp| BOOT::|compForm2| - BOOT::|compForm3| BOOT::|getConditionalCategoryOfType1| - BOOT::|indefIntegralApp| BOOT::|nothingApp| - BOOT::|evalconstruct| BOOT::|evalInfiniteTupleConstruct| - BOOT::|setqSetelt| BOOT::|evalTupleConstruct| - BOOT::|consProplistOf| BOOT::|setqMultiple| - BOOT::|coerceImmediateSubDomain| BOOT::|intApp| - BOOT::|setqSingle| BOOT::|assignError| BOOT::|sigma2App| - BOOT::|canReturn| BOOT::|appext| BOOT::|centerApp| - BOOT::|sigmaApp| BOOT::|stringApp| BOOT::|MpP2P| - BOOT::|evalForm| BOOT::|selectLocalMms| - BOOT::|bottomUpDefault| BOOT::|canCoerceTopMatching| - BOOT::|catchCoerceFailure| BOOT::|asGetModemaps| - BOOT::|asytranCategory| BOOT::|asytranCategoryItem| - BOOT::|asytranDeclaration| - BOOT::|InvestigateConditions,flist| BOOT::|getTranslation| - BOOT::|condUnabbrev| - BOOT::|constructorAbbreviationErrorCheck| BOOT::READ-SPAD0 - BOOT::|BesselasymptB| BOOT::|optCallSpecially| - BOOT::|getDocDomainForOpSig| BOOT::|reportFunctionCacheAll| - BOOT::|clngammacase2| BOOT::|constoken| BOOT::|writeMalloc| - BOOT::|printDec| BOOT::|htPred2English,gn| - BOOT::|prepareData| BOOT::|protectedNagCall| - BOOT::|axiomType| BOOT::|DescendCode| - BOOT::|SetFunctionSlots| - BOOT::|InvestigateConditions,update| - BOOT::|htSystemVariables,functionTail| VMLISP:STRPOS - BOOT::|replaceExitEtc,fn| BOOT::|compNoStacking1| - BOOT::|compClam| BOOT::|getModemapListFromDomain| - BOOT::|say2Split| BOOT::|compColonInside| BOOT::|haddProp| - BOOT::|npEnclosed| BOOT::|hputNewProp| - BOOT::ASHARPMKAUTOLOADFUNCTOR - BOOT::ASHARPMKAUTOLOADCATEGORY BOOT::|addCoreModemap| - BOOT::|getMatchingRightPren| BOOT::|checkHTargs| - BOOT::|mkOperatorEntry| BOOT::|catPairUnion| - BOOT::|lookupUF| BOOT::|newLookupInCategories| - BOOT::|lookupFF| BOOT::|simpHasSignature| - BOOT::|compareSig| BOOT::|lazyCompareSigEqual| - BOOT::|lookupInAddChain| BOOT::|lookupInCategories| - BOOT::|lookupInTable| BOOT::|lookupDisplay| - BOOT::|domainTableLookup| BOOT::|dbShowOpConditions| - BOOT::|dbShowOpParameterJump| - BOOT::|dbShowOpImplementations| BOOT::|dbShowOpParameters| - BOOT::|dbShowOpOrigins| BOOT::|dbShowOpSignatures| - BOOT::|getSigSubst| BOOT::|optDeltaEntry| - BOOT::|lazyMatchArg| BOOT::|nrunNumArgCheck| - BOOT::|nextown2| BOOT::|semchkProplist| - BOOT::|interpREPEAT| BOOT::|makeCommonEnvironment,fn| - BOOT::|compMapCondFun| BOOT::|compApplyModemap| - BOOT::|compMapCond| BOOT::|compMapCond'| - BOOT::|compToApply| BOOT::REDUCE-N BOOT::|applyMapping| - BOOT::|compFormWithModemap| BOOT::|compAtomWithModemap| - BOOT::|ancestorsRecur| BOOT::|checkCommentsForBraces| - BOOT::|dbShowOpDocumentation| BOOT::|dbShowOpNames| - BOOT::REDUCE-N-1 BOOT::|dbGatherData| BOOT::|dbConsHeading| - BOOT::REDUCE-N-2 BOOT::|termMatch| BOOT::|matchAnySegment?| - BOOT::|replaceExitEtc| BOOT::|put| BOOT::|checkAndDeclare| - BOOT::|hasSigInTargetCategory| BOOT::READ-SPAD1 - BOOT::|mkDetailedGrepPattern| BOOT::|displayInfoOp| - BOOT::|dbShowInfoOp| BOOT::|compReduce1| BOOT::|letPrint3| - BOOT::|intloopSpadProcess| BOOT::|zagApp| - BOOT::|findBalancingBrace| BOOT::|appelse| BOOT::|appChar| - BOOT::|appInfix| BOOT::|htMakeButtonSaturn| - BOOT::|vconcatapp| BOOT::|superSubApp| BOOT::|xLate| - BOOT::|appconc| BOOT::MAKELIB BOOT::|appparu| - BOOT::|charySemiColon| BOOT::|charyElse| - BOOT::|charyEquatnum| BOOT::|bcFindString| - BOOT::|charySplit| BOOT::|charyMinus| VMLISP::DCQGENEXP - BOOT::|augProplistOf| BOOT::|putHist| - BOOT::|evalUntargetedADEF| BOOT::|evalTargetedADEF| - BOOT::|mergeInPlace| BOOT::|upLoopIterSTEP| - BOOT::|mergeSort| BOOT::|interpLoop| BOOT::|collectStream| - BOOT::|collectStream1| BOOT::|lazyMatch| - BOOT::|lazyMatchArgDollarCheck| - BOOT::|interpCOLLECTbodyIter| BOOT::|lookupInCompactTable| - BOOT::|sayLooking| BOOT::|upStreamIterSTEP| - BOOT::|lookupIncomplete| BOOT::|newLookupInAddChain| - BOOT::|hashNewLookupInCategories| BOOT::|lookupComplete| - BOOT::|newLookupInCategories1| BOOT::|lazyMatchAssocV| - BOOT::|collectSeveralStreams| BOOT::|mkIterZippedFun| - BOOT::|compareSigEqual| BOOT::|mkInterpTargetedADEF| - BOOT::|compileTargetedADEF| BOOT::|collectOneStream| - BOOT::|oldCompLookupNoDefaults| BOOT::|evalTuple| - BOOT::|interpIF| BOOT::|getReduceFunction| - BOOT::|NRTgetMinivectorIndex| BOOT::|xlPrematureFin| - BOOT::|xlPrematureEOF| BOOT::|xlCmdBug| BOOT::|xlIfBug| - BOOT::|xlSkippingFin| BOOT::|xlConsole| BOOT::|xlOK| - BOOT::|xlSkip| BOOT::|lookupInDomainVector| - BOOT::|basicLookupCheckDefaults| BOOT::|basicLookup| - BOOT::|oldCompLookup| BOOT::|analyzeUndeclaredMap|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T T) T) BOOT::|compDefineLisplib| - BOOT::|compConLib1| BOOT::|addModemap| BOOT::|mmCost| - BOOT::|findFunctionInDomain1| BOOT::/WRITEUPDATE - BOOT::|mmCost0| BOOT::|/D,2,LIB| - BOOT::|processFunctorOrPackage| BOOT::|compOrCroak1,fn| - BOOT::/D-2 BOOT::|BesselIBackRecur| BOOT::|invokeFortran| - BOOT::|nagCall| BOOT::|makeFort| BOOT::|addModemapKnown| - BOOT::|addModemap1| BOOT::|addEltModemap| BOOT::|compHash| - BOOT::|compHashGlobal| BOOT::|compApply| BOOT::|kdPageInfo| - BOOT::|addModemap0| BOOT::|bracketagglist| - BOOT::|attributeLookupExport| BOOT::|upDollarTuple| - BOOT::|xlIfSyntax| BOOT::|incLine1| - BOOT::|oldAxiomCategoryLookupExport| BOOT::|genMapCode| - BOOT::|putMapCode|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T *) T) BOOT::|pfLeaf| BOOT::BPITRACE - VMLISP:|remove| VMLISP:RREAD VMLISP:REMOVEQ - BOOT::MATCH-LISP-TAG VMLISP:NREMOVE VMLISP:NREMOVEQ - BOOT::|tokConstruct| BOOT::|pfAdd| - BOOT:|ByteFileReadLineIntoString| BOOT:MATCH-TOKEN)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T *) T) BOOT::|ncHardError| - BOOT::TOKEN-INSTALL BOOT::|ncSoftError| BOOT::|lnCreate|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T) T) BOOT::|findFunctionInCategory| - BOOT::|Mp2MpAux1| BOOT::|Mp2MpAux0| BOOT::|Expr2Dmp1| - BOOT::|Mp2SimilarDmp| BOOT::|bigopAppAux| - BOOT::|findFunctionInDomain| BOOT::|abbreviationError| - BOOT::|lisplibError| BOOT::|invokeNagman| - BOOT::|mkNewModemapList| BOOT::|mkDiffAssoc| - BOOT::|dbGatherThenShow| BOOT::|appInfixArg| - BOOT::|lazyOldAxiomDomainLookupExport| - BOOT::|oldAxiomDomainLookupExport|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T T T T T) T) - BOOT::|displayDomainOp|)) -(PROCLAIM '(FTYPE (FUNCTION (T T T T *) T) VMLISP:RPLACSTR)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T T T T) T) BOOT::|P2DmpAux| - BOOT::|makeSpadFun|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T T) T) BOOT::|compDefineCategory2| - BOOT::|P2MpAux| BOOT::|makeFort1|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T T T T T T T) T) BOOT::|writeCFile| - BOOT::|Mp2MpAux2|)) -(PROCLAIM '(FTYPE (FUNCTION (T T T T T *) T) BOOT::|msgCreate|)) -(PROCLAIM - '(FTYPE (FUNCTION NIL *) BOOT::|generateResultsName| - BOOT::|generateDataName| BOOT::|htShowPage| - BOOT::|PARSE-Label| BOOT::|bcMatrix| BOOT::|PARSE-Primary1| - BOOT::|PARSE-Enclosure| BOOT::|bcDraw2DSolve| - BOOT::|PARSE-Selector| BOOT::|PARSE-Category| - BOOT::|PARSE-Option| BOOT::|PARSE-TokenOption| - BOOT::|PARSE-Sexpr1| BOOT::|PARSE-Sexpr| - BOOT::|PARSE-Scripts| BOOT::|PARSE-SpecialCommand| - BOOT::|PARSE-FloatBasePart| BOOT::|PARSE-FloatBase| - BOOT::|PARSE-Leave| BOOT::|e02aef| BOOT::|e04ucfCopOut| - BOOT::|c02agf| BOOT::|c02aff| BOOT::|e02adf| BOOT::|c05pbf| - VMLISP:RECLAIM BOOT::MKPROMPT BOOT::|sendHTErrorSignal| - BOOT::|testPage| BOOT::|e01sef| BOOT::|e01saf| - BOOT::|e01daf| BOOT::|e01bhf| BOOT::|e01bgf| BOOT::|e01bff| - BOOT::|e01bef| BOOT::|e01baf| BOOT::|e02zaf| BOOT::|e02gaf| - BOOT::|e02dff| BOOT::|e02def| BOOT::|e02ddf| BOOT::|e02dcf| - BOOT::|e02daf| BOOT::|e02bef| BOOT::|e02bdf| - BOOT::|minusInfinity| BOOT::|plusInfinity| - BOOT::SERVER-SWITCH BOOT::CLEARDATABASE BOOT::NBOOT-LEXPR - BOOT::BOOT-LEXPR BOOT::|executeQuietCommand| - BOOT::|serverSwitch| BOOT::|scanS| - BOOT::|sendNagmanErrorSignal| BOOT::|d01gbf| BOOT::|d01gaf| - BOOT::|d01fcf| BOOT::|d01bbf| BOOT::|d01asf| - BOOT::|d02rafCopOut| BOOT::|d02raf| BOOT::|d02kef| - BOOT::|d02gbf| BOOT::|d02gaf| BOOT::|d02ejf| BOOT::|d02cjf| - BOOT::|d02bhf| BOOT::|d02bbf| BOOT::|e02ahf| - BOOT::|d03edfShort| BOOT::|d03edfLong| BOOT::|d03eefInput| - BOOT::|d03faf| BOOT::|d03eef| BOOT::|d03edf| - BOOT::|htSystemVariables| BOOT::|htSetVars| - BOOT::|mkSetTitle| BOOT::|npCategory| - BOOT::PARSE-CONS_SEXPR BOOT::PARSE-SEXPR - BOOT::PARSE-REF_SEXPR BOOT::PARSE-EXPR2 BOOT::PARSE-EXPR1 - BOOT::|htsv| BOOT::|npDefinitionItem| BOOT::|npDefn| - BOOT::|npMacro| BOOT::|npMDEFinition| BOOT::|npRule| - BOOT::RESETHASHTABLES BOOT::READSPADEXPR - BOOT::|batchExecute| BOOT::|c05nbf| BOOT::|c05adf| - BOOT::|c06gsf| BOOT::|c06gqf| BOOT::|c06gcf| BOOT::|c06gbf| - BOOT::|c06fuf| BOOT::|c06frf| BOOT::|c06fqf| BOOT::|c06fpf| - BOOT::|c06ekf| BOOT::|c06ecf| BOOT::|c06ebf| BOOT::|c06eaf| - BOOT::|s17def| BOOT::|s17dcf| BOOT::|s17akf| BOOT::|s17ajf| - BOOT::|s17ahf| BOOT::|s17agf| BOOT::|s17aff| BOOT::|s17aef| - BOOT::|s17adf| BOOT::|s17acf| BOOT::|s15aef| BOOT::|s15adf| - BOOT::|s14baf| BOOT::|s14abf| BOOT::|s14aaf| BOOT::|s13adf| - BOOT::|s13acf| BOOT::|s13aaf| BOOT::|s01eaf| BOOT::|s21bdf| - BOOT::|s21bcf| BOOT::|s21bbf| BOOT::|s21baf| BOOT::|s20adf| - BOOT::|e02agf| BOOT::|s20acf| BOOT::|d01aqf| BOOT::|s19adf| - BOOT::|d01apf| BOOT::|s19acf| BOOT::|d01anf| BOOT::|d01amf| - BOOT::|d01alf| BOOT::|s19abf| BOOT::|d01akf| BOOT::|s19aaf| - BOOT::|d01ajf| BOOT::|s18def| BOOT::|s18dcf| BOOT::|s18aff| - BOOT::|s18aef| BOOT::|s18adf| BOOT::|s18acf| BOOT::|f04qaf| - BOOT::|f04mcf| BOOT::|f04mbf| BOOT::|f04maf| BOOT::|f04jgf| - BOOT::|f04faf| BOOT::|f04axf| BOOT::|f04atf| BOOT::|f04asf| - BOOT::|quit| BOOT::|f04arf| BOOT::|quitSpad2Cmd| - BOOT::|f04adf| BOOT::|pquit| BOOT::|pquitSpad2Cmd| - BOOT::CONTINUE BOOT::|continue| BOOT::|purgeLocalLibdb| - BOOT::|dbSplitLibdb| BOOT::|f07fef| BOOT::|f07fdf| - BOOT::|f07aef| BOOT::|f07adf| BOOT::|copyright| - BOOT::|s17dlf| BOOT::|s17dhf| BOOT::|s17dgf| BOOT::|f02xef| - BOOT::|f02wef| BOOT::|f02fjf| BOOT::|f02bjf| BOOT::|f02bbf| - BOOT::|f02axf| BOOT::|f02awf| BOOT::|f02akf| BOOT::|f02ajf| - BOOT::|f02agf| BOOT::|htShowPageNoScroll| BOOT::|f02aff| - BOOT::|f02aef| BOOT::|f02adf| BOOT::|f02abf| BOOT::|f02aaf| - BOOT::|measure| BOOT::|writeSaturnSuffix| BOOT::NEWRULE - BOOT::PARSE-LOCAL_VAR BOOT::|htErrorStar| - BOOT::|queryClients| BOOT::|onDisk| BOOT::|endHTPage| - BOOT::|readSpadProfileIfThere| BOOT::|bcDraw3Dpar1| - BOOT::|bcDraw3Dpar| BOOT::|htShowPageStarSaturn| - BOOT::|htShowPageStar| BOOT::|bcDraw3Dfun| - BOOT::|bcDraw2Dpar| BOOT::|bcSum| BOOT::|bcSeries| - BOOT::|bcProduct| BOOT::|bcLimit| - BOOT::|bcIndefiniteIntegrate| BOOT::|bcDraw| - BOOT::|bcDifferentiate| BOOT::|bcDefiniteIntegrate| - BOOT::|bcDraw2Dfun| BOOT::MAKE-TAGS-FILE BOOT::|bcSolve| - BOOT::|npPrimary1| BOOT::|e02bcf| BOOT::|e02bbf| - BOOT::|e02baf| BOOT::|e02akf| BOOT::|e02ajf| BOOT::|e04ycf| - BOOT::|e04ucf| BOOT::|e04naf| BOOT::|e04mbf| BOOT::|e04jaf| - BOOT::|e04gcf| BOOT::|e04fdf| BOOT::|e04dgf| BOOT::|f01ref| - BOOT::|f01rdf| BOOT::|f01rcf| BOOT::|f01qef| BOOT::|f01qdf| - BOOT::|f01qcf| BOOT::|f01mcf| BOOT::|f01maf| BOOT::|f01bsf| - BOOT::|f01brf|)) -(PROCLAIM - '(FTYPE (FUNCTION NIL T) BOOT::|getCodeVector| - BOOT:PARSE-IDENTIFIER BOOT::|axDoLiterals| - BOOT::|PARSE-Suffix| BOOT:CURRENT-TOKEN - BOOT::|PARSE-TokTail| BOOT::|PARSE-InfixWith| - BOOT::|PARSE-With| BOOT::|PARSE-Form| - BOOT::|PARSE-Reduction| BOOT::|PARSE-SemiColon| - BOOT::|PARSE-Iterator| BOOT::|PARSE-Primary| - BOOT::|PARSE-ElseClause| BOOT::|PARSE-Conditional| - BOOT::|PARSE-Name| BOOT::|PARSE-Sequence| - BOOT::|PARSE-Data| BOOT::|PARSE-FormalParameter| - BOOT::|PARSE-IntegerTok| BOOT::|PARSE-String| - BOOT::|PARSE-Quad| BOOT::|PARSE-VarForm| - BOOT::|PARSE-Qualification| BOOT::|PARSE-Prefix| - BOOT::|PARSE-Infix| BOOT::|PARSE-Application| - BOOT:CURRENT-SYMBOL BOOT::|clearCmdSortedCaches| - BOOT::|PARSE-Statement| BOOT::|PARSE-Command| - BOOT::|updateInCoreHist| BOOT::|processSynonyms| - BOOT::|disableHist| BOOT::|PARSE-IteratorTail| - BOOT::|histFileName| BOOT::|PARSE-OpenBrace| - BOOT::|PARSE-Sequence1| BOOT::|PARSE-OpenBracket| - BOOT::|PARSE-PrimaryNoFloat| BOOT:FAIL BOOT::|PARSE-Float| - BOOT::|PARSE-PrimaryOrQM| BOOT::|PARSE-TokenList| - BOOT::|PARSE-AnyId| BOOT::|resetInCoreHist| - BOOT::|PARSE-TokenCommandTail| BOOT::|isTokenDelimiter| - BOOT::|PARSE-ScriptItem| BOOT::|PARSE-CommandTail| - BOOT::|historySpad2Cmd| BOOT::|PARSE-FormalParameterTok| - BOOT::|PARSE-SpecialKeyWord| - BOOT::|writeHistModesAndValues| BOOT::|PARSE-FloatTok| - BOOT::|PARSE-FloatExponent| BOOT::|updateHist| - BOOT::|initHistList| BOOT::|initHist| BOOT::|PARSE-Exit| - BOOT::|oldHistFileName| BOOT:PARSE-NUMBER - BOOT::|PARSE-Return| BOOT::|PARSE-ReductionOp| - BOOT::|PARSE-LabelExpr| BOOT::|PARSE-Import| - BOOT::|writeHiFi| BOOT::|PARSE-Loop| - BOOT::|updateCurrentInterpreterFrame| BOOT::|PARSE-Seg| - BOOT:CURINPUTLINE BOOT::|profileWrite| BOOT:PARSE-BSTRING - BOOT:NEXT-TOKEN BOOT:IOSTAT BOOT::|isPackageFunction| - BOOT:UNGET-TOKENS BOOT::|setOptKeyBlanks| - BOOT::|getInfovecCode| BOOT::|NRTmakeSlot1Info| - BOOT::|reportOnFunctorCompilation| BOOT:BUMPCOMPERRORCOUNT - BOOT::|displayMissingFunctions| BOOT:PARSE-STRING - BOOT:ADVANCE-TOKEN BOOT::ERRHUH BOOT:CURRENT-CHAR - VMLISP:$TOTAL-ELAPSED-TIME BOOT::IS-GENSYM - BOOT::|getSpecialCaseAssoc| - BOOT::|makeConstructorsAutoLoad| - BOOT::|displayExposedGroups| - BOOT::|displayHiddenConstructors| - BOOT::|displaySemanticErrors| BOOT::|clock| - BOOT::|startTimer| BOOT::|spadPrompt| BOOT::|stopTimer| - BOOT::|quadSch| BOOT::/TRACEREPLY BOOT::TRACELETREPLY - BOOT::|voidValue| BOOT::/COMP BOOT::|getDateAndTime| - BOOT::|coercionFailure| VMLISP:EMBEDDED - BOOT::|printableArgModeSetList| BOOT::|asList| - BOOT::|boot2LispError| BOOT::|extendConstructorDataTable| - BOOT::|fin| BOOT::PARSERSTATE BOOT::|New,ENTRY,1| - BOOT::|mkLowerCaseConTable| BOOT::NEW-LEXPR-INTERACTIVE - BOOT::NEW-LEXPR BOOT::|spadThrow| BOOT::INITIALIZE - BOOT::NEW BOOT::|New,ENTRY| BOOT::|traceComp| - BOOT::|New,ENTRY1| BOOT::|New,ENTRY,SYS| BOOT::NEWPO - BOOT::|returnToReader| BOOT::|returnToTopLevel| BOOT::TOP - BOOT::|serverLoop| BOOT::|describeSetOutputTex| - BOOT::|describeSetOutputFortran| - BOOT::|describeSetLinkerArgs| - BOOT::|describeProtectSymbols| - BOOT::|describeOutputLibraryArgs| - BOOT::|describeSetFortDir| BOOT::|describeFortPersistence| - BOOT::|describeSetFortTmpDir| - BOOT::|describeProtectedSymbolsWarning| - BOOT::|describeSetStreamsCalculate| - BOOT::|describeSetOutputFormula| - BOOT::|describeInputLibraryArgs| - BOOT::|resetWorkspaceVariables| BOOT::|describeSetNagHost| - BOOT::|describeAsharpArgs| BOOT::|describeSetOutputAlgebra| - BOOT::|sayAllCacheCounts| BOOT::|describeSetFunctionsCache| - BOOT::|nangenericcomplex| BOOT::|createTypeEquivRules| - BOOT::|createResolveTTRules| BOOT::|createResolveTMRules| - BOOT::|bcBlankLine| BOOT::|browserAutoloadOnceTrigger| - BOOT::|scanKeyTableCons| BOOT::|scanToken| BOOT::|scanEsc| - BOOT::|scanError| BOOT::|scanEscape| BOOT::|scanNumber| - BOOT::|asharpConstructors| BOOT::|scanString| - BOOT::|scanSpace| BOOT::|scanPunct| BOOT::|scanNegComment| - BOOT::|startsNegComment?| BOOT::|scanComment| - BOOT::|startsComment?| BOOT::|scanPunCons| - BOOT::|scanDictCons| BOOT::|resetStackLimits| - BOOT::|npRecoverTrap| BOOT::|syGeneralErrorHere| - BOOT::|DPname| BOOT::|pfNoPosition| VMLISP:CURRENTTIME - BOOT::|buildHtMacroTable| BOOT::|checkWarningIndentation| - BOOT::|npDecl| BOOT::|npType| VMLISP:$SCREENSIZE - BOOT::|npAmpersand| BOOT::|npName| BOOT::|npFromdom| - BOOT::|npSCategory| BOOT::|npPrimary| BOOT::|npState| - BOOT::|npDefaultValue| BOOT::|npAssignVariableName| - BOOT::|npPDefinition| BOOT::|npDollar| - BOOT::|npSQualTypelist| BOOT::PARSE-NON_DEST_REF - BOOT::PARSE-OPT_EXPR BOOT::PARSE-REPEATOR - BOOT::|npCategoryL| BOOT::PARSE-SEXPR_STRING - BOOT::|npProduct| BOOT::PARSE-TEST BOOT::|npIterators| - BOOT::PARSE-EXPR BOOT::|npWhile| - BOOT::|displayPreCompilationErrors| BOOT::PARSE-N_TEST - BOOT::|npForIn| BOOT::PARSE-REP_TEST BOOT::|npGives| - BOOT::PARSE-FIL_TEST BOOT::|npLogical| BOOT::PARSE-SUBEXPR - BOOT::|npExpress| BOOT::PARSE-FID BOOT::PARSE-RULE - BOOT::|npExpress1| BOOT::PARSE-HEADER - BOOT::|npCommaBackSet| BOOT::PARSE-RULE1 BOOT::|npQualType| - VMLISP:$TOTAL-GC-TIME BOOT::|npADD| - BOOT::|npConditionalStatement| - BOOT::|npQualifiedDefinition| BOOT::|npPushId| - BOOT::|npVariable| BOOT::|npDefinitionOrStatement| - BOOT::|npAssignVariable| BOOT::|npColon| - BOOT::|npAssignment| BOOT::|profileDisplay| - BOOT:|TimeStampString| BOOT::|computeDomainVariableAlist| - BOOT::MONITOR-READINTERP BOOT::|npSingleRule| - BOOT::MONITOR-UNTESTED BOOT::|npDefTail| BOOT::|npQuiver| - BOOT::MONITOR-PERCENT BOOT::|npDef| BOOT::|npStatement| - BOOT::|npImport| BOOT::|npTyping| BOOT::|npItem| - BOOT::|npQualDef| BOOT::|npAssign| BOOT::MONITOR-AUTOLOAD - BOOT::|npDefinition| BOOT::MONITOR-RESULTS - BOOT::MONITOR-END BOOT::|npPop3| BOOT::MONITOR-INITTABLE - BOOT::|npAtom2| BOOT::|npInfixOperator| BOOT::|npPower| - BOOT::MONITOR-HELP BOOT::|npMatch| BOOT::MONITOR-REPORT - BOOT::|npMdef| BOOT::|reportInstantiations| - BOOT::|npPrimary2| BOOT::?DOMAINS BOOT::|?domains| - BOOT::|npSuch| BOOT::|npMDEF| BOOT::|npDisjand| - BOOT::|npInfixOp| BOOT::|npDiscrim| - BOOT::|clearConstructorAndLisplibCaches| - BOOT::|npVariableName| BOOT::|clearConstructorCaches| - BOOT::|clearClams| BOOT::|clearCategoryCaches| - BOOT::|cacheStats| BOOT::|reportAndClearClams| - BOOT::|traceDown| BOOT::|statRecordInstantiationEvent| - BOOT::|tc| BOOT::GET-CURRENT-DIRECTORY - BOOT::|removeAllClams| BOOT::|clamStats| BOOT::|npPop1| - BOOT::|npTrap| BOOT::|npApplication| BOOT::|npPop2| - BOOT::|npApplication2| BOOT::WRITE-WARMDATA - BOOT::WRITE-INTERPDB BOOT::|npAssignVariablelist| - BOOT::|clearHashReferenceCounts| BOOT::|npSignature| - BOOT::|pfNothing| BOOT::|npSigItemlist| BOOT::|npEncl| - BOOT::|npBDefinition| BOOT::|npPrefixColon| BOOT::|npNext| - BOOT::|allOperations| BOOT::WRITE-CATEGORYDB - BOOT::WRITE-OPERATIONDB BOOT::WRITE-BROWSEDB - BOOT::WRITE-COMPRESS BOOT::INITIAL-GETDATABASE - BOOT::CATEGORYOPEN BOOT::BROWSEOPEN BOOT::OPERATIONOPEN - BOOT::INTERPOPEN BOOT::COMPRESSOPEN - BOOT::CREATE-INITIALIZERS BOOT::|poNoPosition| - BOOT::|saveDependentsHashTable| BOOT::|saveUsersHashTable| - BOOT::|mkTopicHashTable| BOOT::TOKEN-STACK-SHOW - BOOT::|system| BOOT::|terminateSystemCommand| - BOOT::|getSystemCommandLine| BOOT::TERMCHR - BOOT::IOSTREAMS-SHOW BOOT::|displayExposedConstructors| - BOOT::|finalizeDocumentation| BOOT::REDUCE-STACK-SHOW - BOOT::CLEAR-HIGHLIGHT BOOT::RESET-HIGHLIGHT BOOT::RESTART0 - START BOOT::|libraryFileLists| BOOT::|waitForViewport| - BOOT::|setViewportProcess| - BOOT::|installStandardTestPackages| BOOT::|printCopyright| - BOOT::AKCL-VERSION BOOT::SET-RESTART-HOOK - BOOT::|undoINITIALIZE| BOOT::|simpCategoryTable| - BOOT::|simpTempCategoryTable| BOOT::COMPFIN - BOOT::INPUT-CLEAR BOOT::|genTempCategoryTable| BOOT::|cc| - BOOT::|initNewWorld| BOOT::|genCategoryTable| - BOOT::|dbOpsExposureMessage| BOOT::|htSayUnexposed| - BOOT::|NRTmakeCategoryAlist| - BOOT::|NRTgenFinalAttributeAlist| BOOT::|dcSizeAll| - BOOT::|initialiseIntrinsicList| BOOT::|tempLen| - BOOT::|changeDirectoryInSlot1| BOOT::|NRTaddDeltaCode| - BOOT::|ncIntLoop| BOOT::SPECIALCASESYNTAX - BOOT::|newFortranTempVar| BOOT::|currentSP| - BOOT::|elapsedTime| BOOT::|traceUp| - BOOT::|getIntrinsicList| BOOT::|getInterpMacroNames| - BOOT::|synonymSpad2Cmd| BOOT::|interpFunctionDepAlists| - BOOT::NPPPG BOOT::|isFalse| BOOT::NPPPF BOOT::NPPPFF - BOOT::|printDashedLine| BOOT::|satBreak| BOOT::|up| - BOOT::|getWorkspaceNames| BOOT::|getParserMacroNames| - BOOT::|oldCompilerAutoloadOnceTrigger| BOOT::|TrimCF| - BOOT::|displayWorkspaceNames| BOOT::UP - BOOT::|displayWarnings| BOOT::|buildGloss| - BOOT::|nextInterpreterFrame| BOOT::|down| - BOOT::|displayFrameNames| BOOT::DOWN - BOOT::|previousInterpreterFrame| BOOT::SAME BOOT::|same| - BOOT::|mkUsersHashTable| BOOT::|allConstructors| - BOOT::|frameNames| BOOT::|sayShowWarning| BOOT::|credits| - BOOT::|mkDependentsHashTable| - BOOT::|buildDefaultPackageNamesHT| - BOOT::|dbAugmentConstructorDataTable| FOAM:|fiGetDebugVar| - BOOT::|menuButton| BOOT::|htSaturnBreak| BOOT::|random| - BOOT::|dbConsExposureMessage| BOOT::|mkSigPredVectors| - BOOT::FIRST-ERROR BOOT::|writeSaturnPrefix| BOOT::|on| - BOOT::|offDisk| BOOT::|htBigSkip| BOOT::PARSE-PROGRAM - BOOT::IN-META BOOT::|traceReply| BOOT::|?t| - BOOT::SKIP-BLANKS BOOT::|pspacers| BOOT::NEXT-LINES-SHOW - BOOT::|resetCounters| BOOT::PARSE-DEST_REF - BOOT::SPAD_SHORT_ERROR BOOT::|pcounters| - BOOT::SPAD_LONG_ERROR BOOT::INIT-BOOT/SPAD-READER - BOOT::NEXT-LINES-CLEAR BOOT::|resetTimers| - BOOT::|resetSpacers| BOOT::|ptimers| - BOOT::|PARSE-Expression| - BOOT::|oldParserAutoloadOnceTrigger| BOOT::|boot-LEXPR| - BOOT::|reportCount| BOOT::NEW-LEXPR1 BOOT::|spadReply| - BOOT::|listConstructorAbbreviations| BOOT::BOOT-SKIP-BLANKS - BOOT::|updateFromCurrentInterpreterFrame| - BOOT::PARSE-ARGUMENT-DESIGNATOR BOOT::PARSE-KEYWORD - BOOT::PARSE-SPADSTRING - BOOT::|initializeInterpreterFrameRing| BOOT::READ-SPAD-1 - BOOT::READBOOT BOOT::|reportWhatOptions| - BOOT::TERSYSCOMMAND BOOT::|PARSE-NewExpr| - BOOT::|makeInitialModemapFrame| - BOOT::|createCurrentInterpreterFrame| - BOOT::|getParserMacros| BOOT::|clearCmdCompletely| - BOOT::|clearCmdAll| BOOT::|clearMacroTable| - BOOT::|initializeSystemCommands| BOOT::|htSayHrule| - BOOT::|htEndTable| BOOT::|mkMenuButton| BOOT::|runspad| - BOOT::|htBeginTable| BOOT::|ncTopLevel| - BOOT::|spadStartUpMsgs| BOOT::|initializeRuleSets| - BOOT::|loadExposureGroupData| - BOOT::|statisticsInitialization| BOOT::|ut| - BOOT::|printStatisticsSummary| BOOT::|printStorage| - BOOT::|prTraceNames| BOOT::|spad| BOOT::|spadpo| - BOOT::|intloop| BOOT::|off| BOOT::|htEndTabular| - BOOT::|htSaySaturnAmpersand| BOOT::|page| - BOOT::|clearFrame| BOOT::|getSaturnExampleList| - BOOT::|saturnTERPRI| BOOT::|bcSadFaces| BOOT::YEARWEEK - BOOT::|npBPileDefinition| BOOT::|npTypified| - BOOT::|npVariablelist| BOOT::|npTagged| BOOT::|bcvspace| - BOOT::|npTypeStyle| BOOT::|npColonQuery| BOOT::|npPretend| - BOOT::|npRestrict| BOOT::|npCoerceTo| BOOT::|npRelation| - BOOT::|npFirstTok| BOOT::|npVoid| BOOT::|npSLocalItem| - BOOT::NPPCG BOOT::|npLocalItemlist| BOOT::|npFix| - BOOT::NPPCFF BOOT::|npDefaultItemlist| BOOT::|npSynthetic| - BOOT::|npAmpersandFrom| BOOT::|npBy| BOOT::|npLet| - BOOT::|npTypeVariable| BOOT::|npSignatureDefinee| - BOOT::|npAtom1| BOOT::|npConstTok| BOOT::|npLocalItem| - BOOT::|npLocalDecl| BOOT::|npExport| BOOT::|npLocal| - BOOT::|npInline| BOOT::|npFree| BOOT::|npInterval| - BOOT::|npSegment| BOOT::|npArith| BOOT::|npBreak| - BOOT::|npDefaultItem| BOOT::|npDefaultDecl| - BOOT::|npReturn| BOOT::|npSemiBackSet| - BOOT::|npSDefaultItem| BOOT::|npTypeVariablelist| - BOOT::|npPileDefinitionlist| BOOT::|npDefinitionlist| - BOOT::|npComma| BOOT::|npSymbolVariable| BOOT::|npId| - BOOT::|npSum| BOOT::|npTerm| BOOT::|npRemainder| - BOOT::|npIterate| BOOT::|npLoop| BOOT::|npSuchThat| - BOOT::|npSelector| BOOT::|npIterator| BOOT::|npSigItem| - BOOT::|npSigDecl| BOOT::|statRecordLoadEvent| - BOOT::|computeElapsedTime| BOOT::|npLambda| - BOOT::|computeElapsedSpace| BOOT::|popTimedName| - BOOT::|npBacksetElse| BOOT::|peekTimedName| - BOOT::|npQualTypelist| BOOT::|npPileExit| BOOT::|npExit| - BOOT::|statisticsSummary| BOOT::|displayHeapStatsIfWanted| - BOOT::|update| BOOT:RESTART BOOT:|version| BOOT:/EMBEDREPLY - BOOT:NEXTINPUTLINE BOOT:|Category| BOOT::|intUnsetQuiet| - BOOT::|intSetQuiet| BOOT:POP-REDUCTION - BOOT::|intSetNeedToSignalSessionManager| - BOOT::|intNewFloat| BOOT::|leaveScratchpad| BOOT::|ncError| - BOOT::|incConsoleInput| BOOT:NEXT-CHAR - BOOT::|inclmsgCmdBug| BOOT::|inclmsgIfBug| - BOOT::|inclmsgFinSkipped| BOOT::|inclmsgConsole| - COMPILER::GAZONK-NAME HELP BOOT:ADVANCE-CHAR - BOOT::|rbrkSch| BOOT::|lbrkSch|)) -(PROCLAIM - '(FTYPE (FUNCTION (*) *) BOOT::|makeSpadCommand| BOOT::/RF - BOOT::|/RQ,LIB| VMLISP:$ERASE BOOT::|mkGrepPattern1| - BOOT::|nothingFoundPage| BOOT::|dbNotAvailablePage| - BOOT::|htSetCache| BOOT::NEXT-LINE BOOT::/EF - BOOT::INIT-MEMORY-CONFIG BOOT::/RQ BOOT::|newGoGet| - BOOT::|goGet| BOOT::|dbShowOps| BOOT::|oPage| BOOT::|aPage| - BOOT::|buildLibdb| BOOT::|emptySearchPage| - BOOT::|conOpPage1| BOOT::|conPage| BOOT::|kPage| - BOOT::|genSearch| BOOT::|dbShowCons| BOOT::|form2HtString| - BOOT::|bcFinish| BOOT::|Undef| BOOT:META-SYNTAX-ERROR)) -(PROCLAIM - '(FTYPE (FUNCTION (T) *) BOOT::|numArgs| - BOOT::|formatSignatureArgs0| BOOT::|formatSignatureArgs| - BOOT::|sayWidth| BOOT::SRCABBREVS BOOT::|bcMatrixGen| - BOOT::|bcwords2liststring| BOOT::|bcGenExplicitMatrix| - BOOT::|bcGen| BOOT::|bcInputMatrixByFormulaGen| - BOOT::|bcReadMatrix| BOOT::|systemCommand| - BOOT::|safeWritify| BOOT::|unAbbreviateKeyword| - BOOT::|replacePercentByDollar| BOOT::|e04ucfSolve| - BOOT::|brightPrint0AsTeX| BOOT::|sayDisplayStringWidth| - BOOT:GET-TOKEN BOOT::|initializeLisplib| BOOT::|getMsgTag| - BOOT::|poFileName| BOOT::|mac0InfiniteExpansion,name| - BOOT::|NRTtypeHack| BOOT::|getMsgPos2| BOOT::|e02agfSolve| - BOOT::|c02agfGen| BOOT:NUMOFARGS BOOT::|c02affSolve| - BOOT::|c02affGen| BOOT::|c02agfSolve| BOOT::|c05adfGen| - BOOT::|outputTran| BOOT::|replaceSharpCalls| - BOOT::/UNTRACE-0 BOOT::|doReplaceSharpCalls| BOOT::DEFTRAN - BOOT::LIST2STRING BOOT::DEF-WHERECLAUSELIST BOOT::DEF-ISNT - BOOT::|quoteSuper| BOOT::|quoteSub| BOOT::MK_LEFORM - BOOT::MK_LEFORM-CONS BOOT::|aggSuper| - BOOT::|oldParseString| BOOT::|outformWidth| BOOT::|aggSub| - BOOT::|agggwidth| BOOT::|agggsuper| BOOT::|agggsub| - BOOT::|obj2String| BOOT::|compileFileQuietly| - BOOT::|exptSub| BOOT::|mathPrint| BOOT::|rootSub| - BOOT::|parseTransform| BOOT::|overbarWidth| - BOOT::MONITOR-EVALAFTER BOOT::|overlabelWidth| - BOOT::|object2String| BOOT::|e02aefGen| BOOT::/TRACE-0 - BOOT::LENGTH2STR BOOT::|matSub| BOOT::/MKINFILENAM - BOOT::|qTSuper| BOOT::|qTSub| BOOT::|sayMSGNT| - VMLISP:BPINAME BOOT::|e01safSolve| BOOT::|e01befSolve| - BOOT::|linkToHTPage| BOOT::|killHTPage| - BOOT::|startReplaceHTPage| BOOT::|e01dafSolve| - BOOT::|startHTPopUpPage| BOOT::|e01bffSolve| - BOOT::|e01bafGen| BOOT::|e01sefGen| BOOT::|e01bhfGen| - BOOT::|e01bhfSolve| BOOT::|e01dafGen| BOOT::|e01bgfGen| - BOOT::|e01befGen| BOOT::|e02dcfColdGen| BOOT::|e02bafGen| - BOOT::|e02agfGen| BOOT::|e02befColdGen| BOOT::|e02ajfSolve| - BOOT::|e02ddfColdGen| BOOT::|numMapArgs| - BOOT::|e02befSolve| BOOT::|e02dcfSolve| - BOOT::|e02ddfWarmGen| BOOT::|e02adfSolve| - BOOT::|e02aefSolve| BOOT::|e02ddfSolve| BOOT::|e02bafSolve| - BOOT::|e02bcfSolve| BOOT::|e02ahfGen| BOOT::|e02gafSolve| - BOOT::|e02bbfGen| BOOT::|e02adfGen| BOOT::|e02defGen| - BOOT::|e02ahfSolve| BOOT::|e02bdfGen| BOOT::|e02akfGen| - BOOT::|e02dafGen| BOOT::|e02bdfSolve| BOOT::|e02dffGen| - BOOT::|e02akfSolve| BOOT::|asyJoinPart| BOOT::|printLine| - BOOT::|sockSendWakeup| BOOT::|sockGetFloat| - BOOT::PRINT-LINE BOOT::SOCK-SEND-WAKEUP - BOOT::SOCK-GET-FLOAT BOOT::|/tb| BOOT::|/ry| BOOT::|/rx| - BOOT::|/cxd| BOOT::/FOOBAR BOOT::/CX BOOT::NEWNAMTRANS - BOOT::|htMakeInputList| BOOT::SPAD-MODETRAN - BOOT::|popSatOutput| BOOT::|subrname| BOOT::SOCK-GET-INT - BOOT::OPEN-SERVER BOOT::|protectedEVAL| - BOOT::|setOutputTex| BOOT::|setOutputFortran| BOOT::|set| - BOOT::|setLinkerArgs| BOOT::|protectSymbols| - BOOT::|protectedSymbolsWarning| BOOT::|setStreamsCalculate| - BOOT::|setOutputFormula| BOOT::|setNagHost| - BOOT::|setFunctionsCache| BOOT::|spadType| BOOT::|spadSys| - BOOT::|mkGrepFile| BOOT::|mkGrepPattern1,addOptions| - BOOT::|mkGrepPattern1,remUnderscores| - BOOT::|mkUpDownPattern| BOOT::|mkUpDownPattern,fixchar| - BOOT::|cSearch| BOOT::|verbatimize| - BOOT::|pmParseFromString,flatten| - BOOT::|htCommandToInputLine| BOOT::|detailedSearch| - BOOT::|docSearch| BOOT::|form2HtString,fnTailTail| - BOOT::|form2HtString,fn| BOOT::|sexpr2HtString| - BOOT::|kInvalidTypePage| BOOT::|args2LispString,fnTailTail| - BOOT::|sexpr2LispString,fn| BOOT::|args2LispString| - BOOT::|sexpr2LispString| BOOT::|sexpr2HtString,fn| - BOOT::|spleI| BOOT::|dbComments| BOOT::|sockGetInt| - BOOT::|parseAndEvalStr| BOOT::|parseAndEvalStr1| - BOOT::|d01gafSolve| BOOT::|d01apfGen| BOOT::|d01fcfSolve| - BOOT::|d01asfGen| BOOT::|d02bbfSolve| BOOT::|d02rafGen| - BOOT::|d02kefGen| BOOT::|d02kefSolve| BOOT::|d02ejfGen| - BOOT::|d02gbfSolve| BOOT::|d02bbfGen| BOOT::|d02bhfGen| - BOOT::|d02rafSolve| BOOT::|d02ejfSolve| BOOT::|d02bhfSolve| - BOOT::|d02gafGen| BOOT::|d02gbfGen| BOOT::|d02gafSolve| - BOOT::|d02cjfGen| BOOT::|d02cjfSolve| BOOT::|d03edfControl| - BOOT::|d03edfSolve| BOOT::|d03eefSolve| - BOOT::|d03edfLongGen| BOOT::|d03eefGen| - BOOT::|d03edfShortGen| BOOT::|e01sefSolve| - BOOT::|lnFileName| BOOT::|e01bgfSolve| BOOT::|e01safGen| - BOOT::|e01bffGen| BOOT::|e01bafSolve| - BOOT::|pfGlobalLinePosn| BOOT::|quoteString| - BOOT::|postTran| BOOT::|decodeScripts| BOOT::|htGloss| - BOOT::|htTutorialSearch| BOOT::|postInSeq| - BOOT::|htTextSearch| BOOT::|htGreekSearch| - BOOT::|postMakeCons| BOOT::|postCategory,fn| - BOOT::|htShowFunctionPageContinued| BOOT::|htCacheSet| - BOOT::|htSetFunCommand| BOOT::|listOfStrings2String| - BOOT::|htCacheOne| BOOT::|htShowSetTree| - BOOT::|htShowSetTreeValue| BOOT::|postBigFloat| - BOOT::|htSetInteger| BOOT::|chkRange| BOOT::|postConstruct| - BOOT::|postSlash| BOOT::|htCacheAddChoice| - BOOT::|startHTPage| BOOT::|htSetLinkerArgs| - BOOT::|htSetOutputCharacters| BOOT::|htSetKernelWarn| - BOOT::|htSetKernelProtect| BOOT::|htSetExpose| - BOOT::|htSetInputLibrary| BOOT::|htSetOutputLibrary| - BOOT::|htSetHistory| SPAD-SAVE BOOT:|OsEnvGet| - BOOT:|LispCompile| BOOT:|LispCompileFile| - BOOT::|condErrorMsg| BOOT:|LispLoadFile| - BOOT:|LispLoadFileQuietly| BOOT::MONITOR-RESTORE - BOOT::|brightPrintCenterAsTeX| BOOT::|brightPrint0| - BOOT::|sayWidth,fn| BOOT::|brightPrintCenter| - BOOT::|clearClam| BOOT::|brightPrintHighlightAsTeX| - BOOT::|brightPrintHighlight| BOOT::|sayDisplayWidth,fn| - BOOT::|sayDisplayWidth| BOOT::INIT-LIB-FILE-GETTER - BOOT::INIT-FILE-GETTER BOOT::|entryWidth| BOOT::FILE-RUNNER - BOOT::|editFile| BOOT::|readForDoc| BOOT::|checkNumOfArgs| - BOOT::|openServer| BOOT::|removeBackslashes| - BOOT::|checkAddBackSlashes| BOOT::/RF-1 BOOT::|docreport| - BOOT::|ExecuteInterpSystemCommand| BOOT::|pfFileName| - BOOT::|InterpExecuteSpadSystemCommand| BOOT::|alistSize| - BOOT::|parseTranList| BOOT::|parseOr| BOOT::|parseIf| - BOOT::|parseImplies| BOOT::|parseEquivalence| - BOOT::|parseLhs| BOOT::|parseAnd| BOOT::|parseLeftArrow| - BOOT::|parseUpArrow| BOOT::|parseNotEqual| BOOT::|parseNot| - BOOT::|parseDollarNotEqual| BOOT::|parseDollarGreaterEqual| - BOOT::|parseDollarLessEqual| BOOT::|parseGreaterEqual| - BOOT::|parseLessEqual| BOOT::|scriptTranRow1| - BOOT::|scriptTran| BOOT::|scriptTranRow| - BOOT::|parseExclusiveOr| BOOT::QUOTE-IF-STRING - BOOT::|dbConformGenUnder| BOOT::|listOfEntries| - BOOT::|conformString| BOOT::|dbConformGen| - BOOT::|evalableConstructor2HtString| BOOT::|halfWordSize| - BOOT::|fortFormatCharacterTypes,mkCharName| - BOOT::|opPageFast| - BOOT::|fortFormatCharacterTypes,par2string| VMLISP::MAKEDIR - VMLISP::DELETE-DIRECTORY VMLISP::GET-IO-INDEX-STREAM - VMLISP::GET-INPUT-INDEX-STREAM VMLISP::DIRECTORY? - BOOT::|c05pbfGen| BOOT::|c05nbfGen| BOOT::|c05pbfSolve| - BOOT::|c05nbfSolve| BOOT::|e02dafSolve| BOOT::|c06ebfGen| - BOOT::|c06ebfSolve| BOOT::|c06gsfGen| BOOT::|c06gsfSolve| - BOOT::|c06ekfSolve| BOOT::|c06eafSolve| BOOT::|c06gqfGen| - BOOT::|c06ecfGen| BOOT::|c06fpfGen| BOOT::|c06frfSolve| - BOOT::|c06gbfSolve| BOOT::|c06fqfGen| BOOT::|c06gqfSolve| - BOOT::|c06eafGen| BOOT::|c06gcfGen| BOOT::|c06gcfSolve| - BOOT::|c06gbfGen| BOOT::|c06fufGen| BOOT::|s01eafGen| - BOOT::|s21bafGen| BOOT::|c06fpfSolve| BOOT::|s17dcfGen| - BOOT::|c06fqfSolve| BOOT::|s18defGen| BOOT::|c06frfGen| - BOOT::|s14bafGen| BOOT::|s18dcfGen| BOOT::|s17dhfGen| - BOOT::|c06ecfSolve| BOOT::|s21bdfGen| BOOT::|c06fufSolve| - BOOT::|c06ekfGen| BOOT::|s21bcfGen| BOOT::|sGen| - BOOT::|s17dgfGen| BOOT::|d01anfGen| BOOT::|d01ajfGen| - BOOT::|d01aqfGen| BOOT::|d01gafGen| BOOT::|d01bbfGen| - BOOT::|s21bbfGen| BOOT::|d01amfGen| BOOT::|s17dlfGen| - BOOT::|d01alfGen| BOOT::|d01fcfGen| BOOT::|d01akfGen| - BOOT::|d01gbfGen| BOOT::|d01gbfSolve| VMLISP::|npPC| - VMLISP::|npPP| BOOT::|exp2FortOptimizeArray| - BOOT::|fortError1| BOOT::|fortPre1| BOOT::|spadcall1| - BOOT::|fortPreRoot| BOOT::|checkPrecision| - BOOT::|fix2FortranFloat| BOOT::|normalizeStatAndStringify| - BOOT::|mkParameterList,par2string| BOOT::|f02wefSolve| - BOOT::|f02ajfGen| BOOT::|printAny| BOOT::|f02adfGen| - BOOT::|e02dffSolve| BOOT::|printString| BOOT::|f04jgfGen| - BOOT::|f04qafGen| BOOT::|f04asfGen| BOOT::|summary| - BOOT::|show| BOOT::|showSpad2Cmd| BOOT::|f04qafSolve| - BOOT::|f04mbfGen| BOOT::|f04fafGen| BOOT::|f04arfGen| - BOOT::|f04adfSolve| BOOT::|fixObjectForPrinting| - BOOT::|savesystem| BOOT::|escapeSpecialChars| - BOOT::|f04mcfSolve| BOOT::|encodeItem| BOOT::|f04atfGen| - BOOT::|form2LispString| BOOT::|f04adfGen| - BOOT::|concatWithBlanks| BOOT::|withAsharpCmd| - BOOT::|f04jgfSolve| BOOT::|extendLocalLibdb| - BOOT::|deleteFile| BOOT::|compileAsharpCmd1| - BOOT::|f04mcfGen| BOOT::|f04arfSolve| BOOT::|frame| - BOOT::|frameSpad2Cmd| BOOT::|addNewInterpreterFrame| - BOOT::|getEnv| BOOT::|f04asfSolve| BOOT::|f04fafSolve| - BOOT::|f04mbfSolve| BOOT::|f04atfSolve| BOOT::|f07fdfSolve| - BOOT::|obey| BOOT::|f07aefGen| BOOT::|buildLibdbString| - BOOT::|f07aefSolve| BOOT::|f07fefGen| BOOT::|f07adfSolve| - BOOT::|f07adfGen| BOOT::|dbReadComments| - BOOT::|f07fefSolve| BOOT::|f07fdfGen| BOOT::|s17defGen| - BOOT::|f01qdfSolve| BOOT::|f01rcfSolve| BOOT::|f01mafGen| - BOOT::|f01rdfGen| BOOT::|f01mafSolve| BOOT::|f01brfGen| - BOOT::|f01mcfGen| BOOT::|f02axfGen| BOOT::|f02aefSolve| - BOOT::|f02akfGen| BOOT::|f02abfSolve| BOOT::|f02bjfGen| - BOOT::|bcErrorPage| BOOT::|f02xefGen| BOOT::|form2String| - BOOT::|f02aafSolve| BOOT::|dbSourceFile| - BOOT::MAKE-REASONABLE BOOT::|f02ajfSolve| - BOOT::|f02axfSolve| BOOT::|f02affSolve| BOOT::|downlink| - BOOT::BRIGHTPRINT-0 BOOT::|f02wefGen| - BOOT::|conform2String| BOOT::|f02akfSolve| - BOOT::|f02adfSolve| BOOT::|f02aafGen| - BOOT::|dbSpecialExports| BOOT::|f02agfGen| - BOOT::|f02bjfSolve| BOOT::|buildLibdbConEntry| - BOOT::|f02agfSolve| BOOT::|dbSpecialDescription| - BOOT::|f02xefSolve| BOOT::|f02abfGen| BOOT::|f02bbfGen| - BOOT::|mkButtonBox| BOOT::|f02awfSolve| - BOOT::|assignSlotToPred| BOOT::|f02bbfSolve| - BOOT::|f02aefGen| BOOT::|f02awfGen| BOOT::|f02affGen| - BOOT::|dbMkEvalable| BOOT::|mkEvalable| - BOOT::|conPageChoose| BOOT::KILL-TRAILING-BLANKS - BOOT::|ySearch| BOOT::|aSearch| BOOT::|close| - BOOT::|kSearch| BOOT::|compileBoot| BOOT::|aokSearch| - BOOT::|showNamedConstruct| - BOOT::|reportOpsFromUnitDirectly1| BOOT::|oSearch| - BOOT::|tabsToBlanks| BOOT::|underscoreDollars| - BOOT::|mkGrepTextfile| BOOT::|reportOpsFromUnitDirectly0| - BOOT::|replaceGrepStar| BOOT::|grepSource| BOOT::|xSearch| - BOOT::|pSearch| BOOT::|dSearch| BOOT::|doSystemCommand| - BOOT::|standardizeSignature| BOOT::|conPageFastPath| - BOOT::|conPageConEntry| BOOT::|quickForm2HtString| - BOOT::|dbAttr| BOOT::|e02ajfGen| BOOT::|pluralize| - BOOT::|parseTran| BOOT::|e02defSolve| - BOOT::|dbSpecialOperations| BOOT::|issueHTStandard| - BOOT::|justifyMyType| BOOT::|getCallBackFn| - BOOT::|bcDifferentiateGen| BOOT::|bcIndefiniteIntegrateGen| - BOOT::|htMakeErrorPage| BOOT::|issueHT| - BOOT::|setOutputAlgebra| BOOT::|bcDraw2DparGen| - BOOT::|ExecuteSpadSystemCommand| BOOT::|bcDraw3Dpar1Gen| - BOOT::|bcProductGen| BOOT::|ts| BOOT::|bcRealLimitGen| - BOOT::|e02zafGen| BOOT::|bcSumGen| BOOT::|bcDraw3DparGen| - BOOT::|bcDraw3DfunGen| BOOT::|aggwidth| BOOT::WIDTH - BOOT::|bcDefiniteIntegrateGen| BOOT::|bcSeriesGen| - BOOT::|subspan| BOOT::|bcPuiseuxSeriesGen| - BOOT::|bcLaurentSeriesGen| BOOT::|superspan| - BOOT::|bcSeriesByFormulaGen| BOOT::|bcNotReady| - BOOT::|bcDraw2DfunGen| BOOT::|bcTaylorSeriesGen| - BOOT::|bcDraw2DSolveGen| BOOT::KCL-OS-ENV-GET - BOOT::|bcComplexLimitGen| BOOT::|saturnPRINTEXP| - BOOT::|bcSeriesExpansionGen| BOOT::COMPILE-BOOT-FILE - BOOT::|bcCreateVariableString| BOOT::|bcGenEquations| - BOOT::|vConcatSuper| BOOT::BOOT-LOAD - BOOT::|bcSolveNumerically1| BOOT::|bcLinearSolveEqnsGen| - BOOT::|bcMakeUnknowns| BOOT::|bcInputSolveInfo| - BOOT::|bcInputEquationsEnd| BOOT::|bcSystemSolveEqns1| - BOOT::|bcLinearSolveEqns1| BOOT::|bcVectorGen| - BOOT::|printBasic| BOOT::|subSuper| BOOT::|tr| - BOOT::|bcLinearSolveMatrix1| BOOT::|stringList2String| - BOOT::|bcString2HyString2| BOOT::|bcwords2liststring,fn| - BOOT::|linkGen| BOOT::|optCallEval| BOOT::|tokType| - BOOT::|timedEvaluate| BOOT::|roundStat| - BOOT::|bracketString| BOOT::|e02bcfGen| BOOT::|e02gafGen| - BOOT::|e02bbfSolve| VMLISP:OBEY BOOT::|e04ycfSolve| - BOOT::|e04nafSolve| BOOT::|e04dgfSolve| BOOT::|e04fdfGen| - BOOT::|e04gcfGen| BOOT::|NRTevalDomain| BOOT::|e04fdfSolve| - BOOT::|e04mbfSolve| BOOT::|e04nafGen| BOOT::|e04gcfSolve| - BOOT::|e04ucfGen| BOOT::|e04jafGen| BOOT::|e04mbfGen| - BOOT::|e04jafSolve| BOOT::|e04dgfGen| BOOT::|e04ycfGen| - BOOT::|f01rdfSolve| BOOT::|f01mcfSolve| BOOT::|f01qdfGen| - BOOT::|f01qcfGen| BOOT::|f01qefGen| BOOT::|f01rcfGen| - BOOT::|f01refSolve| BOOT::|f01qefSolve| BOOT::|e02zafSolve| - BOOT::|f01qcfSolve| BOOT::|f01refGen| BOOT::|f01brfSolve| - BOOT::|poGlobalLinePosn| BOOT:|sayString| - BOOT::|incHandleMessage| BOOT::|pred2English| - BOOT::|prefix2String0| BOOT::|form2StringLocal| - BOOT::|formatOpType| BOOT::|form2String1| BOOT::|ncTag| - BOOT::|ncAlist| BOOT::|tuple2String,f| - BOOT::|formatAttributeArg| BOOT::|formString| - BOOT::|form2StringWithPrens| BOOT::|prefix2String| - BOOT::|form2StringAsTeX| BOOT::|prefix2StringAsTeX|)) -(PROCLAIM - '(FTYPE (FUNCTION (*) T) BOOT::|bcConform| BOOT:STREAM-EOF - BOOT::|categoryParts| BOOT:IOCLEAR BOOT:SAY BOOT:MOAN - BOOT::|centerNoHighlight| BOOT:CROAK BOOT::INTERRUPT - BOOT::LISP-BREAK-FROM-AXIOM BOOT:META VMLISP:NILFN - BOOT::MAKE-DATABASE BOOT::|defaultTargetFE| BOOT::/DUPDATE - BOOT::/UPDATE BOOT::/MONITOR VMLISP:$FILEP VMLISP:CALLBELOW - BOOT::|systemError| BOOT::|listSort| - BOOT::|asCategoryParts| BOOT::RDEFOUTSTREAM - BOOT::RDEFINSTREAM VMLISP::SETQERROR BOOT::|throwMessage| - BOOT::TOPLEVEL BOOT::|getDomainSigs| - BOOT::|getInheritanceByDoc| BOOT::|showImp| - BOOT::|showFrom| BOOT::|getDomainDocs| BOOT::|grepFile| - BOOT::|printRecordFile| BOOT::|wasIs| - BOOT::|htFile2RecordFile| BOOT::|inputFile2RecordFile| - BOOT::|htFile2InputFile| BOOT::|bcComments| - BOOT::|bcNameTable| BOOT::|dbSayItemsItalics| - BOOT::|htPred2English| BOOT::|interpret| - BOOT::|Enumeration,LAM| VMLISP:VMREAD VMLISP:RKEYIDS - BOOT::/RP BOOT::MONITOR-TESTED BOOT::MONITOR-RESET - BOOT::MONITOR-DISABLE BOOT::MONITOR-ENABLE - BOOT::|returnStLFromKey| BOOT::MAKE-MONITOR-DATA - BOOT::|level| BOOT::LEVEL BOOT::|resolveTT| - BOOT::|isLegitimateMode| BOOT::|hasFileProperty| - BOOT::|coerceConvertMmSelection| BOOT::|canCoerce| - BOOT::|selectMms1| BOOT::|canCoerceFrom| BOOT::MAKE-TOKEN - BOOT::MAKE-LINE BOOT::|centerAndHighlight| BOOT::|getOpDoc| - BOOT::MAKE-STACK BOOT::|firstNonBlankPosition| - BOOT::MAKE-XDR-STREAM BOOT::INITROOT - BOOT::|EnumerationCategory,LAM| BOOT::|Mapping| - BOOT::|RecordCategory,LAM| BOOT::|Union| - BOOT::|UnionCategory,LAM| BOOT::|displayCategoryTable| - BOOT::MAKE-REDUCTION BOOT::READ-A-LINE BOOT::|dbPresentOps| - BOOT::|buildBitTable| BOOT::|htBlank| - BOOT::|dbMakeContrivedForm| BOOT::|dcSize| BOOT::|sum| - BOOT::|args2HtString| BOOT::|dc| BOOT::|bcNameCountTable| - VMLISP::MAKE-LIBSTREAM BOOT::|nextown1| BOOT::|next1| - BOOT::|incAppend1| BOOT::|synonym| BOOT::|grepConstruct| - VMLISP::LOTSOF BOOT::|htBeginMenu| BOOT::|bcCon| - BOOT::|koOps| BOOT::|dbWriteLines| BOOT::|catsOf| - BOOT::|getDomainOpTable| BOOT:|PlainError| - BOOT:|PlainPrint| BOOT::|htInitPageNoScroll| - BOOT:|ReadLispExpr| BOOT::|conSpecialString?| - BOOT::|htSayStandard| BOOT:|StreamFlush| BOOT:|NewPathname| - BOOT:|SessionPathname| BOOT::|domainsOf| - BOOT::|dbPresentCons| READLINE BOOT:|StringConcat| - BOOT::|htBcLinks| BOOT::|pluralSay| - BOOT::|getConstructorExports| BOOT::|sublisFormal| - BOOT::NEXT-META-LINE BOOT::|htLispLinks| - BOOT::META-META-ERROR-HANDLER BOOT::|dbHeading| - BOOT::NEXT-BOOT-LINE BOOT::|concat| BOOT::SPAD_SYNTAX_ERROR - BOOT::BOOT BOOT::|htQuery| BOOT::SPAD - BOOT::|htSayIndentRel| BOOT::|bcConPredTable| - BOOT::|htSaySaturn| BOOT::|dbSayItems| BOOT::|simpHasPred| - BOOT::|start| BOOT::|protectedPrompt| - BOOT::|htpMakeEmptyPage| BOOT::|htMakeButton| - BOOT::|htSayIfStandard| BOOT::|htSay| BOOT::|incZip1| - BOOT::|incIgen1| BOOT::|incRgen1| - BOOT::|runOldAxiomFunctor| BOOT:|fillerSpaces| - BOOT::|incLude1| FOAM::MAKE-FOAMPROGINFOSTRUCT - BOOT::|bcPred| BOOT::|sayNewLine|)) -(PROCLAIM - '(FTYPE (FUNCTION (T) CHARACTER) VMLISP:EBCDIC VMLISP:NUM2CHAR - BOOT::LINE-CURRENT-CHAR)) -(PROCLAIM '(FTYPE (FUNCTION (T T *) FIXNUM) BOOT::LINE-NEW-LINE)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T) FIXNUM) BOOT::|rwrite128|)) -(PROCLAIM - '(FTYPE (FUNCTION (T) STRING) BOOT::|stripSpaces| BOOT::LINE-BUFFER - BOOT::DROPTRAILINGBLANKS)) -(PROCLAIM - '(FTYPE (FUNCTION (T) T) BOOT::|form2FenceQuoteTail| - BOOT::|combineMapParts| BOOT::|form2FenceQuote| - BOOT::|mkMapPred| BOOT::|formatOpConstant| - BOOT::|formJoin2| BOOT::|axOpTran| BOOT::|axFormatOpList| - BOOT::|axFormatOp| BOOT::|optcomma| - BOOT::|displayTranModemap| - BOOT::|makeInternalMapMinivectorName| - BOOT::|cleanUpSegmentedMsg| BOOT::|makeDefaultDef| - BOOT::|getDefaultingOps| BOOT::|getOpSegment| - BOOT::|removeIsDomainD| BOOT::|formatSignatureAsTeX| - BOOT::|axFormatType| BOOT::|sayRemoveFunctionOrValue| - BOOT::|pvarCondList| BOOT::|makeTypeSequence| - BOOT::|makeArgumentIntoNumber| BOOT::|axFormatAttrib| - BOOT::|categoryForm?| BOOT::|axFormatCondOp| BOOT:OPTIONAL - BOOT::|axFormatPred| BOOT::|fileConstructors| - BOOT::SOURCEPATH BOOT::|untraceMapSubNames| BOOT:LASTELEM - BOOT::|mapPredTran| BOOT::|makeDefaultArgs| - BOOT::|stripType| BOOT::|dqUnitCopy| BOOT::|mkAliasList| - BOOT::|dqUnit| BOOT::|modemapToAx| - BOOT::|isDefaultPackageName| BOOT::|getEqualSublis| - BOOT::|myWritable?| BOOT::|getInfovec| BOOT::|predTran| - BOOT::|fnameReadable?| BOOT::|hasDefaultPackage| - BOOT::|compFailure| BOOT::|fnameType| - BOOT::|setExtendedDomains| - BOOT::|simplifyMapConstructorRefs| BOOT::|fnameName| - BOOT::|StringToDir| - BOOT::|spad2AxTranslatorAutoloadOnceTrigger| - BOOT::|fnameDirectory| - BOOT::|simplifyMapPattern,unTrivialize| BOOT::|DirToString| - BOOT::|isPatternArgument| BOOT::|htQuote| - BOOT::|isConstantArgument| BOOT::|frameName| - BOOT::|objValUnwrap| BOOT::|htMakePage| - BOOT::|PARSE-LedPart| BOOT::|htpPropertyList| - BOOT::|analyzeMap,f| BOOT::|PARSE-NudPart| - BOOT::|PARSE-Expr| BOOT::|bcHt| BOOT::|getIteratorIds| - BOOT::|getUserIdentifiersInIterators| - BOOT::|htpInputAreaAlist| BOOT::|getUserIdentifiersIn| - BOOT::|PARSE-GliphTok| BOOT::|kePageOpAlist| - BOOT::|fileNameStrings| BOOT::|inclmsgCannotRead| - BOOT::MAKE-SYMBOL-OF BOOT:MATCH-ADVANCE-STRING - BOOT::|removeUndoLines| BOOT::STACK-SIZE BOOT:NOTE - BOOT::|histFileErase| BOOT::|histInputFileName| - BOOT::STACK-STORE BOOT::|readHiFi| BOOT::|restoreHistory| - BOOT::STACK-UPDATED BOOT::|clearSpad2Cmd| BOOT::|getToken| - BOOT::|makeHistFileName| BOOT::|changeHistListLen| - BOOT::|showHistory| BOOT::|setIOindex| BOOT::|saveHistory| - BOOT::|PARSE-NBGliphTok| BOOT::|dewritify,dewritifyInner| - BOOT::|setHistoryCore| BOOT::|charDigitVal| - BOOT::|dewritify,is?| BOOT::|writify| BOOT::|history| - BOOT::|gensymInt| BOOT::|dewritify| BOOT::TOKEN-NONBLANK - BOOT::|undoFromFile| BOOT::FLOATEXPID - BOOT::|e02dffSolve,fy| BOOT::|spadClosure?| - BOOT::|bustUnion| BOOT::|writify,writifyInner| - BOOT::|undoChanges| BOOT::|undoInCore| BOOT::|getSlot1| - BOOT::|writifyComplain| BOOT::|unwritable?| - BOOT::|dbSpecialDisplayOpChar?| BOOT::|removeAttributes| - BOOT:|pathname| BOOT::|isLeaf| BOOT::|srcPosDisplay| - BOOT::|srcPosColumn| BOOT::|transformOperationAlist| - BOOT::|srcPosSource| BOOT::|sayNonUnique| - BOOT::|compDefWhereClause,removeSuchthat| - BOOT::|srcPosLine| BOOT::|compTuple2Record| - BOOT::|srcPosFile| BOOT::|mkAtreeValueOf1| BOOT::|center80| - BOOT::|loadFunctor| - BOOT::|compDefWhereClause,transformType| - BOOT::|mkCategoryPackage,gn| - BOOT::|updateCategoryFrameForConstructor| BOOT:|sayFORMULA| - BOOT::|convertOpAlist2compilerInfo| - BOOT::|getCategoryOpsAndAtts| BOOT::|lispize| - BOOT::|getSrcPos| BOOT::|mustInstantiate| - BOOT::|isSystemDirectory| BOOT:ASSOCRIGHT BOOT::|getFlag| - BOOT::|getMsgToWhere| BOOT::|mkExplicitCategoryFunction,fn| - BOOT::|updateCategoryFrameForCategory| BOOT:CURSTRMLINE - BOOT::|alreadyOpened?| BOOT::|msgImPr?| BOOT::|Operators| - BOOT::|mkAtree1| BOOT::|getLineText| BOOT::|pfSourceText| - BOOT::|toFile?| BOOT::|getMsgArgL| BOOT::|poGetLineObject| - BOOT:BRIGHTPRINT BOOT::|getLinePos| - BOOT::|loadIfNecessaryAndExists| BOOT::|lnPlaceOfOrigin| - BOOT::|makeLeaderMsg| BOOT::|putInLocalDomainReferences| - BOOT::|pfPosOrNopos| BOOT::|killNestedInstantiations| - BOOT::|NRTputInTail| BOOT::|quotifyCategoryArgument| - BOOT::|getLisplibVersion| BOOT::|getMsgPrefix| - BOOT::|unInstantiate| BOOT::|asTupleAsVector| - BOOT::|lisplibDoRename| BOOT::|asTupleSize| - BOOT::|finalizeLisplib| BOOT::|disallowNilAttribute| - BOOT::|asTupleNewCode0| BOOT::|processKeyedError| - BOOT::|toScreen?| BOOT::|compileConstructor1| - BOOT::|compileDocumentation| BOOT::|transformREPEAT| - BOOT::|line?| BOOT::|readLibPathFast| - BOOT::|modemap2Signature| BOOT::|transformCollect| - BOOT::|msgLeader?| BOOT::|compileConstructor| - BOOT::|initToWhere| BOOT::|initImPr| - BOOT::|putDatabaseStuff| BOOT::|e02defSolve,fxy| - BOOT::|getMsgPosTagOb| BOOT::|pfIdSymbol| - BOOT::|mkAtreeExpandMacros| BOOT::|getMsgPos| - BOOT::|macApplication| BOOT::|isInterpMacro| - BOOT::|getMsgFTTag?| BOOT::|leader?| - BOOT::|pf0ApplicationArgs| BOOT::|atree2EvaluatedTree| - BOOT::|remFile| BOOT::|pfMLambda?| BOOT::|whichCat| - BOOT::|pfApplicationOp| BOOT::|removeBindingI| - BOOT::|addArgumentConditions,fn| BOOT::|macId| - BOOT:STRMBLANKLINE BOOT::|getUnname1| BOOT:STRMSKIPTOBLANK - BOOT::|remLine| BOOT::|pfSourcePosition| - BOOT::|spadCompileOrSetq| BOOT::|getMsgKey?| - BOOT::|mac0Get| BOOT::|getMsgKey| BOOT::|compile| - BOOT::|evaluateType| BOOT::|constructMacro| - BOOT::|poPosImmediate?| BOOT::|pfMLambdaBody| - BOOT::|poNopos?| BOOT::|evaluateType1| - BOOT::|pf0MLambdaArgs| BOOT:NEXTSTRMLINE - BOOT::|evaluateSignature| BOOT::|macMacro| - BOOT::|poLinePosn| BOOT::|failCheck| BOOT::|pfNothing?| - BOOT::|compile,isLocalFunction| BOOT::|macSubstituteOuter| - BOOT::|erMsgSep| BOOT::|pfMacroRhs| BOOT::|mkConstructor| - BOOT::|showMsgPos?| BOOT::|pfMacroLhs| BOOT::|macExpand| - BOOT:IS_GENVAR BOOT::|mkEvalableMapping| BOOT::|macLambda| - BOOT::|getMsgInfoFromKey| BOOT::|evaluateType0| - BOOT::|getStFromMsg| BOOT::|getUnnameIfCan| - BOOT::|macWhere| BOOT::|tabbing| BOOT::|getMsgLitSym| - BOOT::|pfApplication?| BOOT::|getPosStL| BOOT::|pfMacro?| - BOOT::|doItIf,localExtras| BOOT::|getMsgText| - BOOT::|mkEvalableUnion| BOOT::|pfLambda?| - BOOT::|getMsgPrefix?| BOOT::|mkEvalableRecord| - BOOT::|pfWhere?| BOOT::|getPreStL| BOOT::|makeOrdinal| - BOOT::|mac0GetName| BOOT::|getAndEvalConstructorArgument| - BOOT::|msgOutputter| BOOT::|pfLeaf?| - BOOT::|mkEvalableCategoryForm| BOOT::|getMsgTag?| - BOOT::|devaluateDeeply| BOOT::|pfLeafPosition| - BOOT::|compDefineFunctor1,FindRep| BOOT::|pfAbSynOp| - BOOT::|listOutputter| BOOT::|pfTypedId| - BOOT::|processChPosesForOneLine| BOOT::|pf0LambdaArgs| - BOOT::|e02dffSolve,fx| BOOT::|getModeSetUseSubdomain| - BOOT::MKQSADD1 BOOT::|getModeSet| BOOT::|poCharPosn| - BOOT::|posPointers| BOOT::|NRTgenInitialAttributeAlist| - BOOT::|makeMsgFromLine| BOOT::THETA_ERROR - BOOT::|mkRationalFunction| BOOT::MACROEXPANDALL - BOOT::|isCategoryPackageName| BOOT::|erMsgSort| - BOOT::|isAVariableType| BOOT::|msgNoRep?| - BOOT::|getPrincipalView| BOOT::|To| BOOT::|hitListOfTarget| - BOOT::SUBANQ BOOT::|From| BOOT::|domainDepth| - BOOT::|NRTgetLocalIndexClear| BOOT::|constructSubst| - BOOT::|containsVars| BOOT::|evalMmDom| - BOOT::|abbreviationsSpad2Cmd| - BOOT::|formatUnabbreviatedSig| BOOT::|optFunctorBody| - BOOT::|optimize| BOOT::|emptyAtree| BOOT::|templateParts| - BOOT::|dqToList| BOOT::|dqConcat| BOOT::|isHomogeneousList| - BOOT::|isUncompiledMap| BOOT::|printMms| - BOOT::|getSymbolType| BOOT::/UNTRACE-REDUCE - BOOT::|matchMmCond| BOOT::|object2Identifier| - BOOT::|selectMostGeneralMm| BOOT::|fixUpTypeArgs| - BOOT::|handleLispBreakLoop| BOOT::TRACEOPTIONS BOOT:REMDUP - BOOT::|evalMmStack| BOOT::SHOWBIND BOOT::DROPENV - BOOT::UNVEC BOOT::|noSharpCallsHere| - BOOT::|untraceDomainConstructor| BOOT:CURMAXINDEX - BOOT::|isDomain| BOOT::|getFunctionSourceFile| - BOOT::|isMap| BOOT::HACKFORIS1 BOOT::HACKFORIS - BOOT::|containsVars1| BOOT::|orderMmCatStack| - BOOT::|evalMmStackInner| BOOT::DEF-IN2ON - BOOT::|new2OldTran| BOOT::|resolveTypeList| - BOOT::|newConstruct| BOOT::|newIf2Cond| BOOT::|newDef2Def| - BOOT::|asTupleNew0| BOOT::DEF-MESSAGE1 BOOT::LIST2STRING1 - BOOT::DEF-WHERE BOOT::DEF-SEQ BOOT::SEQOPT BOOT::DEF-IS - BOOT::DEF-EQUAL BOOT::DEF-MESSAGE BOOT::DEF-CATEGORY - BOOT::DEF-REPEAT BOOT::DEF-COND BOOT::DEF-LESSP - BOOT::SMINT-ABLE BOOT::DEF-COLLECT BOOT::DEF-STRING - BOOT::|Zeros| BOOT::DEF-SETELT BOOT::DEF-RENAME1 - BOOT::DEF-ELT BOOT::|DEF-:| BOOT::DEF-ADDLET - BOOT::|quoteWidth| BOOT::DEF-INSERT_LET1 BOOT::|boxSuper| - BOOT::DEF-WHERECLAUSE BOOT::DEF-STRINGTOQUOTE - BOOT::|boxSub| BOOT::DEF-INSERT_LET BOOT::LIST2CONS-1 - BOOT::|bootTransform| BOOT::|concatWidth| - BOOT::DEF-IS-REMDUP1 BOOT::|altSuperSubWidth| - BOOT::|altSuperSubSuper| BOOT::|concatbWidth| - BOOT::LIST2CONS BOOT::|altSuperSubSub| BOOT::DEF-IS-REMDUP - BOOT::|concatSuper| BOOT::DEF-IS-EQLIST - VMLISP:RECOMPILE-DIRECTORY BOOT::|concatSub| - BOOT::|new2OldDefForm| BOOT::|binomWidth| - BOOT::|binomSuper| BOOT::DEF-SELECT BOOT::|binomSub| - BOOT::COMP-TRAN-1 BOOT::PUSHLOCVAR BOOT::COMP-EXPAND - BOOT::|canCacheLocalDomain,domargsglobal| VMLISP:MAKE-CVEC - BOOT::|inSuper| BOOT::COMP-NEWNAM BOOT::COMP-TRAN - BOOT::|inSub| BOOT::COMP-FLUIDIZE BOOT::|addInputLibrary| - BOOT::|inWidth| BOOT::|dropInputLibrary| - BOOT::|openOutputLibrary| BOOT::|moveORsOutside| - BOOT::|stepSuper| BOOT::|outputTranMatrix| - BOOT::|fracwidth| BOOT::|stepSub| BOOT::|compQuietly| - BOOT::|listOfPatternIds| BOOT::|fracsuper| BOOT::COMP-1 - BOOT::|getOplistForConstructorForm| BOOT::|stepWidth| - BOOT::COMP-2 VMLISP:TRIMSTRING BOOT::|maprin0| - BOOT::|compAndDefine| BOOT::|abbreviate| BOOT::|fracsub| - BOOT::|exptSuper| BOOT::|mathPrintTran| - BOOT::|COMP,FLUIDIZE| VMLISP:COMP370 BOOT::|exptWidth| - BOOT::|rootWidth| BOOT::|with| BOOT::|exptNeedsPren| - BOOT::|minusWidth| VMLISP:|log| BOOT::|maprin| - BOOT::|loadDependents| BOOT::|concatTrouble,fixUp| - BOOT::|loadIfNecessary| VMLISP:MBPIP BOOT::|timesWidth| - BOOT::|rootSuper| BOOT::|interactiveModemapForm,fn| - BOOT::|largeMatrixAlist| VMLISP:QSORT BOOT::|sumWidth| - VMLISP:PLACEP BOOT::LOG10 BOOT::|aggWidth| BOOT::|zagWidth| - BOOT::|pi2Width| BOOT::|rebuildCDT| BOOT::|LZeros| - BOOT::|e02zafSolve,fmu| BOOT::|signatureTran| - BOOT::|destructT| BOOT::|userError| BOOT::|clearAllSlams| - BOOT::|displayComp| VMLISP:HKEYS BOOT::|mkErrorExpr| - BOOT::|pi2Sup| BOOT::|compOrCroak1,compactify| - BOOT::|pi2Sub| BOOT::|convertSpadToAsFile| - BOOT::|overbarSuper| BOOT::|outputOp| BOOT::|compiler| - BOOT::|resolveTMRed1| BOOT::|resolveTTRed3| - BOOT::|fnameWritable?| BOOT::MONITOR-EVALBEFORE - VMLISP:UPCASE BOOT::|interpOp?| BOOT::|pathnameName| - BOOT::|pathnameDirectory| BOOT::SPADSYSNAMEP VMLISP:STATEP - BOOT::|compileSpad2Cmd| BOOT::MONITOR-BLANKS - BOOT::|piWidth| BOOT::|newType?| BOOT::WHOCALLED - BOOT::|charyTopWidth| VMLISP:FBPIP BOOT::|bubbleType| - BOOT::|putWidth| BOOT::|piSup| BOOT::OPTIONS2UC - BOOT::|overlabelSuper| BOOT::|pathnameType| - BOOT::|spadThrowBrightly| BOOT::/OPTIONS BOOT::|piSub| - BOOT::/UNEMBED-Q BOOT::/UNEMBED-1 - BOOT::|typeIsASmallInteger| BOOT::|indefIntegralWidth| - BOOT::|indefIntegralSup| BOOT::|isSimple| VMLISP:UNEMBED - BOOT::|indefIntegralSub| BOOT::|primitiveType| - BOOT::|mkAtree| BOOT::/UNTRACELET-2 - BOOT::|outputTranIterate| BOOT::|errorRef| - VMLISP:RE-ENABLE-INT BOOT::/UNTRACELET-1 BOOT::|intWidth| - BOOT::|NRTgetLocalIndex| BOOT::|getOutputAbbreviatedForm| - BOOT::|isFluid| VMLISP:IVECP BOOT::|iterVarPos| - BOOT::|remWidth| VMLISP:LIST2VEC BOOT::|matWidth| - BOOT::|asTupleAsList| BOOT::|outputTranIteration| - VMLISP:LISTOFQUOTES BOOT::|upcase| BOOT::|intSup| - BOOT::|reassembleTowerIntoType| BOOT::|upor| - BOOT::|matSuper| BOOT::|hasFormalMapVariable,hasone?| - BOOT::|intSub| VMLISP:IS-CONSOLE BOOT::|coerceUnion2Branch| - BOOT::|PushMatrix| BOOT::MKPROGN BOOT::|uncons| - VMLISP:MAKE-ABSOLUTE-FILENAME - BOOT::|retract2Specialization| BOOT::|sigma2Width| - VMLISP:FUNARGP BOOT::|syminusp| BOOT::|NRTassocIndex| - BOOT::|resolveTypeListAny| BOOT::MONITOR-PRINTREST - BOOT::|extwidth| BOOT::|varsInPoly| BOOT::|sigma2Sup| - BOOT::|stackWarning| BOOT::SMALL-ENOUGH BOOT::|extsuper| - BOOT::|sigma2Sub| BOOT::|extsub| BOOT::|sigmaWidth| - BOOT::/INITUPDATES BOOT::|sigmaSup| BOOT::IS_SHARP_VAR - BOOT::|sigmaSub| BOOT::|retract1| BOOT::|qTWidth| VMLISP:LN - BOOT::|decomposeTypeIntoTower| BOOT::|transcomparg| - BOOT::FUNLOC BOOT::|stringWidth| - BOOT::|mathprintWithNumber| BOOT::COND-UCASE - VMLISP:PROPLIST BOOT::|texFormat| BOOT::|bubbleConstructor| - BOOT::|isSubForRedundantMapName| BOOT::|isDomainOrPackage| - BOOT::|dispfortexp| BOOT::|isInterpOnlyMap| - BOOT::|formulaFormat| BOOT::|boxWidth| BOOT::|sayMath| - BOOT::|domainZero| BOOT::|domainOne| VMLISP:COPY - VMLISP:DOWNCASE BOOT::|e04ucfSolve,fg| VMLISP:SHUT - BOOT::|unescapeStringsInForm| - BOOT::|executeInterpreterCommand| VMLISP:REROOT - BOOT::|parseAndInterpret| VMLISP:DIG2FIX - BOOT::|ncSetCurrentLine| BOOT::|pvarsOfPattern| - BOOT::|htEscapeString| BOOT::|e01safSolve,f| - BOOT::|e04ucfSolve,fe| BOOT::|e01befSolve,f| - BOOT::|e01bffSolve,g| VMLISP:LOG2 BOOT::|e01dafSolve,g| - BOOT::|e01dafSolve,f| VMLISP:SIZE VMLISP:EOFP - BOOT::|e01bffSolve,f| VMLISP:RSHUT BOOT::|e04ucfSolve,fd| - BOOT::|e01bhfSolve,f| BOOT::|objVal| BOOT::|getValue| - BOOT::|getMode| BOOT::|getUnname| VMLISP:DIGITP - BOOT::|bottomUp| BOOT::|mkAtreeNode| VMLISP:VEC2LIST - VMLISP:MAKE-VEC VMLISP:GCMSG BOOT::|retract| - BOOT::|getUnionOrRecordTags| BOOT::|e02dcfColdSolve,h| - BOOT::|e02ajfSolve,f| BOOT::|polyVarlist| - BOOT::|e02befColdSolve,f| BOOT::|removeQuote| - BOOT::|e02dcfColdSolve,g| BOOT::|e02dcfColdSolve,f| - BOOT::|isMapExpr| BOOT::|getTarget| - BOOT::|e02ddfColdSolve,f| BOOT::|isType| - BOOT::|bottomUpElt| BOOT::|e02adfSolve,f| - BOOT::|retractAtree| BOOT::|bottomUpPercent| - BOOT::|fetchOutput| BOOT::|e02aefSolve,f| - BOOT::|e02gafSolve,fb| BOOT::|bottomUpUseSubdomain| - BOOT::|getBasicObject| BOOT::|bottomUpCompile| - BOOT::|e02ddfSolve,h| BOOT::|e02ddfSolve,g| - BOOT::|e02bafSolve,g| BOOT::|e02bcfSolve,f| - BOOT::|getBasicMode| BOOT::|e02ddfSolve,f| BOOT::|unwrap| - BOOT::|isWrapped| BOOT::|e02bafSolve,f| BOOT::GETZEROVEC - BOOT::|containsPolynomial| - BOOT::|getModeOrFirstModeSetIfThere| BOOT::|e02ahfSolve,f| - BOOT::|e04ucfSolve,fc| BOOT::|wrapMapBodyWithCatch| - BOOT::|e02agfSolve,i| BOOT::|e02agfSolve,h| - BOOT::|e02bdfSolve,f| BOOT::|containsVariables| - BOOT::|e02bbfSolve,f| BOOT::|wrapped2Quote| - BOOT::|objCodeVal| BOOT::|objCodeMode| - BOOT::|e02akfSolve,f| BOOT::|asyUnTuple| - BOOT::|asyTypeUnitList| BOOT::|asyComma?| - BOOT::|interactiveModemapForm| BOOT::|isTaggedUnion| - BOOT::|asIsCategoryForm| BOOT::|opOf| BOOT::|e02agfSolve,g| - BOOT::|asySubstMapping| BOOT::|e02agfSolve,f| - BOOT::|asyTypeMapping| BOOT::|asyCATEGORY| - BOOT::|e02dafSolve,fp| BOOT::|asyShorten| - BOOT::|e02dafSolve,fmu| BOOT::|createAbbreviation| - BOOT::|astran| BOOT::|asMakeAlist| BOOT::|asyParents| - BOOT::|asyDocumentation| BOOT::|asyConstructorModemap| - BOOT::|asytran| BOOT::|asyPredTran| BOOT::|asyPredTran1| - BOOT::|as| BOOT::|asytranLiteral| BOOT::|asytranEnumItem| - BOOT::|constructor?| BOOT::|hackToRemoveAnd| - BOOT::|asyGetAbbrevFromComments| BOOT::|intern| - BOOT::|asyTypeJoinPartPred| BOOT::|zeroOneConversion| - BOOT::|asyArgs| BOOT::|asyArg| BOOT::|asyFindAttrs| - BOOT::|asyAncestors| BOOT::|asyAncestorList| - BOOT::|asyTypeJoinItem| BOOT::|isLowerCaseLetter| - BOOT::|abbreviation?| BOOT::|asAll| BOOT::|error| - BOOT::|asyTypeJoinPartIf| BOOT::|asyType| - BOOT::|asyTypeJoin| BOOT::|asyTypeJoinPartExport| - BOOT::|asyCattranOp| BOOT::|predicateBitRef| - BOOT::|asyMkpred| BOOT::|asyLooksLikeCatForm?| - BOOT::|asyCosigType| BOOT::|setVector12| - BOOT::|asMakeAlistForFunction| BOOT::|optFunctorPROGN| - BOOT::|getAttributesFromCATEGORY| BOOT::|worthlessCode| - BOOT::|mySort| BOOT::|optFunctorBody,CondClause| - BOOT::|mkDomainFormer| BOOT::|mkNiladics| BOOT::|optCall| - BOOT::|explodeIfs| BOOT::|folks| BOOT::|mkVector| - BOOT::|asyExtractDescription| BOOT::|asyCattran1| - BOOT::|simpCattran| BOOT::|asyCattran| BOOT::|asyCatItem| - BOOT::|asyExportAlist| BOOT::FOOBAR - BOOT::|bootAbsorbSEQsAndPROGNs| BOOT::|displayDatabase| - BOOT::|bootAbsorbSEQsAndPROGNs,flatten| BOOT::|bootTran| - BOOT::|asyConstructorArg| BOOT::|bootLabelsForGO| - BOOT::GP2COND BOOT::|bootPROGN| BOOT::|asyTypeMakePred| - BOOT::|bootSEQ| BOOT::|tryToRemoveSEQ| BOOT::|nakedEXIT?| - BOOT::|asyConstructorArgs| BOOT::|mergeCONDsWithEXITs| - BOOT::STREAM2UC BOOT::|asyTypeJoinStack| BOOT::|bootCOND| - BOOT::STRINGREST BOOT::|bootAND| BOOT::|boot2Lisp| - BOOT::|bootOR| BOOT::|asyTypeJoinPartWith| BOOT::|bootIF| - BOOT::|asyCosig| BOOT::|bootAND,flatten| - BOOT::|bootPushEXITintoCONDclause| BOOT::|asyIsCatForm| - BOOT::|bootOR,flatten| BOOT::|asCategoryParts,exportsOf| - BOOT::|removeEXITFromCOND| BOOT::|flattenCOND| BOOT::/FLAG - BOOT::|extractCONDClauses| BOOT::|hashable| - BOOT::|trimString| BOOT::|mergeableCOND| - BOOT::|knownEqualPred| BOOT::|removeEXITFromCOND?| - BOOT::CPSAY BOOT::|zeroOneConvert| BOOT::/EDIT - BOOT::|domainForm?| BOOT::|makeByteWordVec| - BOOT::DECIMAL-LENGTH BOOT::|unabbrevAndLoad| BOOT::READLISP - BOOT::|abbQuery| BOOT::SPAD-EVAL BOOT::/TRANSNBOOT - BOOT::SPAD-MDTR-2 BOOT::SPAD-MDTR-1 BOOT::/TRANSPAD - BOOT::|setAutoLoadProperty| BOOT::/TRANSMETA - BOOT::|getConstructorUnabbreviation| BOOT::|getLisplibName| - BOOT::OPTIMIZE&PRINT - BOOT::|getPartialConstructorModemapSig| BOOT::UNCONS - BOOT::|maximalSuperType| BOOT::|getImmediateSuperDomain| - BOOT::|augmentLowerCaseConTable| BOOT::|isNameOfType| - BOOT::|objMode| BOOT::|isDomainValuedVariable| - BOOT::|packageForm?| BOOT::|sayMSG2File| BOOT::|concatList| - BOOT::|mkMessage| BOOT::|clearCache| BOOT::|IdentityError| - BOOT::/TRANSBOOT BOOT::|process| BOOT::|mathprint| - BOOT::ISLOCALOP-1 BOOT::|pushSatOutput| BOOT::|fracpart| - BOOT::|negintp| BOOT::|intpart| BOOT::|optRECORDELT| - BOOT::|optIF2COND| BOOT::C-TO-R BOOT::C-TO-S BOOT::S-TO-C - BOOT::CGAMMA BOOT::RGAMMA BOOT::CLNGAMMA BOOT::RLNGAMMA - BOOT::|getDomainOps| BOOT::|showGoGet| - BOOT::|showAttributes| BOOT::|showPredicates| - BOOT::|showSummary| BOOT::|getExtensionsOfDomain| - BOOT::|getDomainSeteltForm| BOOT::|getCategoriesOfDomain| - BOOT::|getDomainExtensionsOfDomain| BOOT::|bnot| - BOOT::|notDnf| BOOT::|b2dnf| BOOT::|ordList| BOOT::|bor| - BOOT::|band| BOOT::|bassert| BOOT::|notCoaf| BOOT::|list3| - BOOT::|list2| BOOT::|list1| BOOT::|dnf2pf| BOOT::|be| - BOOT::|reduceDnf| BOOT::|bassertNot| BOOT::|prove| - BOOT::|testPredList| BOOT::|nodeCount| - BOOT::|mkCircularAlist| BOOT::|clearSlam,LAM| - BOOT::|getCacheCount| BOOT::|clearLocalModemaps| - BOOT::|hashCount| BOOT::|parseAndEvalToHypertex| - BOOT::|oldParseAndInterpret| BOOT::|parseAndInterpToString| - BOOT::|parseAndEvalToStringEqNum| BOOT::|setHistory| - BOOT::|setExposeAddGroup| BOOT::|setFortDir| - BOOT::|validateOutputDirectory| BOOT::|setOutputLibrary| - BOOT::|setFortPers| BOOT::|setExposeDropConstr| - BOOT::|setExposeDropGroup| BOOT::|setExposeDrop| - BOOT::|setFortTmpDir| BOOT::|setExposeAdd| - BOOT::|setExpose| BOOT::|setInputLibrary| - BOOT::|setAsharpArgs| BOOT::|countCache| BOOT::|cgamma| - BOOT::|rgamma| BOOT::|clngammacase3| BOOT::|cgammaBernsum| - BOOT::|cgammaAdjust| BOOT::|lnrgammaRatapprox| - BOOT::|phiRatapprox| BOOT::|lnrgamma| - BOOT::|gammaRatapprox| BOOT::|gammaRatkernel| - BOOT::|gammaStirling| BOOT::|PsiIntpart| - BOOT::|isFilterDelimiter?| - BOOT::|mkDetailedGrepPattern,simp| BOOT::|cgammat| - BOOT::|isDefaultOpAtt| BOOT::|replaceTicksBySpaces| - BOOT::COT BOOT::|conform2OutputForm| BOOT::|lncgamma| - BOOT::|dbGetName| BOOT::|pfTupleList| BOOT::|pfWIfElse| - BOOT::|pfWIfThen| BOOT::|mkGrepPattern1,addWilds| - BOOT::|pfWIfCond| BOOT::|pfWIf?| BOOT::|mkGrepPattern1,g| - BOOT::|organizeByName| BOOT::|pfAssignLhsItems| - BOOT::|pfRetractToType| BOOT::|getTempPath| BOOT::|pfSexpr| - BOOT::|looksLikeDomainForm| BOOT::|pfRetractToExpr| - BOOT::|pfRetractTo?| BOOT::|pfExpression?| - BOOT::|genSearchUniqueCount| - BOOT::|pf0FlattenSyntacticTuple| BOOT::|pfSexpr,strip| - BOOT::|pmPreparse| BOOT::|dbUnpatchLines| - BOOT::|evaluateLines| BOOT::|verifyRecordFile| - BOOT::|sayDocMessage| BOOT::|recordAndPrintTest,fn| - BOOT::|pmParseFromString| - BOOT::|conLowerCaseConTranTryHarder| BOOT::|fnameExists?| - BOOT::|htTrimAtBackSlash| BOOT::|setExposeAddConstr| - BOOT::|dbBasicConstructor?| BOOT::|lfnegcomment| - BOOT::|lfcomment| BOOT::|bcStarConform| BOOT::|lfstring| - BOOT::|bcStar| BOOT::|simpBool| BOOT::|scanKeyTr| - BOOT::|extractHasArgs,find| BOOT::|lfkey| - BOOT::|scanPossFloat| BOOT::|scanCloser?| - BOOT::|bcStarSpace| BOOT::|keyword| - BOOT::|loadLibIfNotLoaded| BOOT::|lineoftoks| - BOOT::|lisp2HT| BOOT::|getCType| BOOT::|lisp2HT,fn| - BOOT::|conform2HtString| BOOT::|nextline| - BOOT::|unMkEvalable| BOOT::|int2Bool| BOOT::|keyword?| - BOOT::|htSayList| BOOT::|scanW| BOOT::|isLoaded?| - BOOT::|mkQuote| BOOT::|lfinteger| BOOT::|mkQuote,addQuote| - BOOT::|functionAndJacobian| BOOT::|lferror| - BOOT::|scanWord| BOOT::|scanTransform| - BOOT::|htPred2English,fnAttr| BOOT::|dbConname| - BOOT::|digit?| BOOT::|addSpaces| BOOT::|dbKindString| - BOOT::|lfspaces| BOOT::|stripUnionTags| BOOT::|lfid| - BOOT::|mkPredList| BOOT::|spad2lisp| - BOOT::|orderUnionEntries| BOOT::|punctuation?| - BOOT::|Record0| BOOT::|makeFort,untangle| - BOOT::|makeFort,untangle2| BOOT::|makeOutputAsFortran| - BOOT::|rdigit?| BOOT::|vec2Lists| BOOT::|npMoveTo| - BOOT::|complexRows| BOOT::|makeLispList| - BOOT::|pfSourceStok| BOOT::|vec2Lists1| - BOOT::|multiToUnivariate| BOOT::|spadTypeTTT| - BOOT::|makeUnion| BOOT::|stripNil| - BOOT::|parseAndEvalToString| - BOOT::|parseAndEvalToStringForHypertex| BOOT::|XDRFun| - BOOT::|pair2list| BOOT::|pfStringConstString| - BOOT::|pfExportDef| BOOT::|prefix2Infix| - BOOT::|pfDefinitionSequenceArgs| BOOT::|lispType| - BOOT::|pfComDefinitionDef| BOOT::|checkForBoolean| - BOOT::|npTrapForm| BOOT::|pfTransformArg| - BOOT::|vectorOfFunctions| BOOT::|pfTaggedToTyped1| - BOOT::|pfFlattenApp| BOOT::|pfTaggedToTyped| - BOOT::|pfCollectVariable1| - BOOT::|InvestigateConditions,pessimise| BOOT::|pfCollect1?| - BOOT::|d01gafSolve,f| BOOT::|pfComDefinitionDoc| - BOOT::|PrepareConditional| BOOT::|pfLoopIterators| - BOOT::|TryGDC| BOOT::|d01fcfSolve,f| BOOT::|compCategories| - BOOT::|pfHidePart| BOOT::|makeMissingFunctionEntry,tran| - BOOT::|PacPrint| BOOT::|keyItem| BOOT::|pfHide?| - BOOT::|pfDocumentText| BOOT::|pfDocument?| - BOOT::|e02dafSolve,fxy| BOOT::|pfLambdaArgs| - BOOT::|ConstantCreator| BOOT::|pfDefinitionLhsItems| - BOOT::|pf0WithWithin| BOOT::|d02bbfSolve,fb| - BOOT::|pfWithWithin| BOOT::|d02bbfSolve,fa| - BOOT::|pf0WithBase| BOOT::|d02gbfSolve,fe| - BOOT::|pfWithBase| BOOT::|pfWithWithon| BOOT::|pfNot| - BOOT::|d02kefSolve,fc| BOOT::|pfId| BOOT::|pfTupleParts| - BOOT::|d02kefSolve,fb| BOOT::|pfWhereContext| - BOOT::|InvestigateConditions| BOOT::|pfCheckArg| - BOOT::|InvestigateConditions,reshape| - BOOT::|d02kefSolve,fa| BOOT::|pfCheckId| - BOOT::|getPossibleViews| BOOT::|pfQualTypeQual| - BOOT::|ICformat| BOOT::|pfTupleListOf| - BOOT::|InvestigateConditions,mkNilT| BOOT::|pfQualTypeType| - BOOT::|pfQualType?| BOOT::|getViewsConditions| - BOOT::|pfDWhereExpr| BOOT::|ICformat,Hasreduce| - BOOT::|pfForinLhs| BOOT::|ICformat,ORreduce| - BOOT::|d02gbfSolve,fi| BOOT::|d02gbfSolve,fh| - BOOT::|pfDWhereContext| BOOT::|CategoriesFromGDC| - BOOT::|pfSymbolVariable?| BOOT::|d02rafSolve,fc| - BOOT::|pfMLambdaArgs| BOOT::|optFunctorBodyRequote| - BOOT::|d02gafSolve,ff| BOOT::|pfInlineItems| - BOOT::|d02rafSolve,fb| BOOT::|pfSemiColonBody| - BOOT::|d02rafSolve,fa| BOOT::|pfSemiColon?| - BOOT::|optFunctorBodyQuotable| BOOT::|d02gafSolve,fd| - BOOT::|pfInline| BOOT::|pf0AddBase| BOOT::|pfAddBase| - BOOT::|d02ejfSolve,fb| BOOT::|pfSemiColon| - BOOT::|pfAddAddon| BOOT::|d02ejfSolve,fa| - BOOT::|pfAddAddin| BOOT::|d02bhfSolve,fb| - BOOT::|pf0ImportItems| BOOT::|d02bhfSolve,fa| - BOOT::|pfImportItems| BOOT::|pfInline?| - BOOT::|pfReturnFrom| BOOT::|pfImport| - BOOT::|d02gafSolve,fb| BOOT::|pfListOf?| - BOOT::|pfFreeItems| BOOT::|pf0TLambdaArgs| - BOOT::|d02gafSolve,fa| BOOT::|pfTLambdaArgs| - BOOT::|pfTLambdaBody| BOOT::|pfExitNoCond| - BOOT::|pf0WrongRubble| BOOT::|pfWrongRubble| - BOOT::|pfTLambdaRets| BOOT::|pfWrongWhy| - BOOT::|pfIterateFrom| BOOT::|pfLocalItems| - BOOT::|pfAttributeExpr| BOOT::|d02cjfSolve,fb| - BOOT::|pfAttribute?| BOOT::|pfLoop| BOOT::|d02cjfSolve,fa| - BOOT::|pfDo| BOOT::|pfWDeclareDoc| BOOT::|pfSecond| - BOOT::|pfWDeclareSignature| BOOT::|pfWDeclare?| - BOOT::|pfCheckInfop| BOOT::|d03edfSolve,fd| - BOOT::|pf0CollectIterators| BOOT::|pfExport?| - BOOT::|d03edfSolve,fc| BOOT::|pfDeclPart?| - BOOT::|d03edfSolve,fa| IDENTITY BOOT::|pfDWhere?| - BOOT::|pfImport?| BOOT::|pfTyping?| BOOT::|pfSuchthat| - BOOT::|pfComDefinition?| BOOT::|pfTLambda?| BOOT::|pfWhile| - BOOT::|pfAdd?| BOOT::|pf0ExportItems| BOOT::|pfExportItems| - BOOT::|pfExpr?| BOOT::|pfWith?| BOOT::|e01sefSolve,f| - BOOT::|pf0TypingItems| BOOT::|pfTypingItems| - BOOT::|pfGetLineObject| BOOT::|lnFileName?| - BOOT::|e01bgfSolve,g| BOOT::|e01bgfSolve,f| - BOOT::|pfNopos?| BOOT::|lnExtraBlanks| - BOOT::|pfPlaceOfOrigin| BOOT::|ravel| - BOOT::|poPlaceOfOrigin| BOOT::|e01bafSolve,f| - BOOT::|pfFileName?| BOOT::|poFileName?| - BOOT::|parseAndEval| BOOT::|getDomainHash| BOOT::|aplTran1| - BOOT::|hasAplExtension| BOOT::|htpDomainConditions| - BOOT::|aplTranList| BOOT::|postDefArgs| - BOOT::|postTranScripts| BOOT::|getHtMacroItem| - BOOT::|postTranScripts,fn| BOOT::|unTuple| - BOOT::|isPackageType| BOOT::|buttonNames| - BOOT::|postcheckTarget| BOOT::|postcheck| - BOOT::|dbNonEmptyPattern| BOOT::|postBlockItemList| - VMLISP:|last| BOOT::|postBlockItem| BOOT::|postQuote| - BOOT::|postSequence| BOOT::|postTranList| - BOOT::|checkWarning| VMLISP:HASHTABLE-CLASS - BOOT::|downlinkSaturn| BOOT::|decodeScripts,fn| - BOOT::|mkUnixPattern| BOOT::|tuple2List| - BOOT::|postCapsule| BOOT::|patternCheck| BOOT::|postElt| - BOOT::|postSEGMENT| BOOT::|e04nafSolve,ff| - BOOT::|postIteratorList| BOOT::|npEqPeek| BOOT::|postForm| - BOOT::|htAllOrNum| BOOT::|postOp| BOOT::|stringize| - VMLISP:LISTOFFREES BOOT::|postTuple| BOOT::|postExit| - BOOT::|parseWord| BOOT::|postMapping| VMLISP:GENSYMP - BOOT::|postMDef| BOOT::|pfAttribute| BOOT::|postDef| - BOOT::|npRestore| BOOT::|postCategory| BOOT::|aplTran| - BOOT::|containsBang| BOOT::|htMakePathKey| BOOT::|postJoin| - BOOT::|npWConditional| BOOT::|postTransformCheck| - BOOT::|npBraced| VMLISP:PAPPP - BOOT::|chkAllNonNegativeInteger| BOOT::|postIf| - BOOT::|chkNonNegativeInteger| BOOT::|postPretend| - BOOT::|pfId?| BOOT::|postAtSign| BOOT::|npBracketed| - BOOT::|postColon| BOOT::|chkDirectory| - BOOT::|postColonColon| BOOT::|postWhere| - BOOT::|npZeroOrMore| BOOT::|postSemiColon| - BOOT::|postBlock| BOOT::|pfParts| BOOT::|deepestExpression| - BOOT::|translateYesNo2TrueFalse| BOOT::|postComma| - BOOT::|pfEnSequence| BOOT::|comma2Tuple| - BOOT::|npParenthesized| BOOT::|chkOutputFileName| - BOOT::|postReduce| BOOT::|chkPosInteger| BOOT::|postAdd| - BOOT::|pfUnSequence| BOOT::|postTupleCollect| - BOOT::|postCollect| BOOT::|postRepeat| BOOT::|postIn| - BOOT::|htShowCount| BOOT::|satisfiesUserLevel| - BOOT::|postin| BOOT::|postQUOTE| BOOT::|pfListOf| - BOOT::|postScripts| BOOT::|translateTrueFalse2YesNo| - BOOT::|postWith| BOOT::|e02dffSolve,fp| VMLISP:CHARP - BOOT::|chkNameList| BOOT::|isSymbol| BOOT::INFIXTOK - BOOT::|npQualified| BOOT::SKIP-TO-ENDIF - BOOT::|npConditional| BOOT::|stackMessageIfNone| - BOOT::PREPARSEREADLINE BOOT::|npElse| - BOOT::|translateYesNoToTrueFalse| BOOT::|npMissing| - BOOT::PREPARSEREADLINE1 BOOT::|npDDInfKey| VMLISP:RPACKFILE - BOOT::SKIP-IFBLOCK BOOT::|tokPart| BOOT::|npInfKey| - VMLISP:RECOMPILE-LIB-FILE-IF-NECESSARY BOOT::|npWith| - BOOT::|optimizeFunctionDef| BOOT::PREPARSE-ECHO - BOOT::|npCompMissing| VMLISP::LIBSTREAM-DIRNAME - BOOT::ATENDOFUNIT BOOT::PARSEPRINT BOOT::|npAdd| - BOOT::PREPARSE1 BOOT::|e02defSolve,fp| - BOOT::|htpRadioButtonAlist| BOOT::MONITOR-DATA-COUNT - BOOT::MONITOR-DATA-NAME BOOT::|htpDomainPvarSubstList| - BOOT::MONITOR-DATA-SOURCEFILE BOOT::|profileTran| - BOOT::MONITOR-DELETE BOOT::|pfSequenceToList| - BOOT::MONITOR-DATA-MONITORP BOOT::|pfSequenceArgs| - BOOT::|renamePatternVariables| BOOT::|pfSequence?| - BOOT:|LispEval| BOOT::|pfNovalueExpr| - BOOT::MONITOR-EXPOSEDP BOOT::|pfNovalue?| - BOOT::|htpDomainVariableAlist| BOOT::|pfNotArg| - BOOT::MONITOR-APROPOS BOOT::|pfNot?| BOOT::MONITOR-DATA-P - BOOT::|pfOrRight| BOOT::|pfOrLeft| BOOT::MONITOR-LIBNAME - BOOT::|pfOr?| BOOT::MONITOR-FILE BOOT::|pfAndRight| - BOOT::|pfAndLeft| BOOT::|pfAnd?| BOOT::MONITOR-SPADFILE - BOOT::|getDomainsInScope| BOOT::|pfWrong?| - BOOT::MONITOR-PARSE BOOT::|pf0LocalItems| - BOOT::MONITOR-DECR BOOT::|pfLocal?| BOOT::|pfNovalue| - BOOT::|pf0FreeItems| BOOT::|npItem1| BOOT::|pfFree?| - BOOT::|pfRestrictType| BOOT::MONITOR-INCR - BOOT::|pfRestrictExpr| BOOT::|npLetQualified| - BOOT::|isConstructorForm| BOOT::|pfRestrict?| - BOOT::|library| BOOT::MONITOR-NRLIB BOOT::|pfDefinition?| - BOOT::|unknownTypeError| BOOT::|pfAssignRhs| - BOOT::|pf0AssignLhsItems| BOOT::|pfAssign?| BOOT::|quotify| - BOOT::|pfDoBody| BOOT::|reportHashCacheStats| - BOOT::MONITOR-DIRNAME BOOT::|pfDo?| - BOOT::|mkHashCountAlist| BOOT::|pfSuchthatCond| - BOOT::|displayCacheFrequency| BOOT::|pfSuchthat?| - BOOT::MONITOR-CHECKPOINT BOOT::|pfWhileCond| - BOOT::|pfWhile?| BOOT::|pfForinWhole| - BOOT::|outputDomainConstructor| BOOT::|e02dffSolve,fmu| - BOOT::|pf0ForinLhs| BOOT::|typeTimePrin| - BOOT::|pfCheckMacroOut| BOOT::|isSomeDomainVariable| - BOOT::|pfForin?| BOOT::|displayHashtable| - BOOT::|pfCollect?| BOOT::|removeZeroOne| BOOT::|npEncAp| - BOOT::|pf0LoopIterators| BOOT::|addBlanks| - BOOT::|compHasFormat| BOOT::|loopIters2Sex| - BOOT::|noBlankBeforeP| BOOT::|pfLoop?| - BOOT::|stopTimingProcess| BOOT::|noBlankAfterP| - BOOT::|?comp| BOOT::|pfExitExpr| BOOT::|pfExitCond| - BOOT::|compileQuietly| BOOT::|sayLongOperation| - BOOT::|isAlmostSimple,setAssignment| BOOT::|pfExit?| - BOOT::|compileInteractive| BOOT::|say2PerLineThatFit| - BOOT::?COMP BOOT::|npBracked| BOOT::|pfFromdomDomain| - BOOT::|startTimingProcess| BOOT::|prEnv| - BOOT::|pfFromdomWhat| BOOT::|operationLink| BOOT::|opTran| - BOOT::|pfFromdom?| BOOT::|hasType,fn| BOOT::|pfPretendType| - BOOT::|clearCategoryCache| BOOT::|pfTuple| - BOOT::|pfPretendExpr| BOOT::|clearConstructorCache| - BOOT::|qModemap| BOOT::|pfPretend?| - BOOT::|splitListSayBrightly| BOOT::|formatModemap| - BOOT::|pfCoercetoType| BOOT::|printEnv| - BOOT::|pfCoercetoExpr| BOOT::|tabber| BOOT::|pfCoerceto?| - BOOT::|decExitLevel| BOOT::|pfTaggedExpr| - BOOT::|splitSayBrightly| BOOT::|pfTaggedTag| - BOOT::|brightPrintRightJustify| BOOT::|pfTagged?| - BOOT::|pfIfElse| BOOT::|splitSayBrightlyArgument| - BOOT::DATABASE-ABBREVIATION BOOT::|pfIfThen| - BOOT::|mkDomainConstructor| BOOT::|pfIfCond| - BOOT::|brightPrint1| BOOT::SET-FILE-GETTER BOOT::|mkList| - BOOT::|pfIf?| BOOT::|brightPrint| BOOT::|pf0TupleParts| - BOOT::|pfTuple?| BOOT::DATABASE-SOURCEFILE - BOOT::|minimalise| BOOT::|minimalise,min| - BOOT::|pfLiteral?| BOOT::|mkDevaluate| - BOOT::|minimalise,HashCheck| BOOT::|pfSymbolSymbol| - BOOT::|numberOfEmptySlots| BOOT::|pfSymbol?| - BOOT::|sayBrightlyLength1| BOOT::|hasOptArgs?| - BOOT::|npFromdom1| BOOT::|pfSuchThat2Sex| - BOOT::|CDRwithIncrement| BOOT::|npPush| - BOOT::|segmentedMsgPreprocess| BOOT::|pfOp2Sex| - BOOT::SHOWDATABASE BOOT::|pmDontQuote?| BOOT::|initCache| - BOOT::|blankIndicator| BOOT::|pfDefinitionRhs| - BOOT::|npEqKey| BOOT::|pf0DefinitionLhsItems| - BOOT::|pfApplicationArg| BOOT::SQUEEZE - BOOT::|rulePredicateTran| BOOT::|pfRuleRhs| BOOT::UNSQUEEZE - BOOT::|npDotted| BOOT::|pfRuleLhsItems| - BOOT::|constructor2ConstructorForm| BOOT::|npAngleBared| - BOOT::|pfCollectBody| BOOT::DATABASE-SPARE - BOOT::|pfCollectIterators| BOOT::|remHashEntriesWith0Count| - BOOT::|float2Sex| BOOT::DATABASE-DEFAULTDOMAIN - BOOT::|npListing| BOOT::|pfLiteralString| - BOOT::DATABASE-NILADIC BOOT::|pfLeafToken| - BOOT::DATABASE-CONSTRUCTORCATEGORY BOOT::|pfLiteralClass| - BOOT::DATABASE-OBJECT BOOT::DATABASE-MODEMAPS - BOOT::DATABASE-OPERATIONALIST BOOT::DATABASE-DEPENDENTS - BOOT::DATABASE-USERS BOOT::DATABASE-PARENTS BOOT::|tokPosn| - BOOT::|pileColumn| BOOT::|underDomainOf| - BOOT::DATABASE-PREDICATES BOOT::|underDomainOf;| - BOOT::|pileCforest| BOOT::DATABASE-ATTRIBUTES - BOOT::|enPile| BOOT::|separatePiles| - BOOT::DATABASE-DOCUMENTATION BOOT::|pilePlusComments| - BOOT::|pilePlusComment| BOOT::|insertpile| - BOOT::|lastTokPosn| BOOT::|firstTokPosn| - BOOT::|pileComment| BOOT::|isValidType;| - BOOT::|lnGlobalNum| BOOT::|lnLocalNum| - BOOT::|pfSourcePositionlist| BOOT::|isPartialMode| - BOOT::|pfSourcePositions| - BOOT::|makeOldAxiomDispatchDomain| BOOT::|lnString| - BOOT::DATABASE-ANCESTORS BOOT::|poNoPosition?| - BOOT::|poImmediate?| BOOT::|poIsPos?| BOOT::|hashString| - BOOT::DATABASE-CONSTRUCTOR BOOT::|pfPosn| - BOOT::|isLegitimateRecordOrTaggedUnion| - BOOT::|lnImmediate?| BOOT::|listOfDuplicates| - BOOT::|pfPosImmediate?| BOOT::|isPolynomialMode| - BOOT::|pfSourceToken| BOOT::|equiType| BOOT::|pfFirst| - BOOT::|getUnderModeOf| FOAM::PROCESS-IMPORT-ENTRY - BOOT::|deconstructT| BOOT::|attribute?| BOOT::TRARGPRINT - BOOT::|makeLazyOldAxiomDispatchDomain| BOOT::|eqType| - BOOT::DATABASE-P BOOT::LINE-ADVANCE-CHAR - BOOT::DATABASE-COSIG BOOT::LINE-AT-END-P BOOT::TRBLANKS - BOOT::MAKE-STRING-ADJUSTABLE BOOT::|sayMessage| - BOOT::|dropPrefix| BOOT::TRMETA1 BOOT::|mkDatabasePred| - BOOT::TRY-GET-TOKEN BOOT::TRMETA BOOT::|namestring| - BOOT::|isFreeFunctionFromMmCond| BOOT::|isSharpVarWithNum| - BOOT::|isFreeFunctionFromMm| - BOOT::|mkAlistOfExplicitCategoryOps| BOOT::LINE-P - BOOT::|mkAlistOfExplicitCategoryOps,atomizeOp| - BOOT::|flattenSignatureList| BOOT::|collectAndDeleteAssoc| - BOOT::|checkSplitBrace| BOOT::|getFirstArgTypeFromMm| - BOOT::|checkSplitPunctuation| BOOT::|checkSplitOn| - BOOT::|checkSplitBackslash| BOOT::STACK-POP - BOOT::|checkAlphabetic| BOOT::|isDomainSubst| - BOOT::UNDERSCORE BOOT::|collectComBlock| - BOOT::|getDomainFromMm| BOOT::/MDEF BOOT::STACK-TOP - BOOT::|formal2Pattern| BOOT::|finalizeDocumentation,hn| - BOOT::STACK-P BOOT::LINE-NEXT-CHAR BOOT::REDUCTION-RULE - BOOT::|checkExtractItemList| - BOOT::|recordHeaderDocumentation| BOOT::|checkIeEgfun| - BOOT::|appendOver| BOOT::|rebuild| BOOT::|checkInteger| - BOOT::|spool| BOOT::|setOutputCharacters| - BOOT::/VERSIONCHECK BOOT::INTERP-MAKE-DIRECTORY - BOOT::CACHEKEYEDMSG BOOT::XDR-STREAM-HANDLE - BOOT::|normalizeArgFileName| BOOT::|checkTrim,trim| - BOOT::XDR-STREAM-P BOOT::|checkDocError| BOOT::|bootFind| - BOOT::|checkTrim,wherePP| BOOT::|checkDecorateForHt| - BOOT::XDR-STREAM-NAME BOOT::|checkRecordHash| - BOOT::|checkIsValidType| BOOT::|normalizeTimeAndStringify| - BOOT::SETLETPRINTFLAG BOOT::|checkGetParse| - BOOT::|checkGetStringBeforeRightBrace| - BOOT::|checkGetLispFunctionName| BOOT::MAKE-DIRECTORY - BOOT::|checkLookForRightBrace| - BOOT::|checkLookForLeftBrace| BOOT::|checkFixCommonProblem| - BOOT::|checkArguments| BOOT::SHAREDITEMS BOOT::|checkTexht| - BOOT::|isVowel| BOOT::|getOfCategoryArgument| - BOOT::|checkAddPeriod| BOOT::|newMKINFILENAM| - BOOT::|getFunctionSourceFile1| BOOT::|checkDecorate| - BOOT::|pathname?| BOOT::|hasNoVowels| BOOT::|checkBalance| - BOOT::|checkSayBracket| BOOT::|pfSequence2Sex| - BOOT::|checkBeginEnd| BOOT::|pf2Sex1| BOOT::|checkIeEg| - BOOT::|pfSequence2Sex0| BOOT::|checkDocError1| - BOOT::|ruleLhsTran| BOOT::|patternVarsOf| - BOOT::|checkAddMacros| BOOT::|pfLambdaTran| - BOOT::|pfLambdaBody| BOOT::|checkSplit2Words| - BOOT::|pfLambdaRets| BOOT::|checkAddSpaces| - BOOT::|pfTypedType| BOOT::|newString2Words| - BOOT::|pfCollectArgTran| BOOT::|checkGetArgs| - BOOT::|pfTyped?| BOOT::|pfRhsRule2Sex| - BOOT::|pfLhsRule2Sex| BOOT::|checkDocMessage| - BOOT::|checkRemoveComments| BOOT::|pfRule2Sex| - BOOT::|checkTrimCommented| BOOT::|pfLambda2Sex| - BOOT::|pfDefinition2Sex| BOOT::|leftTrim| - BOOT::|pfCollect2Sex| BOOT::|checkGetMargin| - BOOT::|pfApplication2Sex| BOOT::|whoOwns| - BOOT::|pfLiteral2Sex| BOOT::|pfWhereExpr| - BOOT::|pf0WhereContext| BOOT::|pfIterate?| - BOOT::|pfReturnExpr| BOOT::|pfReturn?| BOOT::|setOutStream| - BOOT::|pfBreakFrom| BOOT::|pfBreak?| BOOT::|pfRule?| - BOOT::DATABASE-CONSTRUCTORMODEMAP BOOT::|%key| BOOT::|ppos| - BOOT::|porigin| BOOT::|pfLinePosn| BOOT::|pfCharPosn| - BOOT::|pfImmediate?| BOOT::|pfNoPosition?| BOOT::|%pos| - BOOT::|processPackage,setPackageCode| BOOT::|%fname| - BOOT::|pfname| BOOT::|%origin| BOOT::|mkRepititionAssoc| - BOOT::|%id| BOOT::|pkey| BOOT::|getCaps| - BOOT::|constructorCategory| BOOT::|evalDomain| - BOOT::|parseAtom| BOOT::|systemErrorHere| - BOOT::|coerceMap2E| BOOT::|parseConstruct| - BOOT::|parseTran,g| BOOT::|parseWhere| BOOT::|parseVCONS| - BOOT::|parseSeq| BOOT::|transSeq| BOOT::|postError| - BOOT::|parseSegment| BOOT::|parseReturn| - BOOT::|parsePretend| BOOT::|parseType| BOOT::|RecordInner| - BOOT::|parseTypeEvaluate| BOOT::|isRecord| - BOOT::|parseMDEF| BOOT::|parseLETD| BOOT::|parseLET| - BOOT::|transIs| BOOT::|CatEval| BOOT::|transUnCons| - BOOT::|parseLeave| BOOT::|mkCategory,Prepare| - BOOT::|parseJoin| BOOT::|parseJoin,fn| BOOT::|parseIsnt| - BOOT::|parseBigelt| BOOT::|parseIs| - BOOT::|DropImplementations| BOOT::|parseInBy| - BOOT::|parseIn| BOOT::|FindFundAncs| BOOT::|parseHas| - BOOT::|parseHas,mkand| BOOT::|TruthP| BOOT::|parseHas,fn| - BOOT::|parseExit| BOOT::|isCategory| BOOT::|parseDEF| - BOOT::|setDefOp| BOOT::|mkCategory,Prepare2| - BOOT::|transIs1| BOOT::|isListConstructor| - BOOT::|parseCategory| BOOT::|parseDropAssertions| - BOOT::|parseAtSign| BOOT::|parseHasRhs| BOOT::|parseCoerce| - BOOT::|getCategoryExtensionAlist0| BOOT::|parseColon| - BOOT::|getCategoryExtensionAlist| BOOT::|sayMSG| - BOOT::|parseDollarGreaterThan| BOOT::|squeeze1| - BOOT::|squeezeList| BOOT::|parseGreaterThan| - BOOT::|categoryParts,exportsOf| - BOOT::|makeSimplePredicateOrNil| BOOT::|simpHasPred,eval| - BOOT::|simpHasPred,simp| BOOT::|specialModeTran| - BOOT::|compressHashTable| BOOT::|simpOrUnion| - BOOT::|clearCategoryTable| BOOT::|transCategoryItem| - BOOT::|parseCases| BOOT::TOKEN-PRINT BOOT::|getConstrCat| - BOOT::LINE-CURRENT-SEGMENT - BOOT::|mkCategoryExtensionAlistBasic| BOOT::STACK-CLEAR - BOOT::|macrop| BOOT::|showCategoryTable| - BOOT::|clearTempCategoryTable| BOOT::TOKEN-P - BOOT::|addToCategoryTable| - BOOT::|simpHasPred,simpDevaluate| - BOOT::|mkCategoryExtensionAlist| - BOOT::|updateCategoryTableForCategory| - BOOT::|isFormalArgumentList| BOOT::|defaultingFunction| - BOOT::|getOperationAlistFromLisplib| - BOOT::|getConstructorAbbreviation| - BOOT::|predicateBitIndex| BOOT::|encodeCatform| - BOOT::|evalableConstructor2HtString,unquote| - BOOT::|orderByContainment| BOOT::|stripOutNonDollarPreds| - BOOT::|isHasDollarPred| BOOT::|transHasCode| - BOOT::|removeAttributePredicates| BOOT::|getCatAncestors| - BOOT::|makeCompactDirect1,fn| BOOT::|depthAssoc| - BOOT::|depthAssocList| BOOT::|fromHeading| - BOOT::|htAddHeading| BOOT::|infovec| BOOT::|dcData1| - BOOT::|dbDoesOneOpHaveParameters?| BOOT::|ppTemplate| - BOOT::|dbOuttran| BOOT::|bitsOf| BOOT::|mathform2HtString| - BOOT::|conname2StringList| BOOT::|dcData| - BOOT::|predicateBitIndexRemop| BOOT::|form2StringList| - BOOT::|dbConform| BOOT::|dbMapping2StringList| - BOOT::|htTab| BOOT::|orderBySubsumption| BOOT::|dcCats| - BOOT::|dcCats1| BOOT::|getLookupFun| - BOOT::|listOfCategoryEntries| BOOT::|niladicHack| - BOOT::|dbGatherDataImplementation,fn| BOOT::|NRTcatCompare| - BOOT::|dbGatherDataImplementation,gn| BOOT::|template| - BOOT::|dcAtts| BOOT::|dcSlots| BOOT::|dcOpTable| - BOOT::|getConstructorArgs| BOOT::|dbNewConname| - BOOT::|escapeString| BOOT::|nodeSize| BOOT::|fortexp0| - BOOT::|vectorSize| BOOT::|myLastAtom| - BOOT::|isDefaultPackageForm?| BOOT::|numberOfNodes| - BOOT::|dcOps| BOOT::|removeAttributePredicates,fn| - BOOT::|removeAttributePredicates,fnl| - BOOT::DATABASE-CONSTRUCTORFORM BOOT::|makeCompactDirect| - BOOT::|htSayTuple| BOOT::|dcPreds| BOOT::|htSayArgument| - BOOT::|makeDomainTemplate| BOOT::|hashTable2Alist| - BOOT::|stuffDomainSlots| BOOT::|getExportCategory| - BOOT::|koCatOps1| BOOT::|simplifyAttributeAlist| - BOOT::|hasPatternVar| BOOT::|dcAll| - BOOT::|findSubstitutionOrder?| BOOT::|isInstantiated| - BOOT::|modemap2SigConds| BOOT::|getSubstCandidates| - BOOT::|htSayExplicitExports| - BOOT::|fortFormatCharacterTypes| BOOT::|opPageFastPath| - BOOT::|fortFormatCharacterTypes,mkParameterList2| - BOOT::|exp2FortOptimizeCS1,popCsStacks| - BOOT::|kFormatSlotDomain,fn| - BOOT::|fortFormatTypes,unravel| BOOT::|formatSlotDomain| - BOOT::|getSubstSignature| BOOT::|getfortexp1| - BOOT::|fortran2Lines1| BOOT::|koOps,trim| - BOOT::|isPatternVar| BOOT::|dispfortexp1| - BOOT::|displayBreakIntoAnds| VMLISP::LIBRARY-FILE - VMLISP::GET-DIRECTORY-LIST VMLISP::PROBE-NAME - VMLISP::SPAD-FIXED-ARG VMLISP::LIBSTREAM-INDEXSTREAM - VMLISP::LIBSTREAM-INDEXTABLE VMLISP::LIBSTREAM-MODE - VMLISP::GETINDEXTABLE VMLISP::GET-INDEX-TABLE-FROM-STREAM - VMLISP::LIBSTREAM-P BOOT::|NRTassocIndexAdd| - BOOT::|optDeltaEntry,quoteSelector| BOOT::|NRToptimizeHas| - BOOT::|listOfBoundVars| BOOT::|slot1Filter,fn| - BOOT::|reverseCondlist| BOOT::|c05pbfSolve,fb| - BOOT::|genDeltaSig| BOOT::|c05pbfSolve,fa| - BOOT::|c05nbfSolve,fb| - BOOT::|NRTsubstDelta,replaceSlotTypes| - BOOT::|c05nbfSolve,fa| BOOT::|slot1Filter| - BOOT::|NRTsubstDelta| BOOT::|c06ebfSolve,f| - BOOT::|catList2catPackageList,fn| BOOT::|addConsDB| - BOOT::|changeDirectoryInSlot1,fn| - BOOT::|changeDirectoryInSlot1,sigloc| - BOOT::|NRTreplaceAllLocalReferences| BOOT::|mkSlot1sublis| - BOOT::|NRTputInLocalReferences| BOOT::|NRTputInHead| - BOOT::|NRTcheckVector| BOOT::|NRTmakeSlot1| - BOOT::|NRTisExported?| BOOT::|makePredicateBitVector| - BOOT::|catList2catPackageList| BOOT::|c06eafSolve,f| - BOOT::|NRTgetAddForm| BOOT::|c06frfSolve,h| - BOOT::|NRTaddInner| BOOT::|c06ekfSolve,f| - BOOT::|updateSlot1DataBase| BOOT::|genDeltaSpecialSig| - BOOT::|c06gbfSolve,f| BOOT::|newHasTest,evalCond| - BOOT::|c06fufSolve,hn| BOOT::|c06gcfSolve,f| - BOOT::|c06fufSolve,hm| BOOT::|c06fpfSolve,h| - BOOT::|c06fqfSolve,h| BOOT::|c06ecfSolve,f| BOOT:|length1?| - BOOT:|ListRemoveDuplicatesQ| BOOT:|ListNReverse| - BOOT::|d01gbfSolve,f| BOOT:|TableKeys| - BOOT::|ncParseAndInterpretString| BOOT::|pfPrintSrcLines| - BOOT::TERMINATOR VMLISP::MAKE-BVEC - BOOT::|exp2FortOptimizeCS| BOOT::|exp2FortOptimizeCS1| - BOOT::|expression2Fortran| BOOT::|fortranCleanUp| - BOOT::|exp2FortOptimize| BOOT::|fortPre| BOOT::|incRgen| - BOOT::|segment| BOOT::|exp2Fort1| FOAM:|printNewLine| - FOAM:|formatDFloat| FOAM:|formatSFloat| FOAM:|formatBInt| - BOOT::|npNull| FOAM:|formatSInt| BOOT::|isFloat| - BOOT::|fortExpSize| BOOT::|parseAndEval1| - BOOT::|printStats| BOOT::|mkParameterList| - BOOT::|unStackWarning| BOOT::|fortFormatIntrinsics| - BOOT::?M BOOT::|displayLines| BOOT::|?m| BOOT::|addCommas| - BOOT::|unErrorRef| BOOT::|fortran2Lines| BOOT::|uppretend| - BOOT::|typeOfType| BOOT::|checkLines| BOOT::|uptypeOf| - BOOT::|statement2Fortran| BOOT::|displayLines1| - BOOT::|upQUOTE| BOOT::|dispStatement| - BOOT::|makeCommonEnvironment,interLocalE| BOOT::|upSEQ| - BOOT::|mkMat| BOOT::|makeCommonEnvironment,interC| - BOOT::|fortSize,elen| BOOT::|quote2Wrapped| - BOOT::|deltaContour,eliminateDuplicatePropertyLists| - BOOT::|fortSize| BOOT::|checkType| BOOT::|interpOnlyREPEAT| - BOOT::|upREPEAT1| BOOT::|old2NewModemaps| BOOT::|upREPEAT0| - BOOT::|displayModemaps| BOOT::|uplocal| - BOOT::|fortFormatElseIf| BOOT::|upfree| - BOOT::|indentFortLevel| FOAM:|Halt| BOOT::|upREPEAT| - BOOT::|?modemaps| BOOT::|fortFormatIf| BOOT::|upDEF| - BOOT::|upreturn| BOOT::|uperror| BOOT::|what| - BOOT::?MODEMAPS BOOT::|whatSpad2Cmd| BOOT::|stackAndThrow| - BOOT::|makeCommonEnvironment,interE| BOOT::|constructor| - BOOT::|alqlGetParams| BOOT::|makeNonAtomic| - BOOT::|alqlGetOrigin| BOOT::|alqlGetKindString| - BOOT::|npboot| BOOT::|compAndTrace| VMLISP::SIMPLE-ARGLIST - BOOT::|string2BootTree| VMLISP::REMOVE-FLUIDS - BOOT::|f04qafSolve,f| BOOT::|getBrowseDatabase| - BOOT::|wrapSEQExit| BOOT::|compileSpadLispCmd| - BOOT::|incExitLevel| BOOT::ASEC BOOT::|mkErrorExpr,bracket| - BOOT::|displayProperties,sayFunctionDeps| BOOT::ACOT - BOOT::|displayMacro| VMLISP::QUOTESOF BOOT::|genDeltaEntry| - BOOT::|displayParserMacro| VMLISP::DEQUOTE - BOOT::|compilerMessage| BOOT::MANEXP - BOOT::|asharpConstructorName?| VMLISP::ISQUOTEDP - BOOT::|f04mcfSolve,gj| BOOT::|f04arfSolve,h| VMLISP::VARP - BOOT::|f04mcfSolve,fd| BOOT::|dbpHasDefaultCategory?| - BOOT::|stackMessage| BOOT::|dbAddChainDomain| - BOOT::|listOfIdentifiersIn| BOOT::|knownInfo| - BOOT::|outerProduct| BOOT::|f04jgfSolve,h| - BOOT::|helpSpad2Cmd| BOOT::|f04mcfSolve,fal| - BOOT::|sayAsManyPerLineAsPossible| BOOT::|extractHasArgs| - BOOT::|read| BOOT::|readSpad2Cmd| BOOT::|displayMacros| - BOOT::|warnLiteral| BOOT::|getConstructorModemap| - BOOT::GCOPY BOOT::|koAttrs,fn| BOOT::|displayOperations| - BOOT::|libConstructorSig| BOOT::|f04asfSolve,h| - BOOT::|libConstructorSig,fn| BOOT::|npProcessSynonym| - BOOT::|listOfSharpVars| BOOT::|compileAsharpLispCmd| - BOOT::|isAlmostSimple| BOOT::|libdbTrim| - BOOT::|isAlmostSimple,fn| BOOT::|isFunctor| - BOOT::|stripLisp| BOOT::|parentsOfForm| - BOOT::|isSideEffectFree| BOOT::|ltrace| BOOT::|dbMkForm| - BOOT::|trace| BOOT::|compileAsharpCmd| BOOT::MSORT - BOOT::|displayProplist,fn| BOOT::|removeEnv| BOOT::|load| - BOOT::|loadSpad2Cmd| BOOT::|dbReadLines| BOOT::?VALUE - BOOT::|help| BOOT::|?value| BOOT::|trimComments| - BOOT::|f04atfSolve,h| BOOT::|f04fafSolve,h| - BOOT::|spreadGlossText| BOOT::?PROPERTIES - BOOT::|asyExtractAbbreviation| BOOT::|getGlossLines| - BOOT::|?properties| BOOT::|asyTypeUnit| - BOOT::|getParentsForDomain| BOOT::|f04fafSolve,g| - BOOT::|prModemaps| BOOT::|asyTypeItem| - BOOT::|f04fafSolve,f| BOOT::|importFromFrame| - BOOT::|decExitLevel,removeExit0| - BOOT::|closeInterpreterFrame| BOOT::|f04mbfSolve,f| - BOOT::|tokTran| BOOT::?MODE BOOT::|parseSystemCmd| - BOOT::|?mode| BOOT::|dumbTokenize| BOOT::|edit| - BOOT::|editSpad2Cmd| BOOT::|getDefaultPackageClients| - BOOT::|displayOperationsFromLisplib| BOOT::|say2PerLine| - BOOT::|getArgumentConstructors,fn| - BOOT::|getArgumentConstructors,gn| BOOT::|display| - BOOT::|displaySpad2Cmd| BOOT::|frameEnvironment| - BOOT::|getArgumentConstructors| BOOT::|buildLibAttrs| - BOOT::|buildLibOps| BOOT::|splitIntoOptionBlocks| - BOOT::|writedb| BOOT::|getFirstWord| BOOT::|f07aefSolve,fp| - BOOT::|isSharpVar| BOOT::HAS_SHARP_VAR - BOOT::|dbHasExamplePage| BOOT::|isExistingFile| - BOOT::|mkHasArgsPred| BOOT::|lefts| BOOT::|findEqualFun| - BOOT::|dbFromConstructor?| BOOT::|f01mafSolve,f| - BOOT::|dbShowKind| BOOT::|unAbbreviateIfNecessary| - BOOT:|DeepCopy| BOOT::|evalDomainOpPred,convertCatArg| - BOOT::|dbOpsForm| BOOT::|form2Fence| BOOT::|devaluateList| - BOOT::|dbConstructorDoc,fn| FOAM:|fiStrHash| - BOOT::|dbGetInputString| BOOT::|pmTransFilter| - BOOT::|dbExtractUnderlyingDomain| FOAM:|fiGetDebugger| - BOOT::|isValidType| BOOT:|ByteFileReadLine| BOOT::RENAME - BOOT::|isExposedConstructor| FOAM:|fiSetDebugVar| - BOOT:|InputStream?| BOOT::|ncParseFromString| - BOOT:|OutputStream?| BOOT:|StreamSize| - BOOT:|StreamGetPosition| BOOT:|StreamEnd?| - BOOT:|StreamClose| BOOT::|dbConstructorDoc,gn| - BOOT::|digits2Names| BOOT::|dbCompositeWithMap| - BOOT::|extractFileNameFromPath| BOOT:|ToPathname| - BOOT::IDENT-CHAR-LIT BOOT::IS-CONSOLE-NOT-XEDIT - BOOT::|dbAddChain| BOOT::MESSAGEPRINT - BOOT:|PathnameDirectory| BOOT::MESSAGEPRINT-2 - BOOT::|kFormatSlotDomain| BOOT:|PathnameName| - BOOT::MESSAGEPRINT-1 BOOT::|devaluate| BOOT:|PathnameType| - BOOT::|simpCatPredicate| BOOT:|PathnameString| - BOOT::|dbInfovec| BOOT:|PathnameAbsolute?| - BOOT:|PathnameWithoutType| BOOT::|getImports| - BOOT:|PathnameWithoutDirectory| BOOT::|saySpadMsg| - BOOT::|mkConArgSublis| BOOT:|PathnameToUsualCase| - BOOT:|PathnameDirectoryOfDirectoryPathname| BOOT::|sayTeX| - BOOT::|getUsersOfConstructor| BOOT:|Bit?| BOOT::EQUABLE - BOOT::|makeTemplate| BOOT::|dbShowConsKinds| - BOOT::|makeOpDirect| BOOT:|Vector?| BOOT::|bcConTable| - BOOT::|makeOpDirect,fn| BOOT::|mkUniquePred| - BOOT::PARTCODET BOOT::|bcAbbTable| BOOT::|putPredHash| - BOOT::|bcNameConTable| BOOT::|NRTinnerGetLocalIndex| - BOOT::|breakIntoLines| BOOT::|dbConstructorKind| - BOOT::BLANKP BOOT::|setLoadTimeQ| BOOT:|CharDigit?| - BOOT::|dbConstructorDoc,hn| BOOT::|setLoadTime| - BOOT::NONBLANKLOC BOOT::|extendVectorSize| - BOOT::|markUnique| BOOT:|Cset| BOOT::INDENT-POS - BOOT::|addConsDB,min| BOOT::NEXT-TAB-LOC - BOOT:|CsetComplement| BOOT::|measureCommon| - BOOT:|CsetString| BOOT::|getDependentsOfConstructor| - BOOT::|htMakeSaturnFilterPage| BOOT::|writeSaturnLines| - BOOT::|hasIdent| BOOT::|addConsDB,HashCheck| - BOOT::|parseNoMacroFromString| BOOT::|mapConsDB| - BOOT::|pf2Sex| BOOT::|squeezeConsDB| BOOT::|StreamNull| - BOOT::|squeezeConsDB,fn| BOOT::|mkBold| BOOT::|incString| - BOOT::|postSignature| BOOT::|killColons| BOOT:|ToString| - BOOT::|e02dffSolve,flam| BOOT::|removeSuperfluousMapping| - BOOT:|StringImage| BOOT::|dbShowConstructorLines| - BOOT:|String?| BOOT::|postAtom| BOOT::|dbName| - BOOT::|makeSpadConstant| BOOT::|postType| - BOOT::|childrenOf| BOOT::|htBcLispLinks| - BOOT::|typeCheckInputAreas| BOOT::|kisValidType| - BOOT::|kCheckArgumentNumbers| BOOT:|StringUpperCase| - BOOT:|StringLowerCase| BOOT::|topicCode| - BOOT::|htMakePage1| BOOT::|string2OpAlist| - BOOT::|htProcessDoitButton| BOOT::|blankLine?| - BOOT::|htProcessDoneButton| BOOT::|e02defSolve,fmu| - BOOT::|topics| BOOT::|htProcessBcButtons| - BOOT::|topLevelInterpEval| BOOT::|tdPrint| - BOOT::|htProcessToggleButtons| - BOOT::|htProcessDomainConditions| - BOOT::|getConstructorSignature| BOOT::|getDefaultProps| - BOOT::|htInputStrings| BOOT::GET-A-LINE - BOOT::|getConstructorDocumentation| - BOOT::|htBcRadioButtons| BOOT::KILL-COMMENTS - BOOT::|topicCode,fn| BOOT::|htRadioButtons| - BOOT::|listOfTopics| BOOT::|htLispMemoLinks| - BOOT::PRINT-RULE BOOT::|code2Classes| BOOT::SET-PREFIX - BOOT::PRINT-FLUIDS BOOT::|td| BOOT::|unabbrev| - BOOT::|prTriple| BOOT::|htEndMenu| BOOT::GET-META-TOKEN - BOOT::|hasNewInfoAlist| BOOT::|addTraceItem| - BOOT::GET-BSTRING-TOKEN BOOT::|untraceAllDomainLocalOps| - BOOT::|bright| BOOT::GET-STRING-TOKEN - BOOT::|formatUnabbreviated| BOOT::GET-IDENTIFIER-TOKEN - BOOT::BVEC-NOT BOOT::TOKEN-LOOKAHEAD-TYPE - BOOT::|orderBySlotNumber| BOOT::|traceSpad2Cmd| - BOOT::|compArgumentConditions| BOOT::|e02defSolve,flam| - BOOT::|trace1| BOOT::LINE-PRINT BOOT::|saveMapSig| - BOOT::LINE-PAST-END-P BOOT::|untrace| - BOOT::|stripOffArgumentConditions| - BOOT::DATABASE-CONSTRUCTORKIND BOOT::SPAD_ERROR_LOC - BOOT::|getTraceOptions| BOOT::|transTraceItem| - BOOT::BOOT-PARSE-1 BOOT::|genSearchTran| - BOOT::REDUCTION-VALUE BOOT::|removeSurroundingStars| - BOOT::|getTraceOption| BOOT::|checkFilter| BOOT::PREPARSE - BOOT::|getMapSubNames| BOOT::|getPreviousMapSubNames| - BOOT::|coerceSpadArgs2E| BOOT::|clear| - BOOT::|whatConstructors| BOOT::|stupidIsSpadFunction| - BOOT::|sayBrightlyLength| BOOT::|stackTraceOptionError| - BOOT::GET-BOOT-TOKEN BOOT::|reportOpsFromUnitDirectly| - BOOT::|coerceSpadFunValue2E| BOOT::|searchCount| - BOOT::GET-SPECIAL-TOKEN BOOT::|domainToGenvar| - BOOT::|searchDropUnexposedLines| BOOT::GET-SPADSTRING-TOKEN - BOOT::|compileAsharpArchiveCmd| BOOT::|genDomainTraceName| - BOOT::GET-NUMBER-TOKEN BOOT::GET-ARGUMENT-DESIGNATOR-TOKEN - BOOT::|spadReply,printName| BOOT::|abbreviations| - BOOT::|getTraceOption,hn| BOOT::BOOT-TOKEN-LOOKAHEAD-TYPE - BOOT::|changeToNamedInterpreterFrame| - BOOT::|removeTracedMapSigs| BOOT::|findFrameInRing| - BOOT::|isListOfIdentifiers| BOOT::|string2Constructor| - BOOT::|isListOfIdentifiersOrStrings| BOOT::|dbString2Words| - BOOT::|conLowerCaseConTran| BOOT::|emptyInterpreterFrame| - BOOT::|string2Words| BOOT::|whatCommands| - BOOT::BUMPERRORCOUNT BOOT::|commandsForUserLevel| - BOOT::MAKE-ADJUSTABLE-STRING BOOT::|dnForm| BOOT::|pp2Cols| - BOOT::|dnForm,negate| BOOT::|dbGetCommentOrigin| - BOOT::|whatSpad2Cmd,fixpat| BOOT::DEF-PROCESS - BOOT::|synonymsForUserLevel| BOOT::DEF-RENAME - BOOT::|postTransform| - BOOT::|processSynonymLine,removeKeyFromLine| - BOOT::|pmPreparse,hn| BOOT::|new2OldLisp| - BOOT::|processSynonymLine| BOOT::PRINT-PACKAGE - BOOT::|printSynonyms| BOOT::INITIALIZE-PREPARSE - BOOT::|clearParserMacro| - BOOT::|dbScreenForDefaultFunctions| BOOT::S-PROCESS - BOOT::|newHelpSpad2Cmd| BOOT::|dbChooseOperandName| - BOOT::|zsystemDevelopmentSpad2Cmd| BOOT::|parseFromString| - BOOT::|checkPmParse,fn| BOOT::|dbRead| - BOOT::|string2SpadTree| BOOT::|checkPmParse| SYSTEM:PNAME - BOOT::|htCopyProplist| BOOT::|pathnameTypeId| - BOOT::|capitalize| BOOT::|htSayValue| - BOOT::|clearCmdExcept| BOOT::|getSubstSigIfPossible| - BOOT::|workfilesSpad2Cmd| BOOT::|isIntegerString| - BOOT::|cd| BOOT::|dbGetExpandedOpAlist| - BOOT::|dbAddDocTable| BOOT::|zsystemdevelopment| - BOOT::|getConstructorForm| BOOT::|workfiles| - BOOT::|originsInOrder| BOOT::|getInfoAlist| - BOOT::|parentsOf| BOOT::|listOrVectorElementMode| - BOOT::|zeroOneConvertAlist| BOOT::|dbInfoSig| - BOOT::|numberize| BOOT::|hasNewInfoText| - BOOT::|splitConTable| BOOT::|dbGetDocTable,gn| - BOOT::|string2Integer| BOOT::|recordFrame| - BOOT::|issueHTSaturn| BOOT::|kTestPred| - BOOT::|segmentKeyedMsg| BOOT::|htpPageDescription| - BOOT::|dbDocTable| BOOT::|saturnTran| BOOT::|bcUnixTable| - BOOT::|mkTabularItem| BOOT::|printAsTeX| - BOOT::|isAsharpFileName?| BOOT::|isMenuItemStyle?| - BOOT::|saturnTranText| BOOT::|bcError| - BOOT::|transOnlyOption| BOOT::|kPageContextMenu| - BOOT::|bcString2WordList| BOOT::|unTab1| - BOOT::|shortenForPrinting| BOOT::|getBpiNameIfTracedMap| - BOOT::|recordAndPrintTest| BOOT::|mkTabularItem,fn| - BOOT::|PullAndExecuteSpadSystemCommand| BOOT::|htNewPage| - BOOT::|htpName| BOOT::|prTraceNames,fn| - BOOT::|htMakePageSaturn| BOOT::|e02zafSolve,flam| - BOOT::|isCapitalWord| BOOT::|zagSuper| BOOT::|height| - BOOT::|zagSub| BOOT::|inputPrompt| - BOOT::|flattenOperationAlist| BOOT::|variableNumber| - BOOT::|spadTrace,g| BOOT::|mkPredList,fn| - BOOT::|isTraceGensym| BOOT::|htPopSaturn| - BOOT::|htMakePageStandard| BOOT::|undo| BOOT::|dbKind| - BOOT::|undoCount| BOOT::|stringer| BOOT::|outputTranIf| - BOOT::|htInitPageNoHeading| BOOT::|undoLocalModemapHack| - BOOT::|saturnHasExamplePage| BOOT::|reportUndo| BOOT::|iht| - BOOT::|bcIssueHt| BOOT::|bcConform1| BOOT::|keyp| - BOOT::|bcConform1,hd| BOOT::|binomialWidth| - BOOT::|htSaySourceFile| BOOT::|basicStringize| - BOOT::|mapStringize| BOOT::|binomialSuper| - BOOT::|bcConform1,mapping| - BOOT::|outputTranMatrix,outtranRow| - BOOT::PLAIN-PRINT-FORMAT-STRING BOOT::|bcConform1,tuple| - BOOT::|binomialSub| BOOT::|vConcatWidth| BOOTTRAN::BOOTTOCL - BOOT::|bcConform1,tl| BOOT::|deMatrix| BOOT::TRANSLIST - BOOT::|sumWidthA| BOOT::TRANSLATE BOOT::|htSayItalics| - BOOT::|dbGetDocTable,hn| BOOT::|absym| - BOOT::|dbEvalableConstructor?| BOOT::|getCallBack| - BOOT::|texFormat1| BOOT::|unTab| - BOOT::RETRANSLATE-DIRECTORY BOOT::|kPageContextMenuSaturn| - BOOT::|maPrin| BOOT::RETRANSLATE-FILE-IF-NECESSARY - BOOT::|saturnExampleLink| BOOT::|explainLinear| - BOOT::RECOMPILE-ALL-LIBS BOOT::|htSayCold| - BOOT::RECOMPILE-LIB-DIRECTORY - BOOT::RECOMPILE-NRLIB-IF-NECESSARY BOOT::|writeSaturnTable| - BOOT::|maprinRows| BOOT::RECOMPILE-ALL-FILES - BOOT::|writeSaturn| BOOT::|maprinChk| - BOOT::|writeSaturnPrint| BOOT::RECOMPILE-ALL-ALGEBRA-FILES - BOOT::|bcConform1,say| BOOT::|escapeSpecialIds| - BOOT::|vConcatSub| BOOT::LOAD-DIRECTORY - BOOT::|postDoubleSharp| BOOT::|sumoverlist| - BOOT::|htProcessBcStrings| BOOT::|matSuperList| - BOOT::|superSubWidth| BOOT::CHAPTER-NAME BOOT::|isQuotient| - BOOT::|matSubList| BOOT::|superSubSuper| - BOOT::|isRationalNumber| BOOT::|matLSum| - BOOT::|superSubSub| BOOT::BLANKCHARP - BOOT::SPADTAGS-FROM-FILE BOOT::|matLSum2| - BOOT::OUR-WRITE-DATE BOOT::LIFT-NRLIB-NAME - BOOT::RECOMPILE-FILE-IF-NECESSARY BOOT::|suScWidth| - BOOT::|bcLinearSolveMatrixInhomo,f| BOOT::LIBCHECK - BOOT::|bcLinearExtractMatrix| BOOT::|printMap| - BOOT::|isInitialMap| BOOT::SPAD-CLEAR-INPUT - BOOT::|bcString2HyString| - BOOT::|NeedAtLeastOneFunctionInThisFile| BOOT::|pfSequence| - BOOT::|npPileBracketed| BOOT::|npAnyNo| BOOT::|bcOptional| - VMLISP::EQUABLE VMLISP::*LAM BOOT::|subSub| VMLISP::RCQEXP - BOOT::|flattenOps| BOOT::|npInfGeneric| BOOT::|slashWidth| - BOOT::|slashSuper| VMLISP::COMPILE1 BOOT::|slashSub| - BOOT::|pfPile| BOOT::|npParened| BOOT::BVEC-COPY - BOOT::|letWidth| VMLISP::FLAT-BV-LIST BOOT::|sortCarString| - BOOT::|pfAppend| VMLISP::PLIST2ALIST BOOT::|pfFix| - BOOT::|outputConstructTran| BOOT::|pfTyping| - BOOT::|outputTranSEQ| BOOT::|outputTranRepeat| - BOOT::|outputTranReduce| BOOT::|outputTranCollect| - BOOT::|outputMapTran| BOOT::|npSemiListing| - BOOT::|pfExport| BOOT::|pfLocal| - BOOT::|optSEQ,getRidOfTemps| BOOT::|optSPADCALL| - BOOT::|pfFree| BOOT::|optXLAMCond| BOOT::|optCONDtail| - BOOT::|optPredicateIfTrue| BOOT::|optCons| BOOT::|optSEQ| - BOOT::|pfBreak| BOOT::|optSEQ,tryToRemoveSEQ| - BOOT::|optSEQ,SEQToCOND| BOOT::|optimize,opt| - BOOT::|optCond| BOOT::|pfReturnNoName| BOOT::|optMkRecord| - BOOT::|npListAndRecover| BOOT::|optCatch| BOOT::|npTuple| - BOOT::|pf0SequenceArgs| BOOT::|compileTimeBindingOf| - BOOT::|optimizeFunctionDef,removeTopLevelCatch| - BOOT::|optEQ| BOOT::|optLESSP| BOOT::|pfIterate| - BOOT::|opt-| BOOT::|optQSMINUS| BOOT::|pfLoop1| - BOOT::|optMINUS| BOOT::|optSuchthat| BOOT::|optRECORDCOPY| - BOOT::|optSETRECORDELT| BOOT::|npParse| - BOOT::|timedEVALFUN| BOOT::|pfDocument| - BOOT::|updateTimedName| BOOT::|pfTweakIf| - BOOT::|timedOptimization| BOOT::|pfCheckItOut| - BOOT::|timedAlgebraEvaluation| BOOT::|pushTimedName| - BOOT::|significantStat| BOOT::|printNamedStats| - BOOT::|htpDestroyPage| BOOT::|splitIntoBlocksOf200| - BOOT::|incIgen| BOOT::|e02dafSolve,flam| - BOOT::|e04nafSolve,fe| BOOT::|str2Tex| - BOOT::|e04nafSolve,fd| BOOT::|wrap| BOOT::|e04nafSolve,fc| - BOOT::|e04ycfSolve,fa| BOOT::|str2Outform| - BOOT::|parse2Outform| BOOT::|e04nafSolve,fj| - BOOT::|e04nafSolve,fg| BOOT::|e04dgfSolve,fb| - BOOT::|e04mbfSolve,fg| BOOT::|evalLoopIter| - BOOT::|formatUnabbreviatedTuple| BOOT::|e04mbfSolve,fe| - BOOT::|length2?| BOOT::|Identity| BOOT::|upADEF| - BOOT::|bool| BOOT::|e04mbfSolve,fd| BOOT::|orderList| - BOOT::|e04mbfSolve,fc| BOOT::|upLoopIters| BOOT::NMSORT - BOOT::|pr| BOOT::|e04fdfSolve,fb| BOOT::|interpIter| - BOOT::|functionp| BOOT::|quoteCatOp| BOOT::|e04fdfSolve,fa| - BOOT::|isLetter| BOOT::|mkNestedElts| BOOT::|charRangeTest| - BOOT::|instantiate| BOOT::|isUpperCaseLetter| - BOOT::|e04gcfSolve,fb| BOOT::|flattenSexpr| - BOOT::|e04gcfSolve,fa| BOOT::|isStreamCollect| - BOOT::|removeZeroOneDestructively| BOOT::|StringToCompStr| - BOOT::|boolODDP| BOOT::|rightTrim| - BOOT::|dropLeadingBlanks| BOOT::|getDomainByteVector| - BOOT::|interpOnlyCOLLECT| BOOT::|e04jafSolve,fc| - BOOT::|upCOLLECT| BOOT::|upAlgExtension| - BOOT::|e04jafSolve,fb| BOOT::|eq2AlgExtension| - BOOT::|e04jafSolve,fa| BOOT::|clearCmdParts| - BOOT::|upCOLLECT0| BOOT::|loadLib| BOOT::|upCOLLECT1| - BOOT::|upand| BOOT::|upDeclare| BOOT:|pp| - BOOT::|f01rdfSolve,fz| BOOT::|mkZipCode| BOOT:ATOM2STRING - BOOT::|orderCatAnc| BOOT::|f01mcfSolve,g| - BOOT::|isOkInterpMode| BOOT::|f01mcfSolve,f| - BOOT::|mkAndApplyPredicates| BOOT:MATCH-STRING - BOOT::|upCOERCE| BOOT::|upStreamIters| BOOT::|upconstruct| - BOOT::|upTARGET| BOOT::|falseFun| BOOT::|upLET| - BOOT::|closeOldAxiomFunctor| BOOT::|f01refSolve,fz| - BOOT::|upLETWithPatternOnLhs| BOOT::|isTupleForm| - BOOT::|f01qefSolve,fz| BOOT::|e02zafSolve,fxy| - BOOT::|shoeStrings| BOOT::|removeConstruct| BOOT:|break| - BOOT::|shoeIntern| BOOT::|isLocalPred| - BOOT::|shoeInternFile| BOOT::|upequation| - BOOT::|SpadInterpretFile| BOOT::|intInterpretPform| - BOOT::|altSeteltable| BOOT::|packageTran| - BOOT::|isHomogeneous| BOOT::|zeroOneTran| - BOOT::|intProcessSynonyms| BOOT::|upbreak| - BOOT::|f01brfSolve,f| BOOT::|intnplisp| BOOT::|upDollar| - BOOT::|nplisp| BOOT::|setCurrentLine| - BOOT::|f01qdfSolve,fz| BOOT::|copyHack| BOOT::|copyHack,fn| - BOOT:ADJCURMAXINDEX BOOT::|upTuple| BOOT::|ncloopParse| - BOOT::|ncloopIncFileName| BOOT::|phBegin| - BOOT::|ncloopEscaped| BOOT::|upiterate| BOOT::|upIF| - BOOT::|upisnt| BOOT::|upisAndIsnt| BOOT::|phInterpret| - BOOT::|isHomogeneousArgs| BOOT:LASTATOM BOOT::|uphas| - BOOT::|phMacro| BOOT::|macroExpanded| BOOT::|upis| - BOOT::|ncConversationPhase,wrapup| BOOT:CONSOLEINPUTP - BOOT::|upwhere| BOOT::|serverReadLine| - BOOT::|ncloopPrintLines| BOOT::|mkLineList| - BOOT::|nonBlank| BOOT:|MakeSymbol| BOOT::|intloopEchoParse| - BOOT::|incBiteOff| BOOT::|SkipEnd?| BOOT::|incFileName| - BOOT::|Else?| BOOT::|Elseif?| BOOT::|If?| - BOOT::|inclmsgNoSuchFile| BOOT::|inclmsgPrematureFin| - BOOT::|incFileInput| BOOT::|Top?| - BOOT::|inclmsgPrematureEOF| BOOT::|SkipPart?| - BOOT::|KeepPart?| BOOT:COMP BOOT:GETGENSYM - BOOT::|incNConsoles| BOOT::|Skipping?| BOOT::|incClassify| - BOOT::EXPAND-TABS BOOT::|incCommand?| BOOT::|incRenumber| - BOOT::|incFile| BOOT::|incPos| - BOOT:|initializeSetVariables| BOOT::|inclmsgSay| - BOOT::|inclmsgConStill| BOOT::|incStringStream| - BOOT::|inclmsgConActive| BOOT:NUMOFNODES FOAM::TYPE2INIT - BOOT:TRANSPGVAR FOAM::FOAM-FUNCTION-INFO BOOT::|GetValue| - BOOT::|hasToInfo| FOAM::INSERT-TYPES BOOT::|formatPred| - BOOT::|chaseInferences,foo| BOOT::|liftCond| - FOAM::FOAMPROGINFOSTRUCT-P BOOT::|formatInfo| - BOOT:TOKEN-TYPE BOOT::|addInformation,info| - BOOT:|updateSourceFiles| BOOT::|infoToHas| BOOT::|addInfo| - BOOT::|formatPredParts| BOOT::|printInfo| - BOOT::|linearFormat| BOOT::|formatOperationAlistEntry| - BOOT::|formatIf| BOOT:MKQ BOOT::|linearFormatName| - BOOT::|dollarPercentTran| BOOT::|string2Float| - BOOT::|specialChar| BOOT:TOKEN-SYMBOL BOOT::|hashCode?| - BOOT::|formatArgList| BOOT::|listOfPredOfTypePatternIds| - BOOT::|script2String| BOOT::|form2Fence1| - BOOT::|replaceGoGetSlot| BOOT::|constructorName| - BOOT::|sayModemap| BOOT:ACTION BOOT::|opIsHasCat| - BOOT::|isNewWorldDomain| BOOT::|formCollect2String| - BOOT::|DNameToSExpr1| BOOT::|tuple2String| - BOOT::|DNameFixEnum| BOOT::|formJoin2String| BOOT:ASSOCLEFT - BOOT::|DNameToSExpr| BOOT:|sayALGEBRA| - BOOT::|CompStrToString| BOOT::|record2String| - FOAM-USER::|AXL-spitSInt| BOOT::|computedMode| - BOOT::|formWrapId| BOOT::|getIProplist| - BOOT::|isBinaryInfix| BOOT::|mkAtreeValueOf| - BOOT::|collectDefTypesAndPreds| BOOT::|formatSignature| - BOOT::|freeOfSharpVars| BOOT::|unVectorize| - BOOT::|formatSignature0| BOOT::|isInternalFunctionName| - BOOT::|objEnv| BOOT:NREVERSE0 BOOT::|formatMapping| - BOOT::|canRemoveIsDomain?| BOOT:|sayFORTRAN| - BOOT::|formIterator2String| BOOT:|IS_#GENVAR| - BOOT::|removeIsDomains| BOOT:LISTOFATOMS - BOOT::|formatAttribute| BOOT::|formTuple2String| - BOOT::|numOfSpadArguments| BOOT::|args2Tuple| - BOOT::|blankList| BOOT::|removeBodyFromEnv| - BOOT::|form2StringWithWhere| BOOT::|reportOpSymbol| - BOOT::|apropos| BOOT::|formatModemap,fn| - BOOT::|listOfVariables| BOOT::|isFreeVar| - BOOT::|isLocalVar| BOOT::|expr2String| - BOOT::|isInternalMapName| BOOT::|atom2String|)) -(PROCLAIM - '(FTYPE (FUNCTION (T *) *) VMLISP:MAKE-APPENDSTREAM - VMLISP:MAKE-INSTREAM VMLISP:MAKE-OUTSTREAM - VMLISP:COMPILE-LIB-FILE BOOT:|OsRunProgram| - BOOT:|OsRunProgramToStream| BOOT::ASHARP - FOAM:COMPILE-AS-FILE BOOT:|Prompt| BOOT:|sayBrightlyNT|)) -(PROCLAIM - '(FTYPE (FUNCTION (T T T) (VALUES T T)) BOOT::|getScriptName| - FOAM:AXIOMXL-GLOBAL-NAME BOOT::|spadTraceAlias|)) -(PROCLAIM '(FTYPE (FUNCTION (T T *) (VALUES T T)) VMLISP:MDEF)) -(PROCLAIM '(FTYPE (FUNCTION (T *) STRING) VMLISP:MAKE-FULL-CVEC)) -(PROCLAIM - '(FTYPE (FUNCTION (T T) *) BOOT::|bcInputMatrixByFormula| - BOOT::|bcInputExplicitMatrix| BOOT::|htStringPad| - BOOT::|evalAndRwriteLispForm| BOOT::|mkAtreeWithSrcPos| - BOOT::|rwriteLispForm| BOOT::COMPILE-DEFUN BOOT::|doIt| - BOOT::BPIUNTRACE VMLISP:QUOTIENT BOOT::|print| - BOOT::|compilerDoitWithScreenedLisplib| - BOOT::|compilerDoit| BOOT::MONITOR-PRINVALUE BOOT::/TRACE-2 - VMLISP:|LAM,FILEACTQ| BOOT::|hasFormalMapVariable| - BOOT::|ScanOrPairVec| VMLISP:SUFFIX BOOT::PRINMATHOR0 - BOOT::|spadTrace| BOOT::|output| BOOT::|e01bffDefaultSolve| - BOOT::|e01safDefaultSolve| BOOT::|popUpNamedHTPage| - BOOT::|e01dafDefaultSolve| BOOT::|replaceNamedHTPage| - BOOT::|e02bafDefaultSolve| BOOT::|e02bdfDefaultSolve| - BOOT::|e02defDefaultSolve| BOOT::|sockSendFloat| - BOOT::SOCK-SEND-SIGNAL BOOT::SOCK-SEND-FLOAT - BOOT::SOCK-SEND-STRING BOOT::SOCK-SEND-INT BOOT::ERASE - BOOT::|sayErrorly| BOOT::|saturnSayErrorly| BOOT::|set1| - BOOT::|displaySetOptionInformation| BOOT::|mkGrepPattern| - BOOT::|showDoc| BOOT::|genSearchSayJump| BOOT::|oPageFrom| - BOOT::|showConstruct| BOOT::|htCommandToInputLine,fn| - BOOT::|grepConstructorSearch| BOOT::|showNamedDoc| - BOOT::|form2HtString,fnTail| BOOT::|xdrWrite| - BOOT::|spleI1| BOOT::|readData,xdrRead1| BOOT::|xdrRead| - BOOT::|sockSendSignal| BOOT::|htpLabelFilteredInputString| - BOOT::|e01bgfDefaultSolve| BOOT::|e01befDefaultSolve| - BOOT::|e01bafDefaultSolve| BOOT::|htGlossSearch| - BOOT::|htSetSystemVariable| BOOT::|htSetSystemVariableKind| - BOOT::|htSetNotAvailable| BOOT::|htShowLiteralsPage| - BOOT::|htCheck| BOOT::|htShowIntegerPage| - BOOT::|htShowFunctionPage| BOOT::|htSetFunCommandContinue| - BOOT::|htKill| BOOT::|htFunctionSetLiteral| - BOOT::|htShowSetPage| BOOT::ADDCLOSE BOOT::|htSetLiteral| - BOOT:|LispCompileFileQuietlyToObject| - ; BOOT::|findStringInFile| - BOOT::|ppPair| - BOOT::|getMinimalVarMode| BOOT::|checkAddSpaceSegments| - BOOT::|checkAddIndented| BOOT::|alistSize,count| - BOOT::|dbConformGen1| BOOT::|pickitForm| - BOOT::|koaPageFilterByCategory1| VMLISP::COPY-FILE - VMLISP::COPY-LIB-DIRECTORY BOOT::|c06ebfDefaultSolve| - BOOT::|c06gsfDefaultSolve| BOOT::|c06eafDefaultSolve| - BOOT::|c06gbfDefaultSolve| BOOT::|c06gqfDefaultSolve| - BOOT::|c06ecfDefaultSolve| BOOT::|c06gcfDefaultSolve| - BOOT::|d01gafDefaultSolve| BOOT::|spadcall2| - BOOT::|sublisV| BOOT::|sublisV,suba| BOOT::|fortError| - BOOT::|f04adfDefaultSolve| BOOT::|f04arfDefaultSolve| - BOOT::|koPageFromKKPage| BOOT::|kArgPage| BOOT::|npsystem| - BOOT::|f04asfDefaultSolve| - BOOT::|handleParsedSystemCommands| - BOOT::|handleTokensizeSystemCommands| - BOOT::|f07fdfDefaultSolve| BOOT::|tokenSystemCommand| - BOOT::|reportOpsFromLisplib1| BOOT::|handleNoParseCommands| - BOOT::|f07aefDefaultSolve| BOOT::|f07fefDefaultSolve| - BOOT::|f07adfDefaultSolve| BOOT::|addPatchesToLongLines| - BOOT::|kArgumentCheck| BOOT::COERCE-FAILURE-MSG - BOOT::|kxPage| BOOT::|kcnPage| BOOT::SAYBRIGHTLYNT1 - BOOT::|kcuPage| BOOT::|ksPage| BOOT::|conOpPage| - BOOT::|kcdoPage| BOOT::|kcdePage| BOOT::|kcdPage| - BOOT::|kccPage| BOOT::|patternCheck,subWild| - BOOT::|kcaPage| BOOT::|kcpPage| BOOT::|htDoneButton| - BOOT::|sockSendInt| BOOT::|kePage| BOOT::|sockSendString| - BOOT::|koaPageFilterByName| BOOT::|koaPageFilterByCategory| - BOOT::|koPageAux1| BOOT::|kcPage| BOOT::|getmode| - BOOT::|docSearch1| BOOT::|grepSearchQuery| - BOOT::|repeatSearch| BOOT::|reportOpsFromLisplib0| - BOOT::|reportOperations| BOOT::|generalSearchDo| - BOOT::|grepSearchJump| BOOT::|mkDetailedGrepPattern,conc| - BOOT::|kiPage| BOOT::|errorPage| - BOOT::|dbShowConsKindsFilter| BOOT::|koPage| - BOOT::|dbInfoChoose| BOOT::|kciPage| - BOOT::|dbInfoChooseSingle| BOOT::|dbSort| BOOT::|msgText| - BOOT::|bcSeriesByFormula| BOOT::|bcRealLimitGen1| - BOOT::|bcSeriesExpansion| BOOT::|ncloopInclude| - BOOT::|bcComplexLimit| BOOT::|bcRealLimit| - BOOT::|htFilterPage| BOOT::|bcPuiseuxSeries| - BOOT::KCL-OS-RUN-PROGRAM-TO-STREAM BOOT::|bcLaurentSeries| - BOOT::KCL-OS-RUN-PROGRAM BOOT::|bcTaylorSeries| - BOOT::|bcLinearSolveMatrix| BOOT::|bcMakeEquations| - BOOT::|bcMakeLinearEquations| BOOT::|bcLinearSolveEqns| - BOOT::|bcSolveSingle| BOOT::|bcInputEquations| BOOT::FC - BOOT::|bcSystemSolve| BOOT::|bcSolveEquationsNumerically| - BOOT::|bcSolveEquations| BOOT::|bcLinearSolve| - BOOT::|bcLinearMatrixGen| - BOOT::|bcLinearSolveMatrixInhomoGen| - BOOT::|bcLinearSolveMatrixInhomo| - BOOT::|bcLinearSolveMatrixHomo| BOOT::|finalExactRequest| - BOOT::|printMap1| BOOT::|htMkName| - BOOT::|makeLongSpaceString| BOOT::|makeLongTimeString| - BOOT::|nrtEval| BOOT::|f01mcfDefaultSolve| - BOOT::|f01rcfDefaultSolve| BOOT::|ncloopCommand| - BOOT::|ncloopInclude1| BOOT::|ncConversationPhase| - BOOT:DEFSTREAM BOOT::|inclHandleBug| BOOT::|evalSlotDomain| - BOOT::|ncEltQ| BOOT::|formArguments2String,fn|)) -(PROCLAIM - '(FTYPE (FUNCTION (T *) T) BOOT:|sayBrightly| BOOT:BLANKS - BOOT:MATCH-NEXT-TOKEN BOOT::|desiredMsg| - BOOT:|sayBrightlyI| BOOT:MATCH-CURRENT-TOKEN - VMLISP:RDEFIOSTREAM VMLISP:CATCHALL VMLISP:TAB - VMLISP:|F,PRINT-ONE| VMLISP:VMPRINT BOOT::FINDTAG - VMLISP:MAKE-HASHTABLE VMLISP:MAKE-FILENAME VMLISP:MACERR - VMLISP:PRETTYPRINT BOOT::|pfExpression| BOOT::|pfSymbol| - VMLISP:|LAM,EVALANDFILEACTQ| VMLISP:PRETTYPRIN0 - BOOT::|pfSymb| VMLISP::MAKE-INPUT-FILENAME - BOOT:|LispReadFromString| BOOT::MONITOR-ADD BOOT::|cpCms| - VMLISP::MAKE-FULL-NAMESTRING BOOT:|PrettyPrint| - BOOT:|PlainPrintOn| BOOT:|WriteLispExpr| BOOT:|WriteLine| - BOOT:|WriteString| BOOT:|ReadLineIntoString| - BOOT:|ReadBytesIntoVector| BOOT:|Pathname| - BOOT:|FullVector| BOOT:|FullBvec| BOOT:|FullString| - BOOT::PRINT-NEW-LINE BOOT::PRINT-FULL - BOOT::GET-BOOT-IDENTIFIER-TOKEN BOOT::COMPSPADFILES)) -(PROCLAIM - '(FTYPE (FUNCTION (T T) T) BOOT::|mkAliasList,fn| BOOT:PREDECESSOR - BOOT::|depthOfRecursion| BOOT::|formatJoinKey| - BOOT::|putBodyInEnv| BOOT::|mapDefsWithCorrectArgCount| - BOOT::|sayModemapWithNumber| BOOT::|addDefaults| BOOT:NLIST - BOOT::|formatOperation| BOOT::|get1defaultOp| - BOOT::|compileBody| BOOT::|makeLocalModemap| BOOT:NSTRCONC - BOOT::|saveDependentMapInfo| BOOT:GETRULEFUNLISTS - BOOT::|axFormatDecl| BOOT::|mkMapAlias| BOOT::|readData| - BOOT::|axFormatConstantOp| BOOT::|axFormatOpSig| - BOOT::|mkFormalArg| BOOT::|writeData| BOOT:POINT - BOOT::|mkValCheck| BOOT::|mkValueCheck| BOOT::|isPointer?| - BOOT::|wt| BOOT::|dqAppend| BOOT::|makePattern| - BOOT::|makeAxFile| BOOT::|clearDependencies| - BOOT::|getEqualSublis,fn| BOOT::|sourceFilesToAxFile| - BOOT::|getLocalVars| BOOT::|simplifyMapPattern| - BOOT::|getMapBody| BOOT:GETTAIL BOOT::|htpLabelInputString| - BOOT::|htpLabelSpadValue| BOOT::|putDependencies| - BOOT::STACK-PUSH BOOT:COMPARE BOOT::|htMakeDoneButton| - BOOT::|putDependencies,removeObsoleteDependencies| - BOOT::|makeNewDependencies| BOOT::|PARSE-Operation| - BOOT::|htInitPage| BOOT::|notCalled| BOOT::|htpProperty| - BOOT::|containsOp| BOOT::|makeRuleForm| - BOOT::|nonRecursivePart| BOOT::|outputFormat| - BOOT::|sayDroppingFunctions| BOOT::|nonRecursivePart1| - BOOT::|expandRecursiveBody| BOOT::|addDefMap| - BOOT::|e04nafSolve,fh| BOOT:FLAG BOOT::|ifCond| - BOOT::|incCommandTail| BOOT::|incTrunc| BOOT::|dollarTran| - BOOT:PAIR BOOT::CHAR-EQ BOOT::|PARSE-rightBindingPowerOf| - BOOT::|e04nafSolve,fi| BOOT:SUBLISNQ - BOOT::|writeInputLines| BOOT::|rempropI| BOOT:DELASC - BOOT::|showInput| BOOT::|showInOut| BOOT::SPADRREAD - BOOT:LASSOC BOOT::|ScanOrPairVec,ScanOrInner| BOOT::|getI| - BOOT::|mergeSignatureAndLocalVarAlists| BOOT::CHAR-NE - BOOT:S+ BOOT::|convertOpAlist2compilerInfo,formatSig| - BOOT::|getLisplibNoCache| BOOT::|getLisplib| - BOOT::|PARSE-leftBindingPowerOf| BOOT:MAKE-PARSE-FUNCTION - BOOT::|spadPrint| BOOT::|getSlotFromCategoryForm| - BOOT::|systemDependentMkAutoload| BOOT:MKPF - BOOT::|mkAutoLoad| BOOT:STRM BOOT::|wordFrom| - FOAM::|magicEq1| BOOT::|throwKeyedMsg1| - BOOT::|saturnThrowKeyedMsg| BOOT::|center| - BOOT::|substituteCategoryArguments| - BOOT::|isDomainConstructorForm| BOOT::|keyedSystemError1| - BOOT::|orderByDependency| BOOT::|saturnKeyedSystemError| - BOOT::|getFunctorOpsAndAtts| BOOT::|breakKeyedMsg| - BOOT::|fastSearchCurrentEnv| BOOT::|putMode| - BOOT::|splitListOn| BOOT::|putFlag| - BOOT::|mkAtreeNodeWithSrcPos| BOOT::|getMsgCatAttr| - BOOT::|DomainSubstitutionFunction| - BOOT::|transferSrcPosInfo| BOOT::|isNestedInstantiation| - BOOT::|DomainSubstitutionFunction,Subst| - BOOT::|mkAtree1WithSrcPos| BOOT::|wrapDomainSub| - BOOT::|listInitialSegment| BOOT::|compCategoryItem| - BOOT::|writeLib| - BOOT::|makeFunctorArgumentParameters,findExtrasP| - BOOT::|loadLibIfNecessary| BOOT::|rep| - BOOT::|collectDefTypesAndPreds,addPred| - BOOT::|setMsgPrefix| BOOT::|setMsgCatlessAttr| - BOOT::|getSignatureFromMode| - BOOT::|makeFunctorArgumentParameters,findExtras| - BOOT::|makeFunctorArgumentParameters,findExtras1| - BOOT::|autoLoad| BOOT::|isMacro| BOOT::|readLib| - BOOT::|getValueFromEnvironment| - BOOT::|unloadOneConstructor| - BOOT::|compileCases,FindNamesFor| BOOT::|asTupleNewCode| - BOOT::|macroExpandList| BOOT::|setMsgForcedAttrList| - BOOT::|macSubstituteId| BOOT::|atree2Tree1| - BOOT::|compileCases,isEltArgumentIn| - BOOT::|makeFunctorArgumentParameters,augmentSig| - BOOT::|mkAtree3,fn| BOOT::|macroExpandInPlace| - BOOT::|getErFromDbL| BOOT::|compJoin,getParms| - BOOT::|pfMapParts| BOOT::|erMsgCompare| - BOOT::|compareposns| BOOT::|pfCopyWithPos| - BOOT::|mkCategoryPackage,fn| BOOT::|getArgumentMode| - BOOT:REMFLAG BOOT::|listDecideHowMuch| - BOOT::|throwEvalTypeMsg| BOOT::|splitEncodedFunctionName| - BOOT:QLASSQ BOOT::|decideHowMuch| BOOT::|getArgValue1| - BOOT::|setMsgText| BOOT::|setMsgUnforcedAttrList| - BOOT::|genDomainViewList0| BOOT::|macLambda,mac| - BOOT::|macWhere,mac| - BOOT::|makeFunctorArgumentParameters,fn| - BOOT::|canCacheLocalDomain| - BOOT::|makeCategoryPredicates,fn| - BOOT::|makeCategoryPredicates,fnl| - BOOT::|getArgValueOrThrow| BOOT::|mac0SubstituteOuter| - BOOT::|insertPos| BOOT::|macLambdaParameterHandling| - BOOT::|genDomainViewName| BOOT::|isKeyQualityP| - BOOT::|queueUpErrors| BOOT::|thisPosIsEqual| - BOOT::|getOpArgTypes1| BOOT::|redundant| - BOOT::|argCouldBelongToSubdomain| BOOT::|thisPosIsLess| - BOOT::APPEND-N BOOT::|putFTText| BOOT::CONS-N - BOOT::|getModemap| BOOT::|sameMsg?| BOOT::EVAL-DEFUN - BOOT::|mkOpVec| BOOT::|resolveTCat| - BOOT::PRINT-AND-EVAL-DEFUN BOOT::|AssocBarGensym| - BOOT::|FromTo| BOOT::|compareMode2Arg| - BOOT::|c02affSolve,f| BOOT::|subCopy| - BOOT::|getOpArgTypes,f| BOOT::|isTowerWithSubdomain| - BOOT::|addEmptyCapsuleIfNecessary| BOOT::|constructM| - BOOT:|delete| BOOT::|c02agfSolve,f| BOOT::|bootStrapError| - BOOT::|getOpArgTypes| BOOT::|dqAddAppend| BOOT::|tracelet| - BOOT::/UNTRACE-2 BOOT:|rassoc| BOOT::|resolveTM1| - BOOT::|matchMmSigTar| BOOT::/UNTRACE-1 BOOT::|deepSubCopy| - BOOT::|CONTAINEDisDomain| BOOT::|hasCatExpression| - BOOT::PAIRTRACE BOOT::|spadUntrace| BOOT:LENGTHENVEC - BOOT::|defaultTypeForCategory| BOOT::DEF-IT BOOT:|breaklet| - BOOT::|mmCatComp| BOOT::|mergeSubs| BOOT::DEF-LET - BOOT::|hasCaty1| BOOT:STRINGPAD BOOT::|mkObjWrap| - BOOT:TRUNCLIST BOOT::|position1| BOOT::DEF-IS2 - BOOT::|defLET| BOOT::|defLETdcq| - BOOT::|sortAndReorderDmpExponents| BOOT::WHDEF - BOOT::|removeListElt| BOOT::|everyNth| BOOT::LET_ERROR - BOOT::|defIS| BOOT::DEF-IS-REV VMLISP:SETDIFFERENCE - BOOT::DEF-SELECT2 BOOT::DEF-SELECT1 BOOT::|addInformation| - BOOT::|varIsOnlyVarInPoly| BOOT::|makeCategoryPredicates| - BOOT::|compDefWhereClause,addSuchthat| VMLISP:DIVIDE - BOOT::NOTEQUALLIBS VMLISP:GETL BOOT::|modemapPattern| - BOOT::|removeVectorElt| BOOT::GETALIST - BOOT::|buildDatabase| BOOT::|mathPrint1| - BOOT::|getInverseEnvironment| BOOT::|getSuccessEnvironment| - BOOT::|getSystemModemaps| BOOT::|insertWOC| - BOOT::|getModemapsFromDatabase| BOOT::|removeCoreModemaps| - BOOT::|SubstWhileDesizing| BOOT::|resolveTTUnion| - BOOT::|resolveTTEq| BOOT::|rightBindingPowerOf| - BOOT::/GETOPTION BOOT::|resolveTTCC| - BOOT::|leftBindingPowerOf| BOOT::|stackSemanticError| - BOOT::/GETTRACEOPTIONS BOOT::|resolveTTRed| - BOOT::/TRACELET-PRINT BOOT::|resolveTTSpecial| - BOOT::MONITOR-PRINT BOOT::|compareTT| BOOT::|opWidth| - BOOT::|isConstantId| BOOT::|acceptableTypesToResolve| - BOOT::|resolveTCat1| BOOT::|getConditionsForCategoryOnType| - BOOT::|resolveTTAny| BOOT::|resolveTMOrCroak| - BOOT::|outputMapTran0| BOOT::|spliceTypeListForEmptyMode| - BOOT::MONITOR-EVALTRAN BOOT::|constructTowerT| - BOOT::|throwKeyedMsg| BOOT::|canCoerceExplicit2Mapping| - BOOT::|term1RWall| BOOT::|absolutelyCannotCoerce| - BOOT::|rassocSub| BOOT::|coerceOrConvertOrRetract| - VMLISP:NCONC2 BOOT::|term1RW| BOOT::|coerceOrRetract| - BOOT::|resolveTMTaggedUnion| BOOT::|canCoerceUnion| - BOOT::|acceptableTypesToResolve1| BOOT::|canCoercePermute| - BOOT::|computeTTTranspositions| BOOT::|resolveTM2| - BOOT::|newCanCoerceCommute| BOOT::|coerceIntCommute| - BOOT::|resolveTMRed| BOOT::|coerceInt1| BOOT::|pmatch| - BOOT::/TRACE-1 BOOT::|resolveTMEq| BOOT::|getUnionMode| - BOOT::|resolveTMEq1| BOOT::|isUnionMode| - BOOT::|coerceInt2Union| BOOT::|resolveTMSpecial| - BOOT::|coerceIntFromUnion| VMLISP:REMAINDER - BOOT::|resolveTMRecord| BOOT::|resolveTMUnion| - BOOT::|isFunction| BOOT::|coerceIntAlgebraicConstant| - BOOT::|coerceIntTower| BOOT::|coerceRetract| - BOOT::|compareTypeLists| BOOT::|modifyModeStack| - BOOT::|replaceSymbols| BOOT::|coerceIntTableOrFunction| - BOOT::|isDomainForm| BOOT::|coerceIntSpecial| - BOOT::/TRACELET-2 BOOT::|SubstWhileDesizingList| - BOOT::|coerceIntPermute| BOOT::|getProplist| - BOOT::|coerceBranch2Union| BOOT::ASSOCIATER - BOOT::/TRACELET-1 BOOT::|retractByFunction| - BOOT::|constructT| BOOT::MONITOR-PRINARGS-1 - BOOT::|outputComp| VMLISP:GGREATERP BOOT::|isDomainInScope| - BOOT::|canConvertByFunction| VMLISP:CGREATERP - BOOT::|canCoerceLocal| BOOT::|maxSuperType| - BOOT::|canCoerceTower| BOOT::/UPDATE-1 BOOT::|coerceInt0| - BOOT::|objSetMode| VMLISP:SORTBY BOOT::MONITOR-GETVALUE - VMLISP:|member| BOOT::MONITOR-EVALTRAN1 - BOOT::|coerceIntByMapInner| BOOT::|getConstantFromDomain| - BOOT::|valueArgsEqual?| BOOT::|traceDomainConstructor| - BOOT::|coerceIntByMap| BOOT::|equalZero| - BOOT::|replaceLast| BOOT::|coerceIntTest| VMLISP:ADDOPTIONS - BOOT::|isSubTowerOf| BOOT::|starstarcond| BOOT::|equalOne| - VMLISP:|assoc| VMLISP:SETSIZE BOOT::|evalSharpOne| - VMLISP:EFFACE BOOT::|canCoerceCommute| - BOOT::|clearDependentMaps| BOOT::|constantInDomain?| - VMLISP:EMBED BOOT::|translateMpVars2PVars| - VMLISP:LEXGREATERP VMLISP:RPLPAIR - BOOT::|addDmpLikeTermsAsTarget| VMLISP:HPUT* - BOOT::|genMpFromDmpTerm| VMLISP:STRING2ID-N - BOOT::|htMakeTemplates,substLabel| BOOT::|doDoitButton| - VMLISP:$FINDFILE BOOT::|keyedMsgCompFailure| BOOT::|objNew| - BOOT::|putValue| BOOT::|getAtree| BOOT::|putModeSet| - VMLISP:$SHOWLINE VMLISP:RDROPITEMS BOOT::|bottomUpType| - BOOT::|bottomUpIdentifier| BOOT::|transferPropsToNode| - BOOT::|getArgValue| BOOT::|bottomUpCompilePredicate| - BOOT::|bottomUpPredicate| BOOT::|putTarget| - BOOT::|getMinimalVariableTower| - BOOT::|computeTypeWithVariablesTarget| - BOOT::|removeUnionsAtStart| BOOT::|pushDownOp?| - BOOT::|e02gafSolve,fc| BOOT::|e02gafSolve,fr| - BOOT::|sayIntelligentMessageAboutOpAvailability| - BOOT::|getBasicMode0| BOOT::|mkObjCode| - BOOT::|intCodeGenCOERCE| BOOT::|canCoerceByMap| - BOOT::|canCoerceByFunction| BOOT::|isSubDomain| - BOOT::|absolutelyCanCoerceByCheating| - BOOT::|e04ucfSolve,fa| BOOT::|coerceCommuteTest| - BOOT::|asyGetAbbrevFromComments,fn| BOOT::|asySplit| - BOOT::|asyWrap| BOOT::GETDATABASE - BOOT::|asyAbbreviation,chk| BOOT::|asyTypeJoinPart| - BOOT::|setVector4part3| BOOT::|sublisProp| - BOOT::|setVector12,freeof| BOOT::|setVector4Onecat,form| - BOOT::|asyDisplay| BOOT::ERROR-FORMAT - BOOT::|asyAbbreviation| BOOT::|asyCattranConstructors| - BOOT::|DomainPrint| BOOT::|makeSF| BOOT::|asySimpPred| - BOOT::|setVector0| BOOT::|setVector3| BOOT::DIVIDE2 - BOOT::QUOTIENT2 BOOT::|htpSetName| BOOT::|sort| - BOOT::|defLET2| BOOT::|defLetForm| BOOT::|asyMapping| - BOOT::|defIS1| BOOT::|asySig| BOOT::|defISReverse| - BOOT::|addCARorCDR| BOOT::|defLET1| - BOOT::|asyExportAlist,fn| BOOT::|displayDatabase,fn| - BOOT::|quickAnd| BOOT::|asyCattranSig| BOOT::|asySigTarget| - BOOT::|asyMkSignature| BOOT::|asCategoryParts,build| - BOOT::/COMPINTERP BOOT::|unabbrevRecordComponent| - BOOT::|unabbrev1| BOOT::|makeByteWordVec2| - BOOT::|condAbbrev| BOOT::|unabbrevUnionComponent| - BOOT::|constructorNameConflict| BOOT::SPAD-PRINTTIME - BOOT::|htpLabelType| BOOT::|errorSupervisor| - BOOT::|sayErrorly1| BOOT::INTEGER-BIT BOOT::|chebeval| - BOOT::|rPsi| BOOT::|cpsireflect| BOOT::|cPsi| - BOOT::|BesselJRecur| BOOT::|substFromAlist| - BOOT::|BesselJAsymptOrder| BOOT::|BesselJAsympt| - BOOT::|PsiXotic| BOOT::|f01| BOOT::|brutef01| - BOOT::RBESSELJ BOOT::CPSI BOOT::RPSI BOOT::CHYPER0F1 - BOOT::CBESSELI BOOT::RBESSELI BOOT::CBESSELJ - BOOT::|formatLazyDomainForm| BOOT::|formatLazyDomain| - BOOT::|getDomainSigs1| BOOT::|showDomainsOp1| - BOOT::|devaluateSlotDomain| BOOT::|getDomainRefName| - BOOT::|andDnf| BOOT::|ordUnion| BOOT::|coafAndDnf| - BOOT::|orDel| BOOT::|orDnf| BOOT::|dnfContains,fn| - BOOT::|andReduce| BOOT::|simpBoolGiven| BOOT::|dnfContains| - BOOT::|coafAndCoaf| BOOT::|ordIntersection| - BOOT::|ordSetDiff| BOOT::|coafOrDnf| BOOT::|predCircular| - BOOT::|clearAllSlams,fn| BOOT::|assocCircular| - BOOT::|recurrenceError| BOOT::|countCircularAlist| - BOOT::|displaySetVariableSettings| BOOT::|sayCacheCount| - BOOT::|chebstareval| BOOT::|BesselIAsymptOrder| - BOOT::|horner| BOOT::|BesselKAsymptOrder| BOOT::|cbeta| - BOOT::|PsiAsymptotic| BOOT::|PsiEps| BOOT::|FloatError| - BOOT::|cgammaG| BOOT::|besselIback| BOOT::|rPsiW| - BOOT::|firstNonDelim| BOOT::|chebf01| BOOT::|BesselJ| - BOOT::|BesselI| BOOT::|grepSplit| BOOT::|grepConstruct1| - BOOT::|grepConstructDo| BOOT::|mkGrepPattern1,h| - BOOT::|pfCoerceto| BOOT::|stripOffSegments| - BOOT::|pfFromdom| BOOT::|pfRetractTo| BOOT::|pfRestrict| - BOOT::|mkGrepPattern1,split| BOOT::|testInput2Output| - BOOT::|hyperize| BOOT::|testPrin| BOOT::|grepCombine| - BOOT::|subMatch| BOOT::|bcAbb| BOOT::|lfrinteger| - BOOT::|getFortranType| BOOT::|wl| BOOT::|scanIgnoreLine| - BOOT::|makeVector| BOOT::|htPred2English,fn| BOOT::|posend| - BOOT::|functionAndJacobian,DF| BOOT::|isString?| - BOOT::|bcOpTable| BOOT::|xdrOpen| BOOT::|scanExponent| - BOOT::|scanCheckRadix| BOOT::|coerceUn2E| - BOOT::|inFirstNotSecond| BOOT::|coerceVal2E| - BOOT::|EnumPrint| BOOT::|scanInsert| VMLISP::WRAP - BOOT::|RecordPrint| BOOT::|coerceRe2E| - BOOT::|syIgnoredFromTo| BOOT::|sySpecificErrorHere| - BOOT::|pfTree| BOOT::|makeList| - BOOT::|setVector4Onecat,Supplementaries| BOOT::|pfSuch| - BOOT::|compCategories1| BOOT::|pfParen| BOOT::|pfPretend| - BOOT::|pfComDefinition| BOOT::|pfMLambda| - BOOT::|resolvePatternVars| BOOT::|cons5| - BOOT::|makeMissingFunctionEntry| BOOT::|pfHide| - BOOT::|setVector5| BOOT::|d02kefSolve,fd| - BOOT::|mkVectorWithDeferral| BOOT::|d02kefSolve,fe| - BOOT::|d02gbfSolve,ff| BOOT::|pfBracketBar| - BOOT::|d02gbfSolve,fg| BOOT::|pfIdPos| BOOT::|ProcessCond| - BOOT::|DescendCodeAdd| BOOT::|LookUpSigSlots| - BOOT::|DomainPrintSubst| BOOT::|d02gbfSolve,fc| - BOOT::|partPessimise| BOOT::|d02gbfSolve,fd| - BOOT::|pfBraceBar| BOOT::|sublisProp,inspect| - BOOT::|pfTagged| BOOT::|HasCategory| BOOT::|d02gbfSolve,fa| - BOOT::|HasSignature| BOOT::|d02gbfSolve,fb| - BOOT::|HasAttribute| BOOT::|pfWDeclare| - BOOT::|InvestigateConditions,Conds| BOOT::|pfBracket| - BOOT::|pfDWhere| BOOT::|NewbFVectorCopy| - BOOT::|DescendCodeVarAdd| BOOT::|getDomainView| - BOOT::|pfBrace| BOOT::|d02gafSolve,fe| - BOOT::|d02gafSolve,fc| BOOT::|pfOr| BOOT::|pfAnd| - BOOT::|d03edfSolve,fb| BOOT::|pfTLam| - BOOT::|stringChar2Integer| BOOT::|reshape| - BOOT::|e01dafSolve,h| BOOT::|hashCombine| - BOOT::|e01dafSolve,k| BOOT::|hashType| VMLISP:$REPLACE - VMLISP:UNIONQ BOOT::|spadSysBranch| - BOOT::|htSystemVariables,gn| BOOT::|postFlatten| - BOOT::|gatherGlossLines| VMLISP:|intersection| - BOOT::|postFlattenLeft| BOOT::|postTranSegment| - VMLISP:DEFINE-FUNCTION BOOT::SEGMENT BOOT::|pfTyped| - BOOT::|postScriptsForm| BOOT::|htCheckList| - BOOT::|htSetvarDoneButton| BOOT::|htMakePathKey,fn| - BOOT::|npLeftAssoc| VMLISP:SETDIFFERENCEQ - BOOT::|htMarkTree| BOOT::|pfCollect| BOOT::|pfQualType| - BOOT::|deltaContour| BOOT::ADD-PARENS-AND-SEMIS-TO-LINE - BOOT::|getUniqueSignature| VMLISP:INTERSECTIONQ - BOOT::|AMFCR,redefinedList| BOOT::|putDomainsInScope| - BOOT::INITIAL-SUBSTRING BOOT::|compFormMatch,match| - BOOT::STOREBLANKS BOOT::|compFormMatch| BOOT::ESCAPED - BOOT::PARSEPILES BOOT::|addNewDomain| BOOT::|htDoNothing| - BOOT::|AMFCR,redefined| BOOT::|domainMember| - BOOT::|e04ycfSolve,fb| BOOT::MONITOR-WRITE - BOOT::|htpSetDomainPvarSubstList| BOOT::|coerceByModemap| - BOOT::|htpLabelFilter| BOOT::|profileDisplayOp| - BOOT::|htpLabelSpadType| BOOT::|pfAssign| - BOOT::|htpSetDomainVariableAlist| BOOT::|convertOrCroak| - BOOT::|htpSetDomainConditions| - BOOT::|intersectionEnvironment| BOOT::|pfRule| - BOOT::|coerceExit| BOOT::|resolveTM| - BOOT::|autoCoerceByModemap| BOOT::|coerceExtraHard| - BOOT::|hasType| BOOT::|getConstructorMode| - BOOT::|getConstructorFormOfMode| BOOT::|pfWhere| - BOOT::|coerceHard| BOOT::|npRightAssoc| - BOOT::|coerceSubset| BOOT::|reportCircularCacheStats| - BOOT::|mkCircularCountAlist| BOOT::|pfPushMacroBody| - BOOT::|pfMacro| BOOT::|coerceEasy| BOOT::|keyedSystemError| - BOOT::|chaseInferences| BOOT::|say2PerLineWidth| - BOOT::|getFormModemaps| BOOT::|prEnv,tran| BOOT::|qArg| - BOOT::|npMissingMate| BOOT::|canFit2ndEntry| - BOOT::|sayKeyedMsgLocal| BOOT::|mkUnion| - BOOT::|printEnv,tran| BOOT::|listTruncate| - BOOT::|newHasTest| BOOT::|makeCategoryForm| - BOOT::ADDOPERATIONS BOOT::ASHARPMKAUTOLOADFUNCTION - BOOT::|HGETandCount| BOOT::|consForHashLookup| - BOOT::|sayKeyedMsgAsTeX| BOOT::|SymMemQ| BOOT::|addToSlam| - BOOT::|throwPatternMsg| BOOT::DELDATABASE - BOOT::|sayPatternMsg| BOOT::|getKeyedMsgInDb| - BOOT::|lassocShift| BOOT::|htMakeTemplates| - BOOT::|isKeyedMsgInDb| BOOT::|patternVarsOf1| - BOOT::GETCONSTRUCTOR BOOT::|pfFromDom| BOOT::|symEqual| - BOOT::|domainEqualList| BOOT::SET-LIB-FILE-GETTER - BOOT::|pfApplication| BOOT::|rightJustifyString| - BOOT::|remHashEntriesWith0Count,fn| - BOOT::|globalHashtableStats| BOOT::|lassocShiftQ| - BOOT::|pfWDec| BOOT::|pileForest| BOOT::|canCoerce;| - BOOT::|pileForest1| BOOT::|canCoerce1| BOOT::DAASENAME - BOOT::|pileTree| BOOT::|eqpileTree| BOOT::|pileCtree| - BOOT::|resolveTT;| BOOT::WRAPDOMARGS BOOT::|evalCategory| - BOOT::|replaceSharps| BOOT::|ofCategory| - BOOT::|canCoerceFrom;| BOOT::|canCoerceFrom0| - BOOT::|isEqualOrSubDomain| BOOT::|hasCorrectTarget| - BOOT::MAKE-DATABASES BOOT::|resolveTT1| - BOOT::|applyWithOutputToString| BOOT::|isDomainSubst,fn| - BOOT::|isDomainSubst,findSub| BOOT::|insertModemap| - BOOT::|makeBigFloat| BOOT::REDUCTION-PRINT - BOOT::|mkAlistOfExplicitCategoryOps,fn| BOOT::REMOVER - BOOT::STACK-LOAD BOOT::ESCAPE-KEYWORDS BOOT::|allLASSOCs| - BOOT::MAKE-PARSE-FUNCTION1 BOOT::|pairList| - BOOT::INITIAL-SUBSTRING-P BOOT::|finalizeDocumentation,fn| - BOOT::|formatOpSignature| BOOT::|sayKeyedMsg| - BOOT::|transDocList| BOOT::MAKE-PARSE-FUNC-FLATTEN - BOOT::|recordAttributeDocumentation| - BOOT::|recordDocumentation| - BOOT::|recordSignatureDocumentation| BOOT::|macroExpand| - BOOT::|checkRewrite| BOOT::|checkComments| - BOOT::|checkExtract| BOOT::|checkTrim| - BOOT::|spadSysChoose| BOOT::|testError| - BOOT::|spadtestValueHook| BOOT::|checkIsValidType,fn| - BOOT::|transDoc| BOOT::|checkIndentedLines| - BOOT::SAYBRIGHTLY1 BOOT::|pvarPredTran| BOOT::|mkAbbrev| - BOOT::|addSuffix| BOOT::|processPackage,opt| - BOOT::|subTree| BOOT::|mkRepititionAssoc,mkRepfun| - BOOT::|setPackageLocals| BOOT::|UnionPrint| - BOOT::|JoinInner| BOOT::|objNewWrap| - BOOT::|coerceByFunction| BOOT::|MappingPrint| - BOOT::|parseTypeEvaluateArgs| BOOT::|createEnum| - BOOT::|parseTranCheckForRecord| BOOT::|installConstructor| - BOOT::|AncestorP| BOOT::|SourceLevelSubset| - BOOT::|JoinInner,AddPredicate| BOOT::|mkAnd| BOOT::|mkOr| - BOOT::|SigListUnion| BOOT::|PredImplies| - BOOT::|DescendantP| BOOT::|mkOr2| BOOT::|SigOpsubsume| - BOOT::|SourceLevelSubsume| BOOT::|compMakeCategoryObject| - BOOT::|MachineLevelSubset| BOOT::|MachineLevelSubsume| - BOOT::|SigListOpSubsume| BOOT::|SigEqual| - BOOT::|SigListMember| BOOT::|CategoryPrint| BOOT::|mkAnd2| - BOOT::|categoryParts,build| - BOOT::|catPairUnion,addConflict| - BOOT::|clearCategoryTable1| BOOT::|parseCases,casefn| - BOOT::|hasCat| BOOT::|superSub| BOOT::|encodeCategoryAlist| - BOOT::|simpCategoryOr| BOOT::|tempExtendsCat| - BOOT::CONVERSATION1 BOOT::|addDomainToTable| - BOOT::|mkCategoryOr| BOOT::/EMBED-Q - BOOT::|formalSubstitute| - BOOT::|updateCategoryTableForDomain| - BOOT::|simpCatHasAttribute| BOOT::|testExtend| - BOOT::|mergeOr| BOOT::|newHasTest,fn| BOOT::|simpOrUnion1| - BOOT::|updateCategoryTable| BOOT::|substDomainArgs| - BOOT::|NRTreplaceLocalTypes| BOOT::|dcOpPrint| - BOOT::|predicateBitIndex,pn| BOOT::|augmentPredCode| - BOOT::|mungeAddGensyms| BOOT::|htSayExpose| - BOOT::|makeCompactSigCode| BOOT::|evalDomainOpPred,process| - BOOT::|makeGoGetSlot| BOOT::|dbShowOpHeading| - BOOT::|makePrefixForm| BOOT::|dbShowOperationLines| - BOOT::|buildBitTable,fn| BOOT::|makeCompactDirect1| - BOOT::|augmentPredVector| BOOT::|simpOrDumb| - BOOT::|dbReduceByForm| BOOT::|dbContrivedForm| - BOOT::|dbReduceByOpSignature| BOOT::|dcOpLatchPrint| - BOOT::|reduceByGroup| BOOT::|dbGetCondition| - BOOT::|dbGetOrigin| BOOT::|koCatOps| BOOT::|modemap2Sig| - BOOT::|substInOrder| BOOT::|pairlis| BOOT::|getDcForm| - BOOT::|koCatAttrsAdd| BOOT::|getSubstInsert| - BOOT::|integerAssignment2Fortran1| BOOT::|koOps,fn| - BOOT::|getAllModemapsFromDatabase| BOOT::|koOps,merge| - BOOT::|exp2FortOptimizeCS1,pushCsStacks| - BOOT::|fortFormatTypes| BOOT::|segment2| BOOT::|whoUses| - BOOT::|fortranifyIntrinsicFunctionName| - BOOT::|expression2Fortran1| BOOT::|dispfortarrayexp| - BOOT::|fortFormatIfGoto| BOOT::|koCatAttrs| - BOOT::|dbGetContrivedForm| BOOT::|dispfortexpj| - BOOT::|assignment2Fortran1| BOOT::|beenHere| - BOOT::|dispfortexpf| BOOT::|htSayConstructor| - BOOT::|stringPrefix?| VMLISP::PUTINDEXTABLE - VMLISP::WRITE-INDEXTABLE BOOT::|NRTsetVector4Part2| - BOOT::|consDomainName| BOOT::|NRTencode| - BOOT::|consDomainForm| BOOT::|deltaTran| BOOT::|consSig| - BOOT::|NRTaddToSlam| BOOT::|deepChaseInferences| - BOOT::|c06gsfSolve,g| BOOT::|c06gsfSolve,f| - BOOT::|NRTdescendCodeTran| BOOT::|mergeAppend| - BOOT::|NRTgetLocalIndex1| BOOT::|vectorLocation| - BOOT::|c06frfSolve,fy| BOOT::|c06frfSolve,gy| - BOOT::|c06frfSolve,fx| BOOT::|c06frfSolve,gx| - BOOT::|c06gqfSolve,g| BOOT::|c06gqfSolve,f| - BOOT::|c06fpfSolve,f| BOOT::|c06fpfSolve,g| - BOOT::|c06fqfSolve,f| BOOT::|c06fqfSolve,g| - BOOT::|c06fufSolve,fy| BOOT::|c06fufSolve,gy| - BOOT::|c06fufSolve,fx| BOOT::|c06fufSolve,gx| - BOOT:|ListIsLength?| BOOT:|ListMemberQ?| BOOT:|ListMember?| - BOOT:|ListRemoveQ| BOOT:|ListNRemoveQ| BOOT:|ListUnion| - BOOT:|ListUnionQ| BOOT:|ListIntersection| - BOOT:|ListIntersectionQ| BOOT:|ListAdjoin| - BOOT:|ListAdjoinQ| BOOT:|AlistAssoc| BOOT:|AlistRemove| - BOOT:|AlistAssocQ| BOOT:|AlistRemoveQ| BOOT:|AlistAdjoinQ| - BOOT:|AlistUnionQ| BOOT::|rePackageTran| - BOOT::|ncINTERPFILE| BOOT:|TableUnset| - BOOT::|updateSymbolTable| FOAM:|printDFloat| - FOAM:|printSFloat| FOAM:|fputs| FOAM:|printBInt| - FOAM:|fputc| FOAM:|printSInt| FOAM:|printString| - FOAM:|printChar| BOOT::|incAppend| BOOT::|segment1| - BOOT::|intersectionContour,unifiable| BOOT::|getStatement| - BOOT::|deltaContour,contourDifference| - BOOT::|makeCommonEnvironment,makeSameLength| BOOT::DELLASOS - BOOT::|addContour,fn| BOOT::|fortranifyFunctionName| - BOOT::|displayOpModemaps| BOOT::|fortFormatTypes1| - BOOT::|f02aefSolve,l| FOAM:|PtrMagicEQ| BOOT::|hasOption| - BOOT::|intersectionContour| BOOT::|commandErrorIfAmbiguous| - BOOT::|intersectionContour,computeIntersection| - BOOT::|f04adfSolve,f| BOOT::|f04adfSolve,g| - BOOT::|makeCommonEnvironment| BOOT::|makeLiteral| - BOOT::|isLiteral| BOOT::|f04mcfSolve,f| - BOOT::|f04mcfSolve,g| BOOT::|f04qafSolve,h| BOOT::|mapInto| - BOOT::|f04qafSolve,k| BOOT::|stringMatches?| - BOOT::|basicMatch?| BOOT::|optionError| - BOOT::|displayProperties| BOOT::|mkErrorExpr,highlight| - BOOT::|f04adfSolve,fb| BOOT::|mkErrorExpr,highlight1| - BOOT::|coerce| BOOT::|numOfOccurencesOf| BOOT::|sublisR| - BOOT::|compMapCond''| BOOT::|getAndSay| - BOOT::|intersectionContour,interProplist| BOOT::|position| - BOOT::|satDownLink| BOOT::|getmodeOrMapping| - BOOT::|intersectionContour,compare| - BOOT::|intersectionContour,modeCompare| - BOOT::|getAbbreviation| BOOT::|koAttrs| - BOOT::|GEQNSUBSTLIST,GSUBSTinner| BOOT::|isCategoryForm| - BOOT::|resolve| BOOT::|convert| BOOT::|flatten| - BOOT::|f04jgfSolve,f| BOOT::|npsynonym| - BOOT::|f04jgfSolve,g| BOOT::|getImports,import| - BOOT::|f04arfSolve,f| BOOT::|f04arfSolve,g| - BOOT::|modeEqual| BOOT::|f04mbfSolve,l| - BOOT::|displayWarning| BOOT::|f04mbfSolve,o| - BOOT::|addContour| BOOT::|f04asfSolve,f| - BOOT::|f04asfSolve,g| BOOT::|deleteAssoc| - BOOT::|purgeNewConstructorLines| - BOOT::|filterListOfStrings| BOOT::|asyDocumentation,fn| - BOOT::|satisfiesRegularExpressions| BOOT::|displayProplist| - BOOT::|transformAndRecheckComments| - BOOT::|displaySemanticError| BOOT::|asySignature| - BOOT::|f04mbfSolve,h| BOOT::|asyTypeUnitDeclare| - BOOT::|f04mbfSolve,k| BOOT::|asyCatSignature| - BOOT::|dbSpreadComments| BOOT::|computeAncestorsOf| - BOOT::|descendantsOf| BOOT::|f04atfSolve,f| - BOOT::|f04atfSolve,g| BOOT::|f04adfSolve,gb| - BOOT::|reportOpsFromLisplib| BOOT::|f07fdfSolve,fa| - BOOT::|f07fdfSolve,fb| BOOT::|f07aefSolve,fa| - BOOT::|f07aefSolve,faa| BOOT::|f07adfSolve,fa| - BOOT::|f07adfSolve,fb| BOOT::|childArgCheck| - BOOT::|f07aefSolve,fb| BOOT::POSN1 BOOT::|assocCar| - BOOT::|childAssoc| BOOT::|f07fefSolve,fb| - BOOT::|f07fefSolve,fbb| BOOT::|ancestorsAdd| - BOOT::|f07fefSolve,fa| BOOT::|quickOr| - BOOT::|f07fefSolve,faa| BOOT::|f07aefSolve,fbb| - BOOT::|explodeIfs,gn| BOOT::|f01qdfSolve,fa| - BOOT::|f01qdfSolve,ga| BOOT::|dbGatherDataImplementation| - BOOT::|dbMakeSignature| BOOT::|dbExposed?| - BOOT::|getRegistry| BOOT::|opAlistCount| - BOOT::|f01rdfSolve,gb| BOOT::|bcStarSpaceOp| - BOOT::|evalDomainOpPred,convert| BOOT::|f02aefSolve,f| - BOOT:|Sort| BOOT::|f02aefSolve,g| BOOT:|SortInPlace| - BOOT::|evalDomainOpPred,evpred| BOOT::|f02aefSolve,h| - BOOT::|evalDomainOpPred,evpred1| BOOT::|f02abfSolve,f| - BOOT::|f02abfSolve,g| BOOT::|f02aafSolve,f| - BOOT::|f02aafSolve,g| BOOT::|evalDomainOpPred| - BOOT::|getDomainOpTable,memq| BOOT::|f02ajfSolve,h| - BOOT::|f02ajfSolve,l| BOOT::|superMatch?| - BOOT::|f02affSolve,f| BOOT::|f02affSolve,g| - BOOT:|ByteFileWriteLine| BOOT::NREVERSE-N - BOOT::|f02adfSolve,h| BOOT::|f02adfSolve,l| - FOAM:|fiSetDebugger| BOOT::TRUNCLIST-1 - BOOT::|f02bjfSolve,h| BOOT::-REDUCE-OP - BOOT::|f02bjfSolve,l| BOOT::OR2 BOOT::|f02axfSolve,h| - BOOT::AND2 BOOT::|f02axfSolve,l| BOOT::|f02ajfSolve,f| - BOOT::REPEAT-TRAN BOOT::|f02ajfSolve,g| BOOT::MKPFFLATTEN - BOOT::|f02akfSolve,h| BOOT:|StreamSetPosition| - BOOT::|f02akfSolve,l| BOOT::MKPF1 BOOT::|f02axfSolve,f| - BOOT::|f02axfSolve,g| BOOT::-REPEAT BOOT::|f02xefSolve,fb| - BOOT::|CONTAINED,EQUAL| BOOT::|f02xefSolve,gb| - BOOT::|CONTAINED,EQ| BOOT::|f02awfSolve,h| - BOOT::|f02awfSolve,l| BOOT::|kPageArgs| - BOOT::|dbSubConform| BOOT::|f02akfSolve,f| - BOOT::|f02akfSolve,g| BOOT:|PathnameWithType| - BOOT::MARKHASH BOOT:|PathnameWithDirectory| - BOOT::|f02bjfSolve,f| BOOT::|f02bjfSolve,g| - BOOT::|f02adfSolve,f| BOOT::|f02adfSolve,g| BOOT::|,MIN| - BOOT:|PathnameWithinDirectory| - BOOT::|domainDescendantsOf,jfn| - BOOT::|domainDescendantsOf,catScreen| BOOT::|,MAX| - BOOT:|PathnameWithinOsEnvVar| BOOT::LEXLESSEQP - BOOT::|,DIFFERENCE| BOOT::GLESSEQP BOOT::MAKE-INIT-VECTOR - BOOT::|,TIMES| BOOT::|,PLUS| BOOT::|f02awfSolve,f| - BOOT::|f02awfSolve,g| BOOT::SUBB BOOT::|getCDTEntry| - BOOT::|f02xefSolve,fa| BOOT::|f02xefSolve,ga| - BOOT::|stuffSlots| BOOT::|domainDescendantsOf| BOOT::DO_LET - BOOT::|f02agfSolve,f| BOOT:|CsetMember?| - BOOT::|f02agfSolve,g| BOOT::|measureCommon,fn| - BOOT:|CsetUnion| BOOT::|f02wefSolve,fb| - BOOT::|f02wefSolve,gb| BOOT::|deleteWOC| - BOOT::|f02bbfSolve,f| BOOT::|next| BOOT::|f02bbfSolve,g| - BOOT::|suffix?| BOOT::|list2LongerVec| - BOOT::|f02wefSolve,fa| BOOT::|mkCurryFun| - BOOT::|f02wefSolve,ga| BOOT::|logicalMatch?| - BOOT::|subCopy0| BOOT::|patternCheck,wild| - BOOT:|StringFromToEnd| BOOT::|beforeAfter| - BOOT::|deepSubCopyOrNil| BOOT::|patternCheck,pos| - BOOT:|StringGreater?| BOOT::|deepSubCopy0| BOOT::|prefix?| - BOOT:|StringPrefix?| BOOT::|subCopyOrNil| - BOOT::|htpSetInputAreaAlist| BOOT::|termRW1| - BOOT::|processInteractive| BOOT::|termRW| - BOOT::|maskMatch?| BOOT::|tdAdd| BOOT::|filterByTopic| - BOOT::|addTopic2Documentation| BOOT::|addStats| - BOOT::|transferCodeCon| BOOT::|compileCases| - BOOT::|transferClassCodes| BOOT::|addArgumentConditions| - BOOT::|NRTassignCapsuleFunctionSlot| - BOOT::|reportSpadTrace| BOOT::BVEC-NOR BOOT::BVEC-NAND - BOOT::|addDomain| BOOT::|giveFormalParametersValues| - BOOT::PRINT-DEFUN BOOT::|augmentTraceNames| - BOOT::|stripOffSubdomainConditions| - BOOT::|untraceDomainLocalOps| BOOT::TRANSLABEL1 - BOOT::|getOption| BOOT::TRANSLABEL BOOT::|traceOptionError| - BOOT::GET-GLIPH-TOKEN BOOT::|funfind,LAM| - BOOT::|mergePathnames| BOOT::|subTypes| BOOT::|lassocSub| - BOOT::|dbWordFrom| BOOT::|commandUserLevelError| - BOOT::|applyGrep| BOOT::|htButtonOn?| - BOOT::|generalSearchString| BOOT::|zsystemdevelopment1| - BOOT::|grepForAbbrev| BOOT::|match?| BOOT::|commandError| - BOOT::|optionUserLevelError| BOOT::|firstDelim| BOOT::/READ - BOOT::|kciReduceOpAlist| BOOT::|dbInfoTran| - BOOT::|koPageInputAreaUnchanged?| BOOT::|dbInfoWrapOrigin| - BOOT::|insert| BOOT::|dbInfoSigMatch| BOOT::|ancestorsOf| - BOOT::|compIterator| BOOT::|getIdentity| - BOOT::|augmentHasArgs| BOOT::|processInteractive1| - BOOT::|recordAndPrint| BOOT::|interpretTopLevel| - BOOT::|substituteSegmentedMsg| - BOOT::|dbSpecialExpandIfNecessary| BOOT::|sameUnionBranch| - BOOT::|htpSetPageDescription| BOOT::|testBitVector| - BOOT::|dbShowConsDoc| BOOT::|printTypeAndTimeNormal| - BOOT::|satTypeDownLink| BOOT::|printTypeAndTimeSaturn| - BOOT::|mkDocLink| BOOT::|addParameterTemplates| - BOOT::|hasPair| BOOT::|htpAddToPageDescription| - BOOT::|getAliasIfTracedMapParameter| BOOT::|pfAbSynOp?| - BOOT::|printTypeAndTime| BOOT::|phReportMsgs| - BOOT::|untraceDomainConstructor,keepTraced?| - BOOT::|htpButtonValue| BOOT::|htSayConstructorName| - BOOT::|getMapSig| BOOT::|spadTrace,isTraceable| - BOOT::|removeOption| BOOT::|screenLocalLine| - BOOT::|undoSteps| BOOT::|agg| BOOT::|diffAlist| - BOOT::|undoSingleStep| BOOT::|htSayBind| - BOOT::|bcConstructor| BOOT::|checkArgs| - BOOT::SPADTAGS-FROM-DIRECTORY BOOT::|matSuperList1| - BOOT::|getBindingPowerOf| BOOT::|matSubList1| - BOOT::|matWList1| BOOT::NAG-FILES BOOT::|htpLabelDefault| - BOOT::GET-NAG-CHAPTER BOOT::|setNAGBootAutloadProperties| - BOOT::|htpLabelErrorMsg| BOOT::|setBootAutloadProperties| - BOOT::|setUpDefault| BOOT::|setBootAutoLoadProperty| - BOOT::|mkBootAutoLoad| BOOT::|matWList| VMLISP::ECQEXP - BOOT::|npTypedForm1| BOOT::|htMakeDoitButton| BOOT::|prnd| - BOOT::|reportAO| BOOT::BVEC-XOR BOOT::BVEC-OR - VMLISP::DCQEXP BOOT::BVEC-AND BOOT::BVEC-GREATER - BOOT::BVEC-EQUAL BOOT::BVEC-CONCAT BOOT::|stringLE1| - BOOT::BVEC-MAKE-FULL BOOT::|scylla| BOOT::|mkSuperSub| - BOOT::|EqualBarGensym| BOOT::|pfReturn| BOOT::|pfSpread| - BOOT::|npTypedForm| BOOT::|after| - BOOT::|optCatch,changeThrowToGo| - BOOT::|optCatch,hasNoThrows| - BOOT::|optCatch,changeThrowToExit| - BOOT::|optimizeFunctionDef,replaceThrowByReturn| - BOOT::|optCallSpecially,lookup| BOOT::|EqualBarGensym,fn| - BOOT::|pfLp| BOOT::|optimizeFunctionDef,fn| - BOOT::|htpSetRadioButtonAlist| BOOT::|pfWrong| - BOOT::|pfForin| BOOT::|pfDefinition| BOOT::|pfReturnTyped| - BOOT::|pfLam| BOOT::|pfIfThenOnly| BOOT::|pfExit| - BOOT::|printNamedStatsByProperty| BOOT::|Delay| - BOOT::|initializeTimedNames| BOOT::|searchTailEnv| - BOOT::|searchCurrentEnv| BOOT::|search| - BOOT::|e04ycfSolve,fc| BOOT::|insertWOC,fn| BOOT::|mkObj| - VMLISP:|union| BOOT::|coerceInt| BOOT::|deleteAssocWOC| - BOOT::|e04nafSolve,fa| BOOT::|deleteAssocWOC,fn| - BOOT::|e04nafSolve,fb| BOOT::|deleteLassoc| BOOT::REMALIST - BOOT::|sublisNQ| BOOT::|BooleanEquality| - BOOT::|sublisNQ,fn| BOOT::|modemapsHavingTarget| - BOOT::|PPtoFile| BOOT::|positionInVec| - BOOT::|e04mbfSolve,fa| BOOT::|e04mbfSolve,fb| - BOOT::|mkIterVarSub| BOOT::|lazyOldAxiomDomainDevaluate| - BOOT::|lazyOldAxiomDomainHashCode| BOOT::|declare| - BOOT::|declareMap| BOOT::|concat1| BOOT::|upfreeWithType| - BOOT::|uplocalWithType| BOOT::|deleteAll| - BOOT::|oldAxiomCategoryDevaluate| BOOT::|SExprToDName| - BOOT::|oldAxiomPreCategoryDevaluate| - BOOT::|checkForFreeVariables| BOOT::|f01rdfSolve,fa| - BOOT::|f01rdfSolve,ga| BOOT::|oldAxiomDomainDevaluate| - BOOT::|newHasCategory| BOOT::|orderedDefaults| - BOOT::|f01rdfSolve,fb| BOOT::|attributeNthParent| BOOT:DROP - BOOT::|oldAxiomDomainHashCode| BOOT::|attributeHashCode| - BOOT::|oldAxiomPreCategoryHashCode| - BOOT::|attributeDevaluate| BOOT::|f01refSolve,fa| - BOOT::|f01refSolve,ga| BOOT::|oldAxiomCategoryHashCode| - BOOT:APPLYR BOOT::|f01qcfSolve,f| BOOT::|evalLET| - BOOT::|f01qcfSolve,g| BOOT::|domainEqual| BOOT:STRINGSUFFIX - BOOT::|f01qefSolve,fa| BOOT::|compileIs| - BOOT::|f01qefSolve,ga| BOOT::|f01rcfSolve,fa| - BOOT::|f01rcfSolve,ga| BOOT:CONVERSATION - BOOT::|evalLETchangeValue| BOOT::|isPatternMatch| - BOOT::|seteltable| BOOT::|intSayKeyedMsg| - BOOT::|upLispCall| BOOT::|genIFvalCode| BOOT::|evalLETput| - BOOT::|f01qdfSolve,fb| BOOT::|f01qdfSolve,gb| - BOOT::|intloopProcessString| BOOT::|ncloopDQlines| - BOOT::|intloopInclude1| BOOT::|intloopInclude| - BOOT::|upIFgenValue| BOOT::|putPvarModes| - BOOT::|ncloopPrefix?| BOOT::|intloopPrefix?| - BOOT::|phIntReportMsgs| BOOT::|processMsgList| - BOOT::|phParse| BOOT:TAKE BOOT::|isPatMatch| - BOOT::|intloopReadConsole| BOOT::|streamChop| - BOOT::|inclFname| BOOT::|incDrop| BOOT:SETANDFILE - BOOT:PUSH-REDUCTION BOOT::|inclmsgFileCycle| - BOOT::|assertCond| BOOT::|incActive?| BOOT:TAILFN - BOOT:RPLACW BOOT::|incStream| BOOT::|inclHandleSay| - BOOT::|inclHandleWarning| BOOT:FLAGP - BOOT::|inclHandleError| BOOT:?ORDER BOOT::|incRenumberLine| - BOOT::|incRenumberItem| BOOT::|lnSetGlobalNum| BOOT:S* - FOAM::ALLOC-PROG-INFO BOOT::|liftCond,lcAnd| - BOOT::|actOnInfo| BOOT::|mkJoin| BOOT::|plural| - BOOT::|e04ucfSolve,fb| BOOT:MAKENEWOP BOOT::|has| - BOOT::|containedRight| BOOT::|hashTypeForm| BOOT:CONTAINED - BOOT::|oldAxiomPreCategoryParents| - BOOT::|oldAxiomCategoryDefaultPackage| BOOT:POINTW - BOOT::|linearFormatForm| BOOT::|newHasAttribute| - BOOT::|oldAxiomCategoryParentCount| - BOOT::|findSubstitutionOrder?,fn| BOOT::|app2StringConcat0| - BOOT::|formDecl2String| BOOT::|sayLooking1| - BOOT::|formJoin1| BOOT::|app2StringWrap| BOOT:S- - BOOT::|mkLessOrEqual| BOOT::|formArguments2String| - BOOT::|putValueValue| BOOT::|asTupleNew| BOOT::|objSetVal| - BOOT::|objNewCode| FOAM-USER::H-ERROR BOOT::|displayRule| - BOOT::|coerceInteractive| BOOT::|canMakeTuple| - FOAM-USER::H-STRING BOOT:CARCDREXPAND - BOOT::|formatOpSymbol| FOAM-USER::H-INTEGER - BOOT::|addPatternPred| BOOT::|interpMap| BOOT::|mkLocalVar| - BOOT:/EMBED-1 BOOT::|findLocalVars1| - BOOT::|queryUserKeyedMsg| BOOT::|mkFreeVar| - BOOT::|findLocalVars|)) -(PROCLAIM - '(FTYPE (FUNCTION NIL FIXNUM) BOOT::HEAPELAPSED - BOOT:|OsProcessNumber| BOOT::KCL-OS-PROCESS-NUMBER)) -(PROCLAIM - '(FTYPE (FUNCTION NIL (VALUES T T)) BOOT::MAKE-CLOSEDFN-NAME - BOOT::|genVariable| BOOT::|genSomeVariable| - BOOT::|genDomainVar| BOOT:GENVAR)) diff --git a/src/interp/intint.lisp b/src/interp/intint.lisp new file mode 100644 index 00000000..d08cc8fd --- /dev/null +++ b/src/interp/intint.lisp @@ -0,0 +1,148 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + +(in-package "BOOT") + +(defun |intSayKeyedMsg| (key args) + (|sayKeyedMsg| (|packageTran| key) (|packageTran| args))) + +;;(defun |intMakeFloat| (int frac len exp) +;; (MAKE-FLOAT int frac len exp)) + +;;(defun |intSystemCommand| (command) +;; (catch 'SPAD_READER +;; (|systemCommand| (|packageTran| command)))) + +;;(defun |intUnAbbreviateKeyword| (keyword) +;; (|unAbbreviateKeyword| (|packageTran| keyword))) + +(defun |intProcessSynonyms| (str) + (let ((LINE str)) + (declare (special LINE)) + (|processSynonyms|) + LINE)) + +;; (defun |intNoParseCommands| () +;; |$noParseCommands|) + +;;(defun |intTokenCommands| () +;; |$tokenCommands|) + +(defun |intInterpretPform| (pf) + (|processInteractive| (|zeroOneTran| (|packageTran| (|pf2Sex| pf))) pf)) + +;;(defun |intSpadThrow| () +;; (|spadThrow|)) + +;;(defun |intMKPROMPT| (should? step) +;; (if should? (PRINC (MKPROMPT)))) + +(defvar |$intCoerceFailure| '|coerceFailure|) +(defvar |$intTopLevel| '|top_level|) +(defvar |$intSpadReader| 'SPAD_READER) +(defvar |$intRestart| '|restart|) + +;;(defun |intString2BootTree| (str) +;; (|string2BootTree| str)) + +;;(defun |intPackageTran| (sex) +;; (|packageTran| sex)) + +;;--------------------> NEW DEFINITION (override in i-syscmd.boot.pamphlet) +(defun |stripSpaces| (str) + (string-trim '(#\Space) str)) + +;;(defvar |$SessionManager| |$SessionManager|) +;;(defvar |$EndOfOutput| |$EndOfOutput|) + +;;(defun |intServerReadLine| (foo) +;; (|serverReadLine| foo)) + +;; (defun |intProcessSynonym| (str) +;; (|npProcessSynonym| str)) + +(defun |SpadInterpretFile| (fn) + (|SpadInterpretStream| 1 fn nil) ) + +(defun |intNewFloat| () + (list '|Float|)) + +;; (defun |intDoSystemCommand| (string) +;; (|doSystemCommand| string)) + +(defun |intSetNeedToSignalSessionManager| () + (setq |$NeedToSignalSessionManager| T)) + +;; (defun |intKeyedSystemError| (msg args) +;; (|keyedSystemError| msg args)) + +;;#-:CCL +;;(defun |stashInputLines| (l) +;; (|stashInputLines| l)) + +;;(defun |setCurrentLine| (s) +;; (setq |$currentLine| s)) + +(defun |setCurrentLine| (s) + (setq |$currentLine| + (cond ((null |$currentLine|) s) + ((stringp |$currentLine|) + (cons |$currentLine| + (if (stringp s) (cons s nil) s))) + (t (rplacd (last |$currentLine|) + (if (stringp s) (cons s nil) s)) + |$currentLine|)))) + +(defun |intnplisp| (s) + (setq |$currentLine| s) + (|nplisp| |$currentLine|)) + +;; (defun |intResetStackLimits| () (|resetStackLimits|)) + +(defun |intSetQuiet| () + (setq |$QuietCommand| T)) + +(defun |intUnsetQuiet| () + (setq |$QuietCommand| NIL)) + +;; (defun |expandTabs| (s) +;; (expand-tabs s)) + +;; #-:CCL +;; (defun |leaveScratchpad| () +;; (|leaveScratchpad|)) + +;;(defun |readingFile?| () +;; |$ReadingFile|) + diff --git a/src/interp/intint.lisp.pamphlet b/src/interp/intint.lisp.pamphlet deleted file mode 100644 index d132ad87..00000000 --- a/src/interp/intint.lisp.pamphlet +++ /dev/null @@ -1,168 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp intint.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -(in-package "BOOT") - -(defun |intSayKeyedMsg| (key args) - (|sayKeyedMsg| (|packageTran| key) (|packageTran| args))) - -;;(defun |intMakeFloat| (int frac len exp) -;; (MAKE-FLOAT int frac len exp)) - -;;(defun |intSystemCommand| (command) -;; (catch 'SPAD_READER -;; (|systemCommand| (|packageTran| command)))) - -;;(defun |intUnAbbreviateKeyword| (keyword) -;; (|unAbbreviateKeyword| (|packageTran| keyword))) - -(defun |intProcessSynonyms| (str) - (let ((LINE str)) - (declare (special LINE)) - (|processSynonyms|) - LINE)) - -;; (defun |intNoParseCommands| () -;; |$noParseCommands|) - -;;(defun |intTokenCommands| () -;; |$tokenCommands|) - -(defun |intInterpretPform| (pf) - (|processInteractive| (|zeroOneTran| (|packageTran| (|pf2Sex| pf))) pf)) - -;;(defun |intSpadThrow| () -;; (|spadThrow|)) - -;;(defun |intMKPROMPT| (should? step) -;; (if should? (PRINC (MKPROMPT)))) - -(defvar |$intCoerceFailure| '|coerceFailure|) -(defvar |$intTopLevel| '|top_level|) -(defvar |$intSpadReader| 'SPAD_READER) -(defvar |$intRestart| '|restart|) - -;;(defun |intString2BootTree| (str) -;; (|string2BootTree| str)) - -;;(defun |intPackageTran| (sex) -;; (|packageTran| sex)) - -;;--------------------> NEW DEFINITION (override in i-syscmd.boot.pamphlet) -(defun |stripSpaces| (str) - (string-trim '(#\Space) str)) - -;;(defvar |$SessionManager| |$SessionManager|) -;;(defvar |$EndOfOutput| |$EndOfOutput|) - -;;(defun |intServerReadLine| (foo) -;; (|serverReadLine| foo)) - -;; (defun |intProcessSynonym| (str) -;; (|npProcessSynonym| str)) - -(defun |SpadInterpretFile| (fn) - (|SpadInterpretStream| 1 fn nil) ) - -(defun |intNewFloat| () - (list '|Float|)) - -;; (defun |intDoSystemCommand| (string) -;; (|doSystemCommand| string)) - -(defun |intSetNeedToSignalSessionManager| () - (setq |$NeedToSignalSessionManager| T)) - -;; (defun |intKeyedSystemError| (msg args) -;; (|keyedSystemError| msg args)) - -;;#-:CCL -;;(defun |stashInputLines| (l) -;; (|stashInputLines| l)) - -;;(defun |setCurrentLine| (s) -;; (setq |$currentLine| s)) - -(defun |setCurrentLine| (s) - (setq |$currentLine| - (cond ((null |$currentLine|) s) - ((stringp |$currentLine|) - (cons |$currentLine| - (if (stringp s) (cons s nil) s))) - (t (rplacd (last |$currentLine|) - (if (stringp s) (cons s nil) s)) - |$currentLine|)))) - -(defun |intnplisp| (s) - (setq |$currentLine| s) - (|nplisp| |$currentLine|)) - -;; (defun |intResetStackLimits| () (|resetStackLimits|)) - -(defun |intSetQuiet| () - (setq |$QuietCommand| T)) - -(defun |intUnsetQuiet| () - (setq |$QuietCommand| NIL)) - -;; (defun |expandTabs| (s) -;; (expand-tabs s)) - -;; #-:CCL -;; (defun |leaveScratchpad| () -;; (|leaveScratchpad|)) - -;;(defun |readingFile?| () -;; |$ReadingFile|) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/macros.lisp b/src/interp/macros.lisp new file mode 100644 index 00000000..b46f1864 --- /dev/null +++ b/src/interp/macros.lisp @@ -0,0 +1,926 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + +;; PURPOSE: Provide generally useful macros and functions for MetaLanguage +;; and Boot code. Contents are organized along Common Lisp datatype +;; lines, with sections numbered to match the section headings of the +;; Common Lisp Reference Manual, by Guy Steele, Digital Press, 1984, +;; Digital Press Order Number EY-00031-DP. This way you can +;; look up the corresponding section in the manual and see if +;; there isn't a cleaner and non-VM-specific way of doing things. + + +;; Camm has identified a performace problem during compiles. There is +;; a loop that continually adds one element to a vector. This causes +;; the vector to get extended by 1 and copied. These patches fix the +;; problem since vectors with fill pointers don't need to be copied. +;; +;; These cut out the lion's share of the gc problem +;; on this compile. 30min {\tt ->} 7 min on my box. There is still some gc +;; churning in cons pages due to many calls to 'list' with small n. One +;; can likely improve things further with an appropriate (declare +;; (:dynamic-extent ...)) in the right place -- gcl will allocate such +;; lists on the C stack (very fast). + + +(import-module "sys-macros") +(in-package "BOOT") + +; 5 PROGRAM STRUCTURE + +; 5.3 Top-Level Forms + +(defun SETANDFILE (x y) (LAM\,EVALANDFILEACTQ `(setq ,x ',y))) + +; 5.3.2 Declaring Global Variables and Named Constants + +(defun |functionp| (fn) + (if (identp fn) (and (fboundp fn) (not (macro-function fn))) (functionp fn))) +(defun |macrop| (fn) (and (identp fn) (macro-function fn))) + +; 6 PREDICATES + +; 6.2 Data Type Predicates + +; 6.3 Equality Predicates + +(defun COMPARE (X Y) + "True if X is an atom or X and Y are lists and X and Y are equal up to X." + (COND ((ATOM X) T) + ((ATOM Y) NIL) + ((EQUAL (CAR X) (CAR Y)) (COMPARE (CDR X) (CDR Y))))) + + +(DEFUN ?ORDER (U V) "Multiple-type ordering relation." + (COND ((NULL U)) + ((NULL V) NIL) + ((ATOM U) + (if (ATOM V) + (COND ((NUMBERP U) (if (NUMBERP V) (> V U) T)) + ((NUMBERP V) NIL) + ((IDENTP U) (AND (IDENTP V) (string> (SYMBOL-NAME V) (SYMBOL-NAME U)))) + ((IDENTP V) NIL) + ((STRINGP U) (AND (STRINGP V) (string> V U))) + ((STRINGP V) NIL) + ((AND (VECP U) (VECP V)) + (AND (> (SIZE V) (SIZE U)) + (DO ((I 0 (1+ I))) + ((GT I (MAXINDEX U)) 'T) + (COND ((NOT (EQUAL (ELT U I) (ELT V I))) + (RETURN (?ORDER (ELT U I) (ELT V I)))))))) + ((croak "Do not understand"))) + T)) + ((ATOM V) NIL) + ((EQUAL U V)) + ((NOT (string> (write-to-string U) (write-to-string V)))))) + +; 7 CONTROL STRUCTURE + +; 7.1 Constants and Variables + +; 7.1.1 Reference + +; 7.2 Generalized Variables + +; 7.3 Function Invocation + +; 7.8 Iteration + +; 7.8.2 General Iteration + +(defmacro |Zero| (&rest L) + (declare (ignore l)) + "Needed by spadCompileOrSetq" 0) + +(defmacro |One| (&rest L) + (declare (ignore l)) + "Needed by spadCompileOrSetq" 1) + + +; 7.8.4 Mapping + + + +; 7.10 Dynamic Non-local Exits + +; 10.1 The Property List + + + +(defun PROPERTY (X IND N) + "Returns the Nth element of X's IND property, if it exists." + (let (Y) (if (AND (INTEGERP N) (SETQ Y (GET X IND)) (>= (LENGTH Y) N)) (ELEM Y N)))) + +; 10.3 Creating Symbols + + +(defvar $GENNO 0) + +(DEFUN GENVAR () (INTERNL "$" (STRINGIMAGE (SETQ $GENNO (1+ $GENNO))))) + +(DEFUN IS_GENVAR (X) + (AND (IDENTP X) + (let ((y (symbol-name x))) + (and (char= #\$ (elt y 0)) (> (size y) 1) (digitp (elt y 1)))))) + +(DEFUN IS_\#GENVAR (X) + (AND (IDENTP X) + (let ((y (symbol-name x))) + (and (char= #\# (ELT y 0)) (> (SIZE Y) 1) (DIGITP (ELT Y 1)))))) + +; 10.7 CATCH and THROW + +; 12 NUMBERS + +; 12.3 Comparisons on Numbers + +; 12.4 Arithmetic Operations + +; 12.5 Irrational and Transcendental Functions + +; 12.5.1 Exponential and Logarithmic Functions + +; 12.6 Small Finite Field ops with vector trimming + +(defun TRIMLZ (vec) + (declare (simple-vector vec)) + (let ((n (position 0 vec :from-end t :test-not #'eql))) + (cond ((null n) (vector)) + ((eql n (qvmaxindex vec)) vec) + (t (subseq vec 0 (+ n 1)))))) + +;; In CCL ASH assumes a 2's complement machine. We use ASH in Integer and +;; assume we have a sign and magnitude setup. +#+:CCL (defmacro ash (u v) `(lisp::ash1 ,u ,v)) + +; 14 SEQUENCES + +; 14.1 Simple Sequence Functions + +(define-function 'getchar #'elt) + +(defun GETCHARN (A M) "Return the code of the Mth character of A" + (let ((a (if (identp a) (symbol-name a) a))) (char-code (elt A M)))) + +; 14.2 Concatenating, Mapping, and Reducing Sequences + +(DEFUN STRINGPAD (STR N) + (let ((M (length STR))) + (if (>= M N) + STR + (concatenate 'string str (make-string (- N M) :initial-element #\Space))))) + +(DEFUN STRINGSUFFIX (TARGET SOURCE) "Suffix source to target if enough room else nil." + (concatenate 'string target source)) + +(defun NSTRCONC (s1 s2) (concatenate 'string (string s1) (string s2))) + + +(define-function '|append| #'APPEND) + +;;(defun |delete| (item list) ; renaming from DELETE is done in DEF +;; (cond ((atom list) list) +;; ((equalp item (qcar list)) (|delete| item (qcdr list))) +;; ('t (cons (qcar list) (|delete| item (qcdr list)))))) + +(defun |delete| (item sequence) + (cond ((symbolp item) (remove item sequence :test #'eq)) + ((and (atom item) (not (arrayp item))) (remove item sequence)) + (T (remove item sequence :test #'equalp)))) + + + + + + +(defun THETACHECK (VAL VAR OP) (if (EQL VAL VAR) (THETA_ERROR OP) val)) + +; 15 LISTS + +; 15.1 Conses + + +; 15.2 Lists + + +(defmacro TL (&rest L) `(tail . ,L)) + + +(defmacro SPADCONST (&rest L) (cons 'qrefelt L)) + +(DEFUN LASTELEM (X) (car (last X))) + +(defun LISTOFATOMS (X) + (COND ((NULL X) NIL) + ((ATOM X) (LIST X)) + ((NCONC (LISTOFATOMS (CAR X)) (LISTOFATOMS (CDR X)))))) + +(DEFUN LASTATOM (L) (if (ATOM L) L (LASTATOM (CDR L)))) + +(define-function 'LASTTAIL #'last) + +(define-function 'LISPELT #'ELT) + +(defun DROP (N X &aux m) + "Return a pointer to the Nth cons of X, counting 0 as the first cons." + (COND ((EQL N 0) X) + ((> N 0) (DROP (1- N) (CDR X))) + ((>= (setq m (+ (length x) N)) 0) (take m x)) + ((CROAK (list "Bad args to DROP" N X))))) + +(DEFUN TAKE (N X &aux m) + "Returns a list of the first N elements of list X." + (COND ((EQL N 0) NIL) + ((> N 0) (CONS (CAR X) (TAKE (1- N) (CDR X)))) + ((>= (setq m (+ (length x) N)) 0) (drop m x)) + ((CROAK (list "Bad args to DROP" N X))))) + +(DEFUN NUMOFNODES (X) (if (ATOM X) 0 (+ 1 (NUMOFNODES (CAR X)) (NUMOFNODES (CDR X))))) + +(DEFUN TRUNCLIST (L TL) "Truncate list L at the point marked by TL." + (let ((U L)) (TRUNCLIST-1 L TL) U)) + +(DEFUN TRUNCLIST-1 (L TL) + (COND ((ATOM L) L) + ((EQL (CDR L) TL) (RPLACD L NIL)) + ((TRUNCLIST-1 (CDR L) TL)))) + +; 15.3 Alteration of List Structure + +(defun RPLACW (x w) (let (y z) (dsetq (Y . Z) w) (RPLACA X Y) (RPLACD X Z) X)) + +; 15.4 Substitution of Expressions + +(DEFUN SUBSTEQ (NEW OLD FORM) + "Version of SUBST that uses EQ rather than EQUAL on the world." + (PROG (NFORM HNFORM ITEM) + (SETQ HNFORM (SETQ NFORM (CONS () ()))) + LP (RPLACD NFORM + (COND ((EQ FORM OLD) (SETQ FORM ()) NEW ) + ((NOT (PAIRP FORM)) FORM ) + ((EQ (SETQ ITEM (CAR FORM)) OLD) (CONS NEW ()) ) + ((PAIRP ITEM) (CONS (SUBSTEQ NEW OLD ITEM) ()) ) + ((CONS ITEM ())))) + (if (NOT (PAIRP FORM)) (RETURN (CDR HNFORM))) + (SETQ NFORM (CDR NFORM)) + (SETQ FORM (CDR FORM)) + (GO LP))) + +(DEFUN SUBLISNQ (KEY E) (declare (special KEY)) (if (NULL KEY) E (SUBANQ E))) + +(DEFUN SUBANQ (E) + (declare (special key)) + (COND ((ATOM E) (SUBB KEY E)) + ((EQCAR E (QUOTE QUOTE)) E) + ((MAPCAR #'(LAMBDA (J) (SUBANQ J)) E)))) + +(DEFUN SUBB (X E) + (COND ((ATOM X) E) + ((EQ (CAAR X) E) (CDAR X)) + ((SUBB (CDR X) E)))) + +(defun SUBLISLIS (newl oldl form) + (sublis (mapcar #'cons oldl newl) form)) + +; 15.5 Using Lists as Sets + +#-:CCL +(DEFUN CONTAINED (X Y) + (if (symbolp x) + (contained\,eq X Y) + (contained\,equal X Y))) + +(defun contained\,eq (x y) + (if (atom y) (eq x y) + (or (contained\,eq x (car y)) (contained\,eq x (cdr y))))) + +(defun contained\,equal (x y) + (cond ((atom y) (equal x y)) + ((equal x y) 't) + ('t (or (contained\,equal x (car y)) (contained\,equal x (cdr y)))))) + + +(DEFUN PREDECESSOR (TL L) + "Returns the sublist of L whose CDR is EQ to TL." + (COND ((ATOM L) NIL) + ((EQ TL (CDR L)) L) + ((PREDECESSOR TL (CDR L))))) + +(defun remdup (l) (remove-duplicates l :test #'equalp)) + +(DEFUN GETTAIL (X L) (member X L :test #'equal)) + +; 15.6 Association Lists + + +;; FIXME: Should not this be named `alistAllKeys'? +(DEFUN ASSOCLEFT (X) + "Returns all the keys of association list X." + (if (ATOM X) + X + (mapcar #'car x))) + +;; FIXME: Should not this be named `alistAllValues'? +(DEFUN ASSOCRIGHT (X) + "Returns all the datums of association list X." + (if (ATOM X) + X + (mapcar #'cdr x))) + + +(DEFUN ADDASSOC (X Y L) + "Put the association list pair (X . Y) into L, erasing any previous association for X" + (COND ((ATOM L) + (CONS (CONS X Y) L)) + ((EQUAL X (CAAR L)) + (CONS (CONS X Y) (CDR L))) + ((CONS (CAR L) (ADDASSOC X Y (CDR L)))))) + +(DEFUN DELLASOS (U V) + "Remove any assocation pair (U . X) from list V." + (COND ((ATOM V) NIL) + ((EQUAL U (CAAR V)) + (CDR V)) + ((CONS (CAR V) (DELLASOS U (CDR V)))))) + + +;; FIXME: Should not this be named `alistValue'? +(DEFUN LASSOC (X Y) + "Return the datum associated with key X in association list Y." + (PROG NIL + A + (COND ((ATOM Y) + (RETURN NIL)) + ((EQUAL (CAAR Y) X) + (RETURN (CDAR Y))) ) + (SETQ Y (CDR Y)) + (GO A))) + +;; FIXME: Should not this be named `alistKey'? +(DEFUN |rassoc| (X Y) + "Return the key associated with datum X in association list Y." + (PROG NIL + A + (COND ((ATOM Y) + (RETURN NIL)) + ((EQUAL (CDAR Y) X) + (RETURN (CAAR Y))) ) + (SETQ Y (CDR Y)) + (GO A))) + +; (defun QLASSQ (p a-list) (let ((y (assoc p a-list :test #'eq))) (if y (cdr y)))) +(defun QLASSQ (p a-list) (cdr (assq p a-list))) + +(define-function 'LASSQ #'QLASSQ) + +(defun pair (x y) (mapcar #'cons x y)) + +;;; Operations on Association Sets (AS) + +(defun AS-INSERT (A B L) + ;; PF(item) x PF(item) x LIST(of pairs) -> LIST(of pairs with (A . B) added) + ;; destructive on L; if (A . C) appears already, C is replaced by B + (cond ((null l) (list (cons a b))) + ((equal a (caar l)) (rplac (cdar l) b) l) + ((?order a (caar l)) (cons (cons a b) l)) + (t (as-insert1 a b l) l))) + +(defun as-insert1 (a b l) + (cond ((null (cdr l)) (rplac (cdr l) (list (cons a b)))) + ((equal a (caadr l)) (rplac (cdadr l) b)) + ((?order a (caadr l)) (rplac (cdr l) (cons (cons a b) (cdr l)))) + (t (as-insert1 a b (cdr l))))) + + +; 17 ARRAYS + +; 17.6 Changing the Dimensions of an Array + + +(defun lengthenvec (v n) + (if + (and (array-has-fill-pointer-p v) (adjustable-array-p v)) + (if + (>= n (array-total-size v)) + (adjust-array v (* n 2) :fill-pointer n) + (progn + (setf (fill-pointer v) n) + v)) + (replace (make-array n :fill-pointer t) v))) + +(defun make-init-vector (n val) + (make-array n :initial-element val :fill-pointer t)) + + +; 22 INPUT/OUTPUT + +; 22.2 Input Functions + +; 22.2.1 Input from Character Streams + +(DEFUN STREAM-EOF (&optional (STRM *terminal-io*)) + "T if input stream STRM is at the end or saw a ~." + (not (peek-char nil STRM nil nil nil)) ) + +(DEFUN CONSOLEINPUTP (STRM) (IS-CONSOLE STRM)) + +(defvar $filelinenumber 0) +(defvar $prompt "--->") +(defvar stream-buffer nil) + +(DEFUN NEXTSTRMLINE (STRM) "Returns the next input line from stream STRM." + (let ((v (read-line strm nil -1 nil))) + (if (equal v -1) (throw 'spad_reader nil) + (progn (setq stream-buffer v) v)))) + +(DEFUN CURSTRMLINE (STRM) + "Returns the current input line from the stream buffer of STRM (VM-specific!)." + (cond (stream-buffer) + ((stream-eof strm) (fail)) + ((nextstrmline strm)))) + +(defvar *EOF* NIL) + +(DEFUN CURMAXINDEX (STRM) +"Something bizarre and VM-specific with respect to streams." + (if *EOF* (FAIL) (ELT (ELT (LASTATOM STRM) 1) 3))) + +(DEFUN ADJCURMAXINDEX (STRM) +"Something unearthly and VM-specific with respect to streams." + (let (v) (if *eof* (fail) + (progn (SETQ V (ELT (LASTATOM STRM) 1)) + (SETELT V 3 (SIZE (ELT V 0))))))) + +(DEFUN STRMBLANKLINE (STRM) +"Something diabolical and VM-specific with respect to streams." + (if *EOF* (FAIL) (AND (EQ '\ (CAR STRM)) (EQL 1 (CURMAXINDEX STRM))))) + +(DEFUN STRMSKIPTOBLANK (STRM) +"Munch away on the stream until you get to a blank line." + (COND (*EOF* (FAIL)) + ((PROGN (NEXTSTRMLINE STRM) (STRMBLANKLINE STRM)) STRM) + ((STRMSKIPTOBLANK STRM)))) + +(DEFUN CURINPUTLINE () (CURSTRMLINE *standard-input*)) + +(DEFUN NEXTINPUTLINE () (NEXTSTRMLINE *standard-input*)) + +; 22.3 Output Functions + +; 22.3.1 Output to Character Streams + +(DEFUN ATOM2STRING (X) + "Give me the string which would be printed out to denote an atom." + (cond ((atom x) (symbol-name x)) + ((stringp x) x) + ((write-to-string x)))) + +(defvar |conOutStream| *terminal-io* "console output stream") + +(defun |sayTeX| (x) (if (null x) nil (sayBrightly1 x |$texOutputStream|))) + +(defun |sayNewLine| () (TERPRI)) + +(defvar |$sayBrightlyStream| nil "if not nil, gives stream for sayBrightly output") + +(defun |sayBrightly| (x &optional (out-stream *standard-output*)) + (COND ((NULL X) NIL) + (|$sayBrightlyStream| (sayBrightly1 X |$sayBrightlyStream|)) + ((IS-CONSOLE out-stream) (sayBrightly1 X out-stream)) + ((sayBrightly1 X out-stream) (sayBrightly1 X *terminal-io*)))) + +(defun |sayBrightlyI| (x &optional (s *terminal-io*)) + "Prints at console or output stream." + (if (NULL X) NIL (sayBrightly1 X S))) + +(defun |sayBrightlyNT| (x &optional (S *standard-output*)) + (COND ((NULL X) NIL) + (|$sayBrightlyStream| (sayBrightlyNT1 X |$sayBrightlyStream|)) + ((IS-CONSOLE S) (sayBrightlyNT1 X S)) + ((sayBrightly1 X S) (sayBrightlyNT1 X *terminal-io*)))) + +(defun sayBrightlyNT1 (X *standard-output*) + (if (ATOM X) (BRIGHTPRINT-0 X) (BRIGHTPRINT X))) + +(defun sayBrightly1 (X *standard-output*) + (if (ATOM X) + (progn (BRIGHTPRINT-0 X) (TERPRI) (force-output)) + (progn (BRIGHTPRINT X) (TERPRI) (force-output)))) + +(defvar |$algebraOutputStream| *standard-output*) + +(defun |saySpadMsg| (X) + (if (NULL X) NIL (sayBrightly1 X |$algebraOutputStream|))) + +(defun |sayALGEBRA| (X) "Prints on Algebra output stream." + (if (NULL X) NIL (sayBrightly1 X |$algebraOutputStream|))) + +(defun |sayMSG| (X) + (if (NULL X) NIL (sayBrightly1 X |$algebraOutputStream|))) + +(defun |sayMSGNT| (X) + (if (NULL X) NIL (sayBrightlyNT1 X |$algebraOutputStream|))) + +(defun |sayMSG2File| (msg) + (PROG (file str) + (SETQ file (|makePathname| '|spadmsg| '|listing| |$listingDirectory|)) + (SETQ str + (DEFIOSTREAM + (CONS '(MODE . OUTPUT) (CONS (CONS 'FILE file) NIL)) + 255 0)) + (sayBrightly1 msg str) + (SHUT str) ) ) + +(defvar |$fortranOutputStream|) + +(defun |sayFORTRAN| (x) "Prints on Fortran output stream." + (if (NULL X) NIL (sayBrightly1 X |$fortranOutputStream|))) + +(defvar |$formulaOutputStream|) + +(defun |sayFORMULA| (X) "Prints on formula output stream." + (if (NULL X) NIL (sayBrightly1 X |$formulaOutputStream|))) + +(defvar |$highlightAllowed| nil "Used in BRIGHTPRINT and is a )set variable.") + +(defvar |$highlightFontOn| |$boldString| "switch to highlight font") +(defvar |$highlightFontOff| |$normalString| "return to normal font") + +;; the following are redefined in MSGDB BOOT + +;; --------------------> NEW DEFINITION (override in msgdb.boot.pamphlet) +(DEFUN BRIGHTPRINT (X) (MESSAGEPRINT X)) + +;; --------------------> NEW DEFINITION (override in msgdb.boot.pamphlet) +(DEFUN BRIGHTPRINT-0 (x) (MESSAGEPRINT-1 X)) + +(DEFUN BLANKS (N &optional (stream *standard-output*)) "Print N blanks." + (do ((i 1 (the fixnum(1+ i)))) + ((> i N))(declare (fixnum i n)) (princ " " stream))) + +; 23 FILE SYSTEM INTERFACE + +; 23.2 Opening and Closing Files + +(DEFUN DEFSTREAM (file MODE) + (if (member mode '(i input)) + (MAKE-INSTREAM file) + (MAKE-OUTSTREAM file))) + +; 23.3 Renaming, Deleting and Other File Operations + +(DEFUN NOTE (STRM) +"Attempts to return the current record number of a file stream. This is 0 for +terminals and empty or at-end files. In Common Lisp, we must assume record sizes of 1!" + (COND ((STREAM-EOF STRM) 0) + ((IS-CONSOLE STRM) 0) + ((file-position STRM)))) + +(DEFUN IS-CONSOLE-NOT-XEDIT (S) (not (OR (NULL (IS-CONSOLE S))))) + +(DEFUN POINTW (RECNO STRM) +"Does something obscure and VM-specific with respect to streams." + (let (V) + (if (STREAM-EOF STRM) (FAIL)) + (SETQ V (LASTATOM STRM)) + (SETELT V 4 RECNO) + (SETQ *EOF* (STREAM-EOF STRM)) + strm)) + +(DEFUN POINT (RECNO STRM) (file-position strm recno)) + +(DEFUN STRM (RECNO STRM) +"Does something obscure and VM-specific with respect to streams." + (let (V) + (if (STREAM-EOF STRM) (FAIL)) + (SETQ V (LASTATOM STRM)) + (SETELT V 4 RECNO) + (read-char STRM) + (SETQ *EOF* (STREAM-EOF STRM)) + strm)) + +; 25 MISCELLANEOUS FEATURES + +;; range tests and assertions + +(defmacro |assert| (x y) `(IF (NULL ,x) (|error| ,y))) + +(defun coerce-failure-msg (val mode) + (STRCONC (MAKE-REASONABLE (STRINGIMAGE val)) + " cannot be coerced to mode " + (STRINGIMAGE (|devaluate| mode)))) + +(defmacro |check-subtype| (pred submode val) + `(|assert| ,pred (coerce-failure-msg ,val ,submode))) + +(defmacro |check-union| (pred branch val) + `(|assert| ,pred (coerce-failure-msg ,val ,branch ))) + +(defun MAKE-REASONABLE (Z) + (if (> (length Z) 30) (CONCAT "expression beginning " (subseq Z 0 20)) Z)) + + +(defmacro |elapsedUserTime| () '(get-internal-run-time)) + +#+IBCL +(defmacro |elapsedGcTime| () '(system:gbc-time-report)) +#+AKCL +(defmacro |elapsedGcTime| () '(system:gbc-time)) +#+:CCL +(defmacro |elapsedGcTime| () '(lisp:gctime)) +#-(OR :CCL IBCL AKCL) +(defmacro |elapsedGcTime| () '0) + +(defmacro |do| (&rest args) (CONS 'PROGN args)) + +(defun DROPTRAILINGBLANKS (LINE) (string-right-trim " " LINE)) + +(defun print-and-eval-defun (name body) + (eval body) + (print-defun name body) + ;; (set name (symbol-function name)) ;; this should go away + ) + +(defun eval-defun (name body) (eval (macroexpandall body))) + +; This function was modified by Greg Vanuxem on March 31, 2005 +; to handle the special case of #'(lambda ..... which expands +; into (function (lambda ..... +; +; The extra if clause fixes bugs #196 and #114 +; +; an example that used to cause the failure was: +; )set func comp off +; f(xl:LIST FRAC INT): LIST FRAC INT == map(x +-> x, xl) +; f [1,2,3] +; +; which expanded into +; +; (defun |xl;f;1;initial| (|#1| |envArg|) +; (prog (#:G1420) +; (return +; (progn +; (lett #:G1420 'uninitialized_variable |f| |#1;f;1:initial|) +; (spadcall +; (cons (|function| (lambda (#:G1420 |envArg|) #:G1420)) (vector)) +; |#1| +; (qrefelt |*1;f;1;initial;MV| 0)))))) +; +; the (|function| (lambda form used to cause an infinite expansion loop +; +(defun macroexpandall (sexpr) + (cond + ((atom sexpr) sexpr) + ((eq (car sexpr) 'quote) sexpr) + ((eq (car sexpr) 'defun) + (cons (car sexpr) (cons (cadr sexpr) + (mapcar #'macroexpandall (cddr sexpr))))) + ((and (symbolp (car sexpr)) (macro-function (car sexpr))) + (do () + ((not (and (consp sexpr) (symbolp (car sexpr)) + (macro-function (car sexpr))))) + (setq sexpr (macroexpand sexpr))) + (if (consp sexpr) + (let ((a (car sexpr)) (b (caadr sexpr))) + (if (and (eq a 'function) (eq b 'lambda)) + (cons a (list (cons b (mapcar #'macroexpandall (cdadr sexpr))))) + (mapcar #'macroexpandall sexpr))) + sexpr)) + ('else + (mapcar #'macroexpandall sexpr)))) + + +(defun compile-defun (name body) (eval body) (compile name)) + + +(defun |deleteWOC| (item list) (delete item list :test #'equal)) + +;;---- Added by WFS. + +(proclaim '(ftype (function (t t) t) |subWord|)) ;hack for bug in akcl-478 + +(DEFUN |subWord| (|str| N ) + (declare (fixnum n ) (string |str|)) + (PROG (|word| (|n| 0) |inWord|(|l| 0) ) + (declare (fixnum |n| |l|)) + (RETURN + (SEQ (COND + ((> 1 N) NIL) + ('T (SPADLET |l| (SPADDIFFERENCE (|#| |str|) 1)) + (COND + ((EQL |l| 0) NIL) + ('T (SPADLET |n| 0) (SPADLET |word| '||) + (SPADLET |inWord| NIL) + (DO ((|i| 0 (QSADD1 |i|))) ((QSGREATERP |i| |l|) NIL) + (declare (fixnum |i|)) + (SEQ (EXIT (COND + ((eql (aref |str| |i|) #\space) + (COND + ((NULL |inWord|) NIL) + ((eql |n| N) (RETURN |word|)) + ('T (SPADLET |inWord| NIL)))) + ('T + (COND + ((NULL |inWord|) + (SPADLET |inWord| 'T) + (SPADLET |n| (PLUS |n| 1)))) + (COND + ((eql |n| N) + (cond ((eq |word| '||) + (setq |word| + (make-array 10 :adjustable t + :element-type 'standard-char + :fill-pointer 0)))) + (or |word| (error "bad")) + (vector-push-extend (aref |str| |i|) + (the string |word|) + ) + ) + ('T NIL))))))) + (COND ((> N |n|) NIL) ('T |word|)))))))))) + +(defun print-full (expr &optional (stream *standard-output*)) + (let ((*print-circle* t) (*print-array* t) *print-level* *print-length*) + (print expr stream) + (terpri stream) + (finish-output stream))) + +;; moved here from preparse.lisp + +(defun NEXT-TAB-LOC (i) (* (1+ (truncate i 8)) 8)) + +(defun INDENT-POS (STR) + (do ((i 0 (1+ i)) + (pos 0)) + ((>= i (length str)) nil) + (case (char str i) + (#\space (incf pos)) + (#\tab (setq pos (next-tab-loc pos))) + (otherwise (return pos))))) + +;;(defun expand-tabs (str) +;; (let ((bpos (nonblankloc str)) +;; (tpos (indent-pos str))) +;; (if (eql bpos tpos) str +;; (concatenate 'string (make-string tpos :initial-element #\space) +;; (subseq str bpos))))) +(defun expand-tabs (str) + (if (and (stringp str) (> (length str) 0)) + (let ((bpos (nonblankloc str)) + (tpos (indent-pos str))) + (setq str + (if (eql bpos tpos) + str + (concatenate 'string + (make-string tpos :initial-element #\space) + (subseq str bpos)))) + ;; remove dos CR + (let ((lpos (maxindex str))) + (if (eq (char str lpos) #\Return) (subseq str 0 lpos) str))) + str)) + +(defun blankp (char) (or (eq char #\Space) (eq char #\tab))) + +(defun nonblankloc (str) (position-if-not #'blankp str)) + +;; stream handling for paste-in generation + +(defun |applyWithOutputToString| (func args) + ;; returns the cons of applying func to args and a string produced + ;; from standard-output while executing. + (let* ((out-stream (make-string-output-stream)) + (curoutstream out-stream) + (|$algebraOutputStream| out-stream) + (erroroutstream out-stream) + val) + (declare (special curoutstream |$algebraOutputStream|)) + (setq *standard-output* out-stream) + (setq *terminal-io* out-stream) + (setq val (catch 'spad_reader + (catch 'TOP_LEVEL + (apply (symbol-function func) args)))) + (cons val (get-output-stream-string *standard-output*)))) + +(defun |breakIntoLines| (str) + (let ((bol 0) (eol) (line-list nil)) + (loop + (setq eol (position #\Newline str :start bol)) + (if (null eol) (return)) + (if (> eol bol) + (setq line-list (cons (subseq str bol eol) line-list))) + (setq bol (+ eol 1))) + (nreverse line-list))) + +; part of the old spad to new spad translator +; these are here because they need to be in depsys +; they were in nspadaux.lisp + +(defmacro wi (a b) b) + +(defmacro |try| (X) + `(LET ((|$autoLine|)) + (declare (special |$autoLine|)) + (|tryToFit| (|saveState|) ,X))) + +(defmacro |embrace| (X) `(|wrapBraces| (|saveC|) ,X (|restoreC|))) +(defmacro |indentNB| (X) `(|wrapBraces| (|saveD|) ,X (|restoreD|))) + +(defmacro |tryBreak| (a b c d) +; Try to format by: +; (1) with no line breaking ($autoLine = nil) +; (2) with possible line breaks within a; +; (3) otherwise use a brace + `(LET + ((state)) + (setq state (|saveState| 't)) + (or + (LET ((|$autoLine|)) + (declare (special |$autoLine|)) + (and ,a (|formatRight| '|formatPreferPile| ,b ,c ,d))) + (|restoreState| state) + (and (eqcar ,b (quote seq)) + (|embrace| (and + ,a + (|formatLB|) + (|formatRight| '|formatPreferPile| ,b ,c ,d)))) + (|restoreState| state) + (|embrace| (and ,a + (|formatLB|) + (|formatRight| '|formatPreferPile| ,b ,c ,d)))))) + +(defmacro |tryBreakNB| (a b c d) +; Try to format by: +; (1) with no line breaking ($autoLine = nil) +; (2) with possible line breaks within a; +; (3) otherwise display without a brace + `(LET + ((state)) + (setq state (|saveState| 't)) + (or + (markhash ,b 0) + (LET ((|$autoLine|)) + (declare (special |$autoLine|)) + (and ,a (|formatRight| '|formatPreferPile| ,b ,c ,d))) + (|restoreState| state) + (markhash ,b 1) + (and (eqcar ,b (quote seq)) + (|embrace| (and + ,a + (|formatLB|) + (|formatRight| '|formatPreferPile| ,b ,c ,d)))) + (markhash ,b 2) + (|restoreState| state) + (|indentNB| (and ,a + (|formatRight| '|formatPreferPile| ,b ,c ,d))) + (markhash ,b 3) + +))) + +(defvar HT nil) + +(defun markhash (key n) (progn (cond + ((equal n 3) (remhash key ht)) + ('t (hput ht key n)) ) nil)) + +;; +;; -*- Record Structures -*- +;; + +(defmacro |Record| (&rest x) + `(|Record0| (LIST ,@(COLLECT (IN Y X) + (list 'CONS (MKQ (CADR Y)) (CADDR Y)))))) + +(defmacro |:| (tag expr) + `(LIST '|:| ,(MKQ tag) ,expr)) + + diff --git a/src/interp/macros.lisp.pamphlet b/src/interp/macros.lisp.pamphlet deleted file mode 100644 index 2799b0e9..00000000 --- a/src/interp/macros.lisp.pamphlet +++ /dev/null @@ -1,993 +0,0 @@ -%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/macros.lisp} Pamphlet} -\author{Timothy Daly} - -\begin{document} -\maketitle - -\begin{abstract} -\end{abstract} - -\tableofcontents -\eject - -\begin{verbatim} -PURPOSE: Provide generally useful macros and functions for MetaLanguage - and Boot code. Contents are organized along Common Lisp datatype - lines, with sections numbered to match the section headings of the - Common Lisp Reference Manual, by Guy Steele, Digital Press, 1984, - Digital Press Order Number EY-00031-DP. This way you can - look up the corresponding section in the manual and see if - there isn't a cleaner and non-VM-specific way of doing things. - -\end{verbatim} - -\section{Performance change} - -Camm has identified a performace problem during compiles. There is -a loop that continually adds one element to a vector. This causes -the vector to get extended by 1 and copied. These patches fix the -problem since vectors with fill pointers don't need to be copied. - -These cut out the lion's share of the gc problem -on this compile. 30min {\tt ->} 7 min on my box. There is still some gc -churning in cons pages due to many calls to 'list' with small n. One -can likely improve things further with an appropriate (declare -(:dynamic-extent ...)) in the right place -- gcl will allocate such -lists on the C stack (very fast). - -\subsection{lengthenvec} - -The original code was: -\begin{verbatim} -(defun lengthenvec (v n) - (if (adjustable-array-p v) (adjust-array v n) - (replace (make-array n) v))) -\end{verbatim} - -<>= -(defun lengthenvec (v n) - (if - (and (array-has-fill-pointer-p v) (adjustable-array-p v)) - (if - (>= n (array-total-size v)) - (adjust-array v (* n 2) :fill-pointer n) - (progn - (setf (fill-pointer v) n) - v)) - (replace (make-array n :fill-pointer t) v))) - -@ - -\subsection{make-init-vector} - -The original code was -\begin{verbatim} -(defun make-init-vector (n val) (make-array n :initial-element val)) -\end{verbatim} - -<>= -(defun make-init-vector (n val) - (make-array n :initial-element val :fill-pointer t)) - -@ - -\section{DEFUN CONTAINED} - -The [[CONTAINED]] predicate is used to walk internal structures -such as modemaps to see if the $X$ object occurs within $Y$. One -particular use is in a function called [[isPartialMode]] (see -i-funsel.boot) to decide -if a modemap is only partially complete. If this is true then the -modemap will contain the constant [[$EmptyMode]]. So the call -ends up being [[CONTAINED |$EmptyMode| Y]]. -<>= -#-:CCL -(DEFUN CONTAINED (X Y) - (if (symbolp x) - (contained\,eq X Y) - (contained\,equal X Y))) - -(defun contained\,eq (x y) - (if (atom y) (eq x y) - (or (contained\,eq x (car y)) (contained\,eq x (cdr y))))) - -(defun contained\,equal (x y) - (cond ((atom y) (equal x y)) - ((equal x y) 't) - ('t (or (contained\,equal x (car y)) (contained\,equal x (cdr y)))))) - -@ - -\section{License} - -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -(import-module "sys-macros") -(in-package "BOOT") - -; 5 PROGRAM STRUCTURE - -; 5.3 Top-Level Forms - -(defun SETANDFILE (x y) (LAM\,EVALANDFILEACTQ `(setq ,x ',y))) - -; 5.3.2 Declaring Global Variables and Named Constants - -(defun |functionp| (fn) - (if (identp fn) (and (fboundp fn) (not (macro-function fn))) (functionp fn))) -(defun |macrop| (fn) (and (identp fn) (macro-function fn))) - -; 6 PREDICATES - -; 6.2 Data Type Predicates - -; 6.3 Equality Predicates - -(defun COMPARE (X Y) - "True if X is an atom or X and Y are lists and X and Y are equal up to X." - (COND ((ATOM X) T) - ((ATOM Y) NIL) - ((EQUAL (CAR X) (CAR Y)) (COMPARE (CDR X) (CDR Y))))) - - -(DEFUN ?ORDER (U V) "Multiple-type ordering relation." - (COND ((NULL U)) - ((NULL V) NIL) - ((ATOM U) - (if (ATOM V) - (COND ((NUMBERP U) (if (NUMBERP V) (> V U) T)) - ((NUMBERP V) NIL) - ((IDENTP U) (AND (IDENTP V) (string> (SYMBOL-NAME V) (SYMBOL-NAME U)))) - ((IDENTP V) NIL) - ((STRINGP U) (AND (STRINGP V) (string> V U))) - ((STRINGP V) NIL) - ((AND (VECP U) (VECP V)) - (AND (> (SIZE V) (SIZE U)) - (DO ((I 0 (1+ I))) - ((GT I (MAXINDEX U)) 'T) - (COND ((NOT (EQUAL (ELT U I) (ELT V I))) - (RETURN (?ORDER (ELT U I) (ELT V I)))))))) - ((croak "Do not understand"))) - T)) - ((ATOM V) NIL) - ((EQUAL U V)) - ((NOT (string> (write-to-string U) (write-to-string V)))))) - -; 7 CONTROL STRUCTURE - -; 7.1 Constants and Variables - -; 7.1.1 Reference - -; 7.2 Generalized Variables - -; 7.3 Function Invocation - -; 7.8 Iteration - -; 7.8.2 General Iteration - -(defmacro |Zero| (&rest L) - (declare (ignore l)) - "Needed by spadCompileOrSetq" 0) - -(defmacro |One| (&rest L) - (declare (ignore l)) - "Needed by spadCompileOrSetq" 1) - - -; 7.8.4 Mapping - - - -; 7.10 Dynamic Non-local Exits - -; 10.1 The Property List - - - -(defun PROPERTY (X IND N) - "Returns the Nth element of X's IND property, if it exists." - (let (Y) (if (AND (INTEGERP N) (SETQ Y (GET X IND)) (>= (LENGTH Y) N)) (ELEM Y N)))) - -; 10.3 Creating Symbols - - -(defvar $GENNO 0) - -(DEFUN GENVAR () (INTERNL "$" (STRINGIMAGE (SETQ $GENNO (1+ $GENNO))))) - -(DEFUN IS_GENVAR (X) - (AND (IDENTP X) - (let ((y (symbol-name x))) - (and (char= #\$ (elt y 0)) (> (size y) 1) (digitp (elt y 1)))))) - -(DEFUN IS_\#GENVAR (X) - (AND (IDENTP X) - (let ((y (symbol-name x))) - (and (char= #\# (ELT y 0)) (> (SIZE Y) 1) (DIGITP (ELT Y 1)))))) - -; 10.7 CATCH and THROW - -; 12 NUMBERS - -; 12.3 Comparisons on Numbers - -; 12.4 Arithmetic Operations - -; 12.5 Irrational and Transcendental Functions - -; 12.5.1 Exponential and Logarithmic Functions - -; 12.6 Small Finite Field ops with vector trimming - -(defun TRIMLZ (vec) - (declare (simple-vector vec)) - (let ((n (position 0 vec :from-end t :test-not #'eql))) - (cond ((null n) (vector)) - ((eql n (qvmaxindex vec)) vec) - (t (subseq vec 0 (+ n 1)))))) - -;; In CCL ASH assumes a 2's complement machine. We use ASH in Integer and -;; assume we have a sign and magnitude setup. -#+:CCL (defmacro ash (u v) `(lisp::ash1 ,u ,v)) - -; 14 SEQUENCES - -; 14.1 Simple Sequence Functions - -(define-function 'getchar #'elt) - -(defun GETCHARN (A M) "Return the code of the Mth character of A" - (let ((a (if (identp a) (symbol-name a) a))) (char-code (elt A M)))) - -; 14.2 Concatenating, Mapping, and Reducing Sequences - -(DEFUN STRINGPAD (STR N) - (let ((M (length STR))) - (if (>= M N) - STR - (concatenate 'string str (make-string (- N M) :initial-element #\Space))))) - -(DEFUN STRINGSUFFIX (TARGET SOURCE) "Suffix source to target if enough room else nil." - (concatenate 'string target source)) - -(defun NSTRCONC (s1 s2) (concatenate 'string (string s1) (string s2))) - - -(define-function '|append| #'APPEND) - -;;(defun |delete| (item list) ; renaming from DELETE is done in DEF -;; (cond ((atom list) list) -;; ((equalp item (qcar list)) (|delete| item (qcdr list))) -;; ('t (cons (qcar list) (|delete| item (qcdr list)))))) - -(defun |delete| (item sequence) - (cond ((symbolp item) (remove item sequence :test #'eq)) - ((and (atom item) (not (arrayp item))) (remove item sequence)) - (T (remove item sequence :test #'equalp)))) - - - - - - -(defun THETACHECK (VAL VAR OP) (if (EQL VAL VAR) (THETA_ERROR OP) val)) - -; 15 LISTS - -; 15.1 Conses - - -; 15.2 Lists - - -(defmacro TL (&rest L) `(tail . ,L)) - - -(defmacro SPADCONST (&rest L) (cons 'qrefelt L)) - -(DEFUN LASTELEM (X) (car (last X))) - -(defun LISTOFATOMS (X) - (COND ((NULL X) NIL) - ((ATOM X) (LIST X)) - ((NCONC (LISTOFATOMS (CAR X)) (LISTOFATOMS (CDR X)))))) - -(DEFUN LASTATOM (L) (if (ATOM L) L (LASTATOM (CDR L)))) - -(define-function 'LASTTAIL #'last) - -(define-function 'LISPELT #'ELT) - -(defun DROP (N X &aux m) - "Return a pointer to the Nth cons of X, counting 0 as the first cons." - (COND ((EQL N 0) X) - ((> N 0) (DROP (1- N) (CDR X))) - ((>= (setq m (+ (length x) N)) 0) (take m x)) - ((CROAK (list "Bad args to DROP" N X))))) - -(DEFUN TAKE (N X &aux m) - "Returns a list of the first N elements of list X." - (COND ((EQL N 0) NIL) - ((> N 0) (CONS (CAR X) (TAKE (1- N) (CDR X)))) - ((>= (setq m (+ (length x) N)) 0) (drop m x)) - ((CROAK (list "Bad args to DROP" N X))))) - -(DEFUN NUMOFNODES (X) (if (ATOM X) 0 (+ 1 (NUMOFNODES (CAR X)) (NUMOFNODES (CDR X))))) - -(DEFUN TRUNCLIST (L TL) "Truncate list L at the point marked by TL." - (let ((U L)) (TRUNCLIST-1 L TL) U)) - -(DEFUN TRUNCLIST-1 (L TL) - (COND ((ATOM L) L) - ((EQL (CDR L) TL) (RPLACD L NIL)) - ((TRUNCLIST-1 (CDR L) TL)))) - -; 15.3 Alteration of List Structure - -(defun RPLACW (x w) (let (y z) (dsetq (Y . Z) w) (RPLACA X Y) (RPLACD X Z) X)) - -; 15.4 Substitution of Expressions - -(DEFUN SUBSTEQ (NEW OLD FORM) - "Version of SUBST that uses EQ rather than EQUAL on the world." - (PROG (NFORM HNFORM ITEM) - (SETQ HNFORM (SETQ NFORM (CONS () ()))) - LP (RPLACD NFORM - (COND ((EQ FORM OLD) (SETQ FORM ()) NEW ) - ((NOT (PAIRP FORM)) FORM ) - ((EQ (SETQ ITEM (CAR FORM)) OLD) (CONS NEW ()) ) - ((PAIRP ITEM) (CONS (SUBSTEQ NEW OLD ITEM) ()) ) - ((CONS ITEM ())))) - (if (NOT (PAIRP FORM)) (RETURN (CDR HNFORM))) - (SETQ NFORM (CDR NFORM)) - (SETQ FORM (CDR FORM)) - (GO LP))) - -(DEFUN SUBLISNQ (KEY E) (declare (special KEY)) (if (NULL KEY) E (SUBANQ E))) - -(DEFUN SUBANQ (E) - (declare (special key)) - (COND ((ATOM E) (SUBB KEY E)) - ((EQCAR E (QUOTE QUOTE)) E) - ((MAPCAR #'(LAMBDA (J) (SUBANQ J)) E)))) - -(DEFUN SUBB (X E) - (COND ((ATOM X) E) - ((EQ (CAAR X) E) (CDAR X)) - ((SUBB (CDR X) E)))) - -(defun SUBLISLIS (newl oldl form) - (sublis (mapcar #'cons oldl newl) form)) - -; 15.5 Using Lists as Sets - -<> - -(DEFUN PREDECESSOR (TL L) - "Returns the sublist of L whose CDR is EQ to TL." - (COND ((ATOM L) NIL) - ((EQ TL (CDR L)) L) - ((PREDECESSOR TL (CDR L))))) - -(defun remdup (l) (remove-duplicates l :test #'equalp)) - -(DEFUN GETTAIL (X L) (member X L :test #'equal)) - -; 15.6 Association Lists - - -;; FIXME: Should not this be named `alistAllKeys'? -(DEFUN ASSOCLEFT (X) - "Returns all the keys of association list X." - (if (ATOM X) - X - (mapcar #'car x))) - -;; FIXME: Should not this be named `alistAllValues'? -(DEFUN ASSOCRIGHT (X) - "Returns all the datums of association list X." - (if (ATOM X) - X - (mapcar #'cdr x))) - - -(DEFUN ADDASSOC (X Y L) - "Put the association list pair (X . Y) into L, erasing any previous association for X" - (COND ((ATOM L) - (CONS (CONS X Y) L)) - ((EQUAL X (CAAR L)) - (CONS (CONS X Y) (CDR L))) - ((CONS (CAR L) (ADDASSOC X Y (CDR L)))))) - -(DEFUN DELLASOS (U V) - "Remove any assocation pair (U . X) from list V." - (COND ((ATOM V) NIL) - ((EQUAL U (CAAR V)) - (CDR V)) - ((CONS (CAR V) (DELLASOS U (CDR V)))))) - - -;; FIXME: Should not this be named `alistValue'? -(DEFUN LASSOC (X Y) - "Return the datum associated with key X in association list Y." - (PROG NIL - A - (COND ((ATOM Y) - (RETURN NIL)) - ((EQUAL (CAAR Y) X) - (RETURN (CDAR Y))) ) - (SETQ Y (CDR Y)) - (GO A))) - -;; FIXME: Should not this be named `alistKey'? -(DEFUN |rassoc| (X Y) - "Return the key associated with datum X in association list Y." - (PROG NIL - A - (COND ((ATOM Y) - (RETURN NIL)) - ((EQUAL (CDAR Y) X) - (RETURN (CAAR Y))) ) - (SETQ Y (CDR Y)) - (GO A))) - -; (defun QLASSQ (p a-list) (let ((y (assoc p a-list :test #'eq))) (if y (cdr y)))) -(defun QLASSQ (p a-list) (cdr (assq p a-list))) - -(define-function 'LASSQ #'QLASSQ) - -(defun pair (x y) (mapcar #'cons x y)) - -;;; Operations on Association Sets (AS) - -(defun AS-INSERT (A B L) - ;; PF(item) x PF(item) x LIST(of pairs) -> LIST(of pairs with (A . B) added) - ;; destructive on L; if (A . C) appears already, C is replaced by B - (cond ((null l) (list (cons a b))) - ((equal a (caar l)) (rplac (cdar l) b) l) - ((?order a (caar l)) (cons (cons a b) l)) - (t (as-insert1 a b l) l))) - -(defun as-insert1 (a b l) - (cond ((null (cdr l)) (rplac (cdr l) (list (cons a b)))) - ((equal a (caadr l)) (rplac (cdadr l) b)) - ((?order a (caadr l)) (rplac (cdr l) (cons (cons a b) (cdr l)))) - (t (as-insert1 a b (cdr l))))) - - -; 17 ARRAYS - -; 17.6 Changing the Dimensions of an Array - - -<> -<> - -; 22 INPUT/OUTPUT - -; 22.2 Input Functions - -; 22.2.1 Input from Character Streams - -(DEFUN STREAM-EOF (&optional (STRM *terminal-io*)) - "T if input stream STRM is at the end or saw a ~." - (not (peek-char nil STRM nil nil nil)) ) - -(DEFUN CONSOLEINPUTP (STRM) (IS-CONSOLE STRM)) - -(defvar $filelinenumber 0) -(defvar $prompt "--->") -(defvar stream-buffer nil) - -(DEFUN NEXTSTRMLINE (STRM) "Returns the next input line from stream STRM." - (let ((v (read-line strm nil -1 nil))) - (if (equal v -1) (throw 'spad_reader nil) - (progn (setq stream-buffer v) v)))) - -(DEFUN CURSTRMLINE (STRM) - "Returns the current input line from the stream buffer of STRM (VM-specific!)." - (cond (stream-buffer) - ((stream-eof strm) (fail)) - ((nextstrmline strm)))) - -(defvar *EOF* NIL) - -(DEFUN CURMAXINDEX (STRM) -"Something bizarre and VM-specific with respect to streams." - (if *EOF* (FAIL) (ELT (ELT (LASTATOM STRM) 1) 3))) - -(DEFUN ADJCURMAXINDEX (STRM) -"Something unearthly and VM-specific with respect to streams." - (let (v) (if *eof* (fail) - (progn (SETQ V (ELT (LASTATOM STRM) 1)) - (SETELT V 3 (SIZE (ELT V 0))))))) - -(DEFUN STRMBLANKLINE (STRM) -"Something diabolical and VM-specific with respect to streams." - (if *EOF* (FAIL) (AND (EQ '\ (CAR STRM)) (EQL 1 (CURMAXINDEX STRM))))) - -(DEFUN STRMSKIPTOBLANK (STRM) -"Munch away on the stream until you get to a blank line." - (COND (*EOF* (FAIL)) - ((PROGN (NEXTSTRMLINE STRM) (STRMBLANKLINE STRM)) STRM) - ((STRMSKIPTOBLANK STRM)))) - -(DEFUN CURINPUTLINE () (CURSTRMLINE *standard-input*)) - -(DEFUN NEXTINPUTLINE () (NEXTSTRMLINE *standard-input*)) - -; 22.3 Output Functions - -; 22.3.1 Output to Character Streams - -(DEFUN ATOM2STRING (X) - "Give me the string which would be printed out to denote an atom." - (cond ((atom x) (symbol-name x)) - ((stringp x) x) - ((write-to-string x)))) - -(defvar |conOutStream| *terminal-io* "console output stream") - -(defun |sayTeX| (x) (if (null x) nil (sayBrightly1 x |$texOutputStream|))) - -(defun |sayNewLine| () (TERPRI)) - -(defvar |$sayBrightlyStream| nil "if not nil, gives stream for sayBrightly output") - -(defun |sayBrightly| (x &optional (out-stream *standard-output*)) - (COND ((NULL X) NIL) - (|$sayBrightlyStream| (sayBrightly1 X |$sayBrightlyStream|)) - ((IS-CONSOLE out-stream) (sayBrightly1 X out-stream)) - ((sayBrightly1 X out-stream) (sayBrightly1 X *terminal-io*)))) - -(defun |sayBrightlyI| (x &optional (s *terminal-io*)) - "Prints at console or output stream." - (if (NULL X) NIL (sayBrightly1 X S))) - -(defun |sayBrightlyNT| (x &optional (S *standard-output*)) - (COND ((NULL X) NIL) - (|$sayBrightlyStream| (sayBrightlyNT1 X |$sayBrightlyStream|)) - ((IS-CONSOLE S) (sayBrightlyNT1 X S)) - ((sayBrightly1 X S) (sayBrightlyNT1 X *terminal-io*)))) - -(defun sayBrightlyNT1 (X *standard-output*) - (if (ATOM X) (BRIGHTPRINT-0 X) (BRIGHTPRINT X))) - -(defun sayBrightly1 (X *standard-output*) - (if (ATOM X) - (progn (BRIGHTPRINT-0 X) (TERPRI) (force-output)) - (progn (BRIGHTPRINT X) (TERPRI) (force-output)))) - -(defvar |$algebraOutputStream| *standard-output*) - -(defun |saySpadMsg| (X) - (if (NULL X) NIL (sayBrightly1 X |$algebraOutputStream|))) - -(defun |sayALGEBRA| (X) "Prints on Algebra output stream." - (if (NULL X) NIL (sayBrightly1 X |$algebraOutputStream|))) - -(defun |sayMSG| (X) - (if (NULL X) NIL (sayBrightly1 X |$algebraOutputStream|))) - -(defun |sayMSGNT| (X) - (if (NULL X) NIL (sayBrightlyNT1 X |$algebraOutputStream|))) - -(defun |sayMSG2File| (msg) - (PROG (file str) - (SETQ file (|makePathname| '|spadmsg| '|listing| |$listingDirectory|)) - (SETQ str - (DEFIOSTREAM - (CONS '(MODE . OUTPUT) (CONS (CONS 'FILE file) NIL)) - 255 0)) - (sayBrightly1 msg str) - (SHUT str) ) ) - -(defvar |$fortranOutputStream|) - -(defun |sayFORTRAN| (x) "Prints on Fortran output stream." - (if (NULL X) NIL (sayBrightly1 X |$fortranOutputStream|))) - -(defvar |$formulaOutputStream|) - -(defun |sayFORMULA| (X) "Prints on formula output stream." - (if (NULL X) NIL (sayBrightly1 X |$formulaOutputStream|))) - -(defvar |$highlightAllowed| nil "Used in BRIGHTPRINT and is a )set variable.") - -(defvar |$highlightFontOn| |$boldString| "switch to highlight font") -(defvar |$highlightFontOff| |$normalString| "return to normal font") - -;; the following are redefined in MSGDB BOOT - -;; --------------------> NEW DEFINITION (override in msgdb.boot.pamphlet) -(DEFUN BRIGHTPRINT (X) (MESSAGEPRINT X)) - -;; --------------------> NEW DEFINITION (override in msgdb.boot.pamphlet) -(DEFUN BRIGHTPRINT-0 (x) (MESSAGEPRINT-1 X)) - -(DEFUN BLANKS (N &optional (stream *standard-output*)) "Print N blanks." - (do ((i 1 (the fixnum(1+ i)))) - ((> i N))(declare (fixnum i n)) (princ " " stream))) - -; 23 FILE SYSTEM INTERFACE - -; 23.2 Opening and Closing Files - -(DEFUN DEFSTREAM (file MODE) - (if (member mode '(i input)) - (MAKE-INSTREAM file) - (MAKE-OUTSTREAM file))) - -; 23.3 Renaming, Deleting and Other File Operations - -(DEFUN NOTE (STRM) -"Attempts to return the current record number of a file stream. This is 0 for -terminals and empty or at-end files. In Common Lisp, we must assume record sizes of 1!" - (COND ((STREAM-EOF STRM) 0) - ((IS-CONSOLE STRM) 0) - ((file-position STRM)))) - -(DEFUN IS-CONSOLE-NOT-XEDIT (S) (not (OR (NULL (IS-CONSOLE S))))) - -(DEFUN POINTW (RECNO STRM) -"Does something obscure and VM-specific with respect to streams." - (let (V) - (if (STREAM-EOF STRM) (FAIL)) - (SETQ V (LASTATOM STRM)) - (SETELT V 4 RECNO) - (SETQ *EOF* (STREAM-EOF STRM)) - strm)) - -(DEFUN POINT (RECNO STRM) (file-position strm recno)) - -(DEFUN STRM (RECNO STRM) -"Does something obscure and VM-specific with respect to streams." - (let (V) - (if (STREAM-EOF STRM) (FAIL)) - (SETQ V (LASTATOM STRM)) - (SETELT V 4 RECNO) - (read-char STRM) - (SETQ *EOF* (STREAM-EOF STRM)) - strm)) - -; 25 MISCELLANEOUS FEATURES - -;; range tests and assertions - -(defmacro |assert| (x y) `(IF (NULL ,x) (|error| ,y))) - -(defun coerce-failure-msg (val mode) - (STRCONC (MAKE-REASONABLE (STRINGIMAGE val)) - " cannot be coerced to mode " - (STRINGIMAGE (|devaluate| mode)))) - -(defmacro |check-subtype| (pred submode val) - `(|assert| ,pred (coerce-failure-msg ,val ,submode))) - -(defmacro |check-union| (pred branch val) - `(|assert| ,pred (coerce-failure-msg ,val ,branch ))) - -(defun MAKE-REASONABLE (Z) - (if (> (length Z) 30) (CONCAT "expression beginning " (subseq Z 0 20)) Z)) - - -(defmacro |elapsedUserTime| () '(get-internal-run-time)) - -#+IBCL -(defmacro |elapsedGcTime| () '(system:gbc-time-report)) -#+AKCL -(defmacro |elapsedGcTime| () '(system:gbc-time)) -#+:CCL -(defmacro |elapsedGcTime| () '(lisp:gctime)) -#-(OR :CCL IBCL AKCL) -(defmacro |elapsedGcTime| () '0) - -(defmacro |do| (&rest args) (CONS 'PROGN args)) - -(defun DROPTRAILINGBLANKS (LINE) (string-right-trim " " LINE)) - -(defun print-and-eval-defun (name body) - (eval body) - (print-defun name body) - ;; (set name (symbol-function name)) ;; this should go away - ) - -(defun eval-defun (name body) (eval (macroexpandall body))) - -; This function was modified by Greg Vanuxem on March 31, 2005 -; to handle the special case of #'(lambda ..... which expands -; into (function (lambda ..... -; -; The extra if clause fixes bugs #196 and #114 -; -; an example that used to cause the failure was: -; )set func comp off -; f(xl:LIST FRAC INT): LIST FRAC INT == map(x +-> x, xl) -; f [1,2,3] -; -; which expanded into -; -; (defun |xl;f;1;initial| (|#1| |envArg|) -; (prog (#:G1420) -; (return -; (progn -; (lett #:G1420 'uninitialized_variable |f| |#1;f;1:initial|) -; (spadcall -; (cons (|function| (lambda (#:G1420 |envArg|) #:G1420)) (vector)) -; |#1| -; (qrefelt |*1;f;1;initial;MV| 0)))))) -; -; the (|function| (lambda form used to cause an infinite expansion loop -; -(defun macroexpandall (sexpr) - (cond - ((atom sexpr) sexpr) - ((eq (car sexpr) 'quote) sexpr) - ((eq (car sexpr) 'defun) - (cons (car sexpr) (cons (cadr sexpr) - (mapcar #'macroexpandall (cddr sexpr))))) - ((and (symbolp (car sexpr)) (macro-function (car sexpr))) - (do () - ((not (and (consp sexpr) (symbolp (car sexpr)) - (macro-function (car sexpr))))) - (setq sexpr (macroexpand sexpr))) - (if (consp sexpr) - (let ((a (car sexpr)) (b (caadr sexpr))) - (if (and (eq a 'function) (eq b 'lambda)) - (cons a (list (cons b (mapcar #'macroexpandall (cdadr sexpr))))) - (mapcar #'macroexpandall sexpr))) - sexpr)) - ('else - (mapcar #'macroexpandall sexpr)))) - - -(defun compile-defun (name body) (eval body) (compile name)) - - -(defun |deleteWOC| (item list) (delete item list :test #'equal)) - -;;---- Added by WFS. - -(proclaim '(ftype (function (t t) t) |subWord|)) ;hack for bug in akcl-478 - -(DEFUN |subWord| (|str| N ) - (declare (fixnum n ) (string |str|)) - (PROG (|word| (|n| 0) |inWord|(|l| 0) ) - (declare (fixnum |n| |l|)) - (RETURN - (SEQ (COND - ((> 1 N) NIL) - ('T (SPADLET |l| (SPADDIFFERENCE (|#| |str|) 1)) - (COND - ((EQL |l| 0) NIL) - ('T (SPADLET |n| 0) (SPADLET |word| '||) - (SPADLET |inWord| NIL) - (DO ((|i| 0 (QSADD1 |i|))) ((QSGREATERP |i| |l|) NIL) - (declare (fixnum |i|)) - (SEQ (EXIT (COND - ((eql (aref |str| |i|) #\space) - (COND - ((NULL |inWord|) NIL) - ((eql |n| N) (RETURN |word|)) - ('T (SPADLET |inWord| NIL)))) - ('T - (COND - ((NULL |inWord|) - (SPADLET |inWord| 'T) - (SPADLET |n| (PLUS |n| 1)))) - (COND - ((eql |n| N) - (cond ((eq |word| '||) - (setq |word| - (make-array 10 :adjustable t - :element-type 'standard-char - :fill-pointer 0)))) - (or |word| (error "bad")) - (vector-push-extend (aref |str| |i|) - (the string |word|) - ) - ) - ('T NIL))))))) - (COND ((> N |n|) NIL) ('T |word|)))))))))) - -(defun print-full (expr &optional (stream *standard-output*)) - (let ((*print-circle* t) (*print-array* t) *print-level* *print-length*) - (print expr stream) - (terpri stream) - (finish-output stream))) - -;; moved here from preparse.lisp - -(defun NEXT-TAB-LOC (i) (* (1+ (truncate i 8)) 8)) - -(defun INDENT-POS (STR) - (do ((i 0 (1+ i)) - (pos 0)) - ((>= i (length str)) nil) - (case (char str i) - (#\space (incf pos)) - (#\tab (setq pos (next-tab-loc pos))) - (otherwise (return pos))))) - -;;(defun expand-tabs (str) -;; (let ((bpos (nonblankloc str)) -;; (tpos (indent-pos str))) -;; (if (eql bpos tpos) str -;; (concatenate 'string (make-string tpos :initial-element #\space) -;; (subseq str bpos))))) -(defun expand-tabs (str) - (if (and (stringp str) (> (length str) 0)) - (let ((bpos (nonblankloc str)) - (tpos (indent-pos str))) - (setq str - (if (eql bpos tpos) - str - (concatenate 'string - (make-string tpos :initial-element #\space) - (subseq str bpos)))) - ;; remove dos CR - (let ((lpos (maxindex str))) - (if (eq (char str lpos) #\Return) (subseq str 0 lpos) str))) - str)) - -(defun blankp (char) (or (eq char #\Space) (eq char #\tab))) - -(defun nonblankloc (str) (position-if-not #'blankp str)) - -;; stream handling for paste-in generation - -(defun |applyWithOutputToString| (func args) - ;; returns the cons of applying func to args and a string produced - ;; from standard-output while executing. - (let* ((out-stream (make-string-output-stream)) - (curoutstream out-stream) - (|$algebraOutputStream| out-stream) - (erroroutstream out-stream) - val) - (declare (special curoutstream |$algebraOutputStream|)) - (setq *standard-output* out-stream) - (setq *terminal-io* out-stream) - (setq val (catch 'spad_reader - (catch 'TOP_LEVEL - (apply (symbol-function func) args)))) - (cons val (get-output-stream-string *standard-output*)))) - -(defun |breakIntoLines| (str) - (let ((bol 0) (eol) (line-list nil)) - (loop - (setq eol (position #\Newline str :start bol)) - (if (null eol) (return)) - (if (> eol bol) - (setq line-list (cons (subseq str bol eol) line-list))) - (setq bol (+ eol 1))) - (nreverse line-list))) - -; part of the old spad to new spad translator -; these are here because they need to be in depsys -; they were in nspadaux.lisp - -(defmacro wi (a b) b) - -(defmacro |try| (X) - `(LET ((|$autoLine|)) - (declare (special |$autoLine|)) - (|tryToFit| (|saveState|) ,X))) - -(defmacro |embrace| (X) `(|wrapBraces| (|saveC|) ,X (|restoreC|))) -(defmacro |indentNB| (X) `(|wrapBraces| (|saveD|) ,X (|restoreD|))) - -(defmacro |tryBreak| (a b c d) -; Try to format by: -; (1) with no line breaking ($autoLine = nil) -; (2) with possible line breaks within a; -; (3) otherwise use a brace - `(LET - ((state)) - (setq state (|saveState| 't)) - (or - (LET ((|$autoLine|)) - (declare (special |$autoLine|)) - (and ,a (|formatRight| '|formatPreferPile| ,b ,c ,d))) - (|restoreState| state) - (and (eqcar ,b (quote seq)) - (|embrace| (and - ,a - (|formatLB|) - (|formatRight| '|formatPreferPile| ,b ,c ,d)))) - (|restoreState| state) - (|embrace| (and ,a - (|formatLB|) - (|formatRight| '|formatPreferPile| ,b ,c ,d)))))) - -(defmacro |tryBreakNB| (a b c d) -; Try to format by: -; (1) with no line breaking ($autoLine = nil) -; (2) with possible line breaks within a; -; (3) otherwise display without a brace - `(LET - ((state)) - (setq state (|saveState| 't)) - (or - (markhash ,b 0) - (LET ((|$autoLine|)) - (declare (special |$autoLine|)) - (and ,a (|formatRight| '|formatPreferPile| ,b ,c ,d))) - (|restoreState| state) - (markhash ,b 1) - (and (eqcar ,b (quote seq)) - (|embrace| (and - ,a - (|formatLB|) - (|formatRight| '|formatPreferPile| ,b ,c ,d)))) - (markhash ,b 2) - (|restoreState| state) - (|indentNB| (and ,a - (|formatRight| '|formatPreferPile| ,b ,c ,d))) - (markhash ,b 3) - -))) - -(defvar HT nil) - -(defun markhash (key n) (progn (cond - ((equal n 3) (remhash key ht)) - ('t (hput ht key n)) ) nil)) - -;; -;; -*- Record Structures -*- -;; - -(defmacro |Record| (&rest x) - `(|Record0| (LIST ,@(COLLECT (IN Y X) - (list 'CONS (MKQ (CADR Y)) (CADDR Y)))))) - -(defmacro |:| (tag expr) - `(LIST '|:| ,(MKQ tag) ,expr)) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/metalex.lisp b/src/interp/metalex.lisp index aa5be9ba..06e13fc5 100644 --- a/src/interp/metalex.lisp +++ b/src/interp/metalex.lisp @@ -1,5 +1,7 @@ ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are diff --git a/src/interp/monitor.lisp b/src/interp/monitor.lisp new file mode 100644 index 00000000..28477ea7 --- /dev/null +++ b/src/interp/monitor.lisp @@ -0,0 +1,474 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + +(in-package "BOOT") + +(defun monitor-help () + (format t "~% +;;; MONITOR +;;; +;;; This file contains a set of function for monitoring the execution +;;; of the functions in a file. It constructs a hash table that contains +;;; the function name as the key and monitor-data structures as the value +;;; +;;; The technique is to use a :cond parameter on trace to call the +;;; monitor-incr function to incr the count every time a function is called +;;; +;;; *monitor-table* HASH TABLE +;;; is the monitor table containing the hash entries +;;; *monitor-nrlibs* LIST of STRING +;;; list of NRLIB filenames that are monitored +;;; *monitor-domains* LIST of STRING +;;; list of domains to monitor-report (default is all exposed domains) +;;; monitor-data STRUCTURE +;;; is the defstruct name of records in the table +;;; name is the first field and is the name of the monitored function +;;; count contains a count of times the function was called +;;; monitorp is a flag that skips counting if nil, counts otherwise +;;; sourcefile is the name of the file that contains the source code +;;; +;;; ***** SETUP, SHUTDOWN **** +;;; +;;; monitor-inittable () FUNCTION +;;; creates the hashtable and sets *monitor-table* +;;; note that it is called every time this file is loaded +;;; monitor-end () FUNCTION +;;; unhooks all of the trace hooks +;;; +;;; ***** TRACE, UNTRACE ***** +;;; +;;; monitor-add (name &optional sourcefile) FUNCTION +;;; sets up the trace and adds the function to the table +;;; monitor-delete (fn) FUNCTION +;;; untraces a function and removes it from the table +;;; monitor-enable (&optional fn) FUNCTION +;;; starts tracing for all (or optionally one) functions that +;;; are in the table +;;; monitor-disable (&optional fn) FUNCTION +;;; stops tracing for all (or optionally one) functions that +;;; are in the table +;;; +;;; ***** COUNTING, RECORDING ***** +;;; +;;; monitor-reset (&optional fn) FUNCTION +;;; reset the table count for the table (or optionally, for a function) +;;; monitor-incr (fn) FUNCTION +;;; increments the count information for a function +;;; it is called by trace to increment the count +;;; monitor-decr (fn) FUNCTION +;;; decrements the count information for a function +;;; monitor-info (fn) FUNCTION +;;; returns the monitor-data structure for a function +;;; +;;; ***** FILE IO ***** +;;; +;;; monitor-write (items file) FUNCTION +;;; writes a list of symbols or structures to a file +;;; monitor-file (file) FUNCTION +;;; will read a file, scan for defuns, monitor each defun +;;; NOTE: monitor-file assumes that the file has been loaded +;;; +;;; ***** RESULTS ***** +;;; +;;; monitor-results () FUNCTION +;;; returns a list of the monitor-data structures +;;; monitor-untested () FUNCTION +;;; returns a list of files that have zero counts +;;; monitor-tested (&optional delete) FUNCTION +;;; returns a list of files that have nonzero counts +;;; optionally calling monitor-delete on those functions +;;; +;;; ***** CHECKPOINT/RESTORE ***** +;;; +;;; monitor-checkpoint (file) FUNCTION +;;; save the *monitor-table* in a loadable form +;;; monitor-restore (file) FUNCTION +;;; restore a checkpointed file so that everything is monitored +;;; +;;; ***** ALGEBRA ***** +;;; +;;; monitor-autoload () FUNCTION +;;; traces autoload of algebra to monitor corresponding source files +;;; NOTE: this requires the /spad/int/algebra directory +;;; monitor-dirname (args) FUNCTION +;;; expects a list of 1 libstream (loadvol's arglist) and monitors the source +;;; this is a function called by monitor-autoload +;;; monitor-nrlib (nrlib) FUNCTION +;;; takes an nrlib name as a string (eg POLY) and returns a list of +;;; monitor-data structures from that source file +;;; monitor-report () FUNCTION +;;; generate a report of the monitored activity for domains in +;;; *monitor-domains* +;;; monitor-spadfile (name) FUNCTION +;;; given a spad file, report all NRLIBS it creates +;;; this adds each NRLIB name to *monitor-domains* but does not +;;; trace the functions from those domains +;;; monitor-percent () FUNCTION +;;; ratio of (functions executed)/(functions traced) +;;; monitor-apropos (str) FUNCTION +;;; given a string, find all monitored symbols containing the string +;;; the search is case-insensitive. returns a list of monitor-data items +") nil) + +(defvar *monitor-domains* nil "a list of domains to report") + +(defvar *monitor-nrlibs* nil "a list of nrlibs that have been traced") + +(defvar *monitor-table* nil "a table of all of the monitored data") + +(defstruct monitor-data name count monitorp sourcefile) + +(unless (fboundp 'libstream-dirname) + (defstruct libstream mode dirname (indextable nil) (indexstream nil))) + +(defun monitor-inittable () + "initialize the table" + (setq *monitor-table* (make-hash-table))) + +(eval-when (eval load) + (unless *monitor-table* (monitor-inittable))) + +(defun monitor-end () + "stop the whole monitoring process. we cannot restart" + (maphash + #'(lambda (key value) + (declare (ignore value)) + (eval `(untrace ,key))) + *monitor-table*)) + +(defun monitor-results () + "return a list of the monitor-data structures" + (let (result) + (maphash + #'(lambda (key value) + (declare (ignore key)) + (push value result)) + *monitor-table*) + result)) + +(defun monitor-add (name &optional sourcefile) + "add a function to the hash table" + (unless (fboundp name) (load sourcefile)) + (when (gethash name *monitor-table*) + (monitor-delete name)) + (eval `(trace (,name :cond (progn (monitor-incr ',name) nil)))) + (setf (gethash name *monitor-table*) + (make-monitor-data + :name name :count 0 :monitorp t :sourcefile sourcefile))))) + +(defun monitor-delete (fn) + "delete a function from the monitor table" + (eval `(untrace ,fn)) + (remhash fn *monitor-table*)) + +(defun monitor-enable (&optional fn) + "enable all (or optionally one) function for monitoring" + (if fn + (progn + (eval `(trace (,fn :cond (progn (monitor-incr ',fn) nil)))) + (setf (monitor-data-monitorp (gethash fn *monitor-table*)) t)) + (maphash + #'(lambda (key value) + (declare (ignore value)) + (eval `(trace (,fn :cond (progn (monitor-incr ',fn) nil)))) + (setf (monitor-data-monitorp (gethash key *monitor-table*)) t)) + *monitor-table*))) + +(defun monitor-disable (&optional fn) + "disable all (or optionally one) function for monitoring" + (if fn + (progn + (eval `(untrace ,fn)) + (setf (monitor-data-monitorp (gethash fn *monitor-table*)) nil)) + (maphash + #'(lambda (key value) + (declare (ignore value)) + (eval `(untrace ,fn)) + (setf (monitor-data-monitorp (gethash key *monitor-table*)) nil)) + *monitor-table*))) + +(defun monitor-reset (&optional fn) + "reset the table count for the table (or optionally, for a function)" + (if fn + (setf (monitor-data-count (gethash fn *monitor-table*)) 0) + (maphash + #'(lambda (key value) + (declare (ignore value)) + (setf (monitor-data-count (gethash key *monitor-table*)) 0)) + *monitor-table*))) + +(defun monitor-incr (fn) + "incr the count of fn by 1" + (let (data) + (setq data (gethash fn *monitor-table*)) + (if data + (incf (monitor-data-count data)) ;; change table entry by side-effect + (warn "~s is monitored but not in table..do (untrace ~s)~%" fn fn)))) + +(defun monitor-decr (fn) + "decr the count of fn by 1" + (let (data) + (setq data (gethash fn *monitor-table*)) + (if data + (decf (monitor-data-count data)) ;; change table entry by side-effect + (warn "~s is monitored but not in table..do (untrace ~s)~%" fn fn)))) + +(defun monitor-info (fn) + "return the information for a function" + (gethash fn *monitor-table*)) + +(defun monitor-file (file) + "hang a monitor call on all of the defuns in a file" + (let (expr (package "BOOT")) + (format t "monitoring ~s~%" file) + (with-open-file (in file) + (catch 'done + (loop + (setq expr (read in nil 'done)) + (when (eq expr 'done) (throw 'done nil)) + (if (and (consp expr) (eq (car expr) 'in-package)) + (if (and (consp (second expr)) (eq (first (second expr)) 'quote)) + (setq package (string (second (second expr)))) + (setq package (second expr))) + (when (and (consp expr) (eq (car expr) 'defun)) + (monitor-add (intern (string (second expr)) package) file)))))))) + +(defun monitor-untested () + "return a list of the functions with zero count fields" + (let (result) + (maphash + #'(lambda (key value) + (if (and (monitor-data-monitorp value) (= (monitor-data-count value) 0)) + (push key result))) + *monitor-table*) + result)) + +(defun monitor-tested (&optional delete) + "return a list of the functions with non-zero count fields, optionally deleting them" + (let (result) + (maphash + #'(lambda (key value) + (when (and (monitor-data-monitorp value) (> (monitor-data-count value) 0)) + (when delete (monitor-delete key)) + (push key result))) + *monitor-table*) + result)) + +(defun monitor-write (items file) + "write out a list of symbols or structures to a file" + (with-open-file (out file :direction :output) + (dolist (item items) + (if (symbolp item) + (format out "~s~%" item) + (format out "~s~50t~s~100t~s~%" + (monitor-data-sourcefile item) + (monitor-data-name item) + (monitor-data-count item)))))) + +(defun monitor-checkpoint (file) + "save the *monitor-table* in loadable form" + (let ((*print-package* t)) + (declare (special *print-package*)) + (with-open-file (out file :direction :output) + (format out "(in-package \"BOOT\")~%") + (format out "(monitor-inittable)~%") + (dolist (data (monitor-results)) + (format out "(monitor-add '~s ~s)~%" + (monitor-data-name data) + (monitor-data-sourcefile data)) + (format out "(setf (gethash '~s *monitor-table*) + (make-monitor-data :name '~s :count ~s :monitorp ~s + :sourcefile ~s))~%" + (monitor-data-name data) + (monitor-data-name data) + (monitor-data-count data) + (monitor-data-monitorp data) + (monitor-data-sourcefile data)))))) + +(defun monitor-restore (file) + "restore a checkpointed file so that everything is monitored" + (load file)) + +;; these functions are used for testing the algebra code + +(defun monitor-dirname (args) + "expects a list of 1 libstream (loadvol's arglist) and monitors the source" + (let (name) + (setq name (libstream-dirname (car args))) + (setq name (file-namestring name)) + (setq name (concatenate 'string "/spad/int/algebra/" name "/code.lsp")) + (when (probe-file name) + (push name *monitor-nrlibs*) + (monitor-file name)))) + +(defun monitor-autoload () + "traces autoload of algebra to monitor corresponding source files" + (trace (loadvol + :entrycond nil + :exitcond (progn (monitor-dirname system::arglist) nil)))) + +(defun monitor-nrlib (nrlib) + "takes an nrlib name as a string (eg POLY) and returns a list of + monitor-data structures from that source file" + (let (result) + (maphash + #'(lambda (k v) + (declare (ignore k)) + (when (string= nrlib + (pathname-name (car (last + (pathname-directory (monitor-data-sourcefile v)))))) + (push v result))) + *monitor-table*) + result)) + +(defun monitor-libname (item) + "given a monitor-data item, extract the NRLIB name" + (pathname-name (car (last + (pathname-directory (monitor-data-sourcefile item)))))) + +(defun monitor-exposedp (fn) + "exposed functions have more than 1 semicolon. given a symbol, count them" + (> (count #\; (symbol-name fn)) 1)) + +(defun monitor-readinterp () + "read INTERP.EXPOSED to initialize *monitor-domains* to exposed domains. + this is the default action. adding or deleting domains from the list + will change the report results" + (let (skip expr name) + (declare (special *monitor-domains*)) + (setq *monitor-domains* nil) + (with-open-file (in "/spad/src/algebra/INTERP.EXPOSED") + (read-line in) + (read-line in) + (read-line in) + (read-line in) + (catch 'done + (loop + (setq expr (read-line in nil "done")) + (when (string= expr "done") (throw 'done nil)) + (cond + ((string= expr "basic") (setq skip nil)) + ((string= expr "categories") (setq skip t)) + ((string= expr "hidden") (setq skip t)) + ((string= expr "defaults") (setq skip nil))) + (when (and (not skip) (> (length expr) 58)) + (setq name (subseq expr 58 (length expr))) + (setq name (string-right-trim '(#\space) name)) + (when (> (length name) 0) + (push name *monitor-domains*)))))))) + +(defun monitor-report () + "generate a report of the monitored activity for domains in *monitor-domains*" + (let (nrlibs nonzero total) + (unless *monitor-domains* (monitor-readinterp)) + (setq nonzero 0) + (setq total 0) + (maphash + #'(lambda (k v) + (declare (ignore k)) + (let (nextlib point) + (when (> (monitor-data-count v) 0) (incf nonzero)) + (incf total) + (setq nextlib (monitor-libname v)) + (setq point (member nextlib nrlibs :test #'string= :key #'car)) + (if point + (setf (cdr (first point)) (cons v (cdr (first point)))) + (push (cons nextlib (list v)) nrlibs)))) + *monitor-table*) + (format t "~d of ~d (~d percent) tested~%" nonzero total + (round (/ (* 100.0 nonzero) total))) + (setq nrlibs (sort nrlibs #'string< :key #'car)) + (dolist (pair nrlibs) + (let ((exposedcount 0) (testcount 0)) + (when (member (car pair) *monitor-domains* :test #'string=) + (format t "for library ~s~%" (car pair)) + (dolist (item (sort (cdr pair) #'> :key #'monitor-data-count)) + (when (monitor-exposedp (monitor-data-name item)) + (incf exposedcount) + (when (> (monitor-data-count item) 0) (incf testcount)) + (format t "~5d ~s~%" + (monitor-data-count item) + (monitor-data-name item)))) + (if (= exposedcount testcount) + (format t "~a has all exposed functions tested~%" (car pair)) + (format t "Daly bug:~a has untested exposed functions~%" (car pair)))))) + nil)) + +(defun monitor-parse (expr) + (let (point1 point2) + (setq point1 (position #\space expr :test #'char=)) + (setq point1 (position #\space expr :start point1 :test-not #'char=)) + (setq point1 (position #\space expr :start point1 :test #'char=)) + (setq point1 (position #\space expr :start point1 :test-not #'char=)) + (setq point2 (position #\space expr :start point1 :test #'char=)) + (subseq expr point1 point2))) + +(defun monitor-spadfile (name) + "given a spad file, report all NRLIBS it creates" + (let (expr) + (with-open-file (in name) + (catch 'done + (loop + (setq expr (read-line in nil 'done)) + (when (eq expr 'done) (throw 'done nil)) + (when (and (> (length expr) 4) (string= (subseq expr 0 4) ")abb")) + (setq *monitor-domains* + (adjoin (monitor-parse expr) *monitor-domains* :test #'string=)))))))) + +(defun monitor-percent () + (let (nonzero total) + (setq nonzero 0) + (setq total 0) + (maphash + #'(lambda (k v) + (declare (ignore k)) + (when (> (monitor-data-count v) 0) (incf nonzero)) + (incf total)) + *monitor-table*) + (format t "~d of ~d (~d percent) tested~%" nonzero total + (round (/ (* 100.0 nonzero) total))))) + +(defun monitor-apropos (str) + "given a string, find all monitored symbols containing the string + the search is case-insensitive. returns a list of monitor-data items" + (let (result) + (maphash + #'(lambda (k v) + (when + (search (string-upcase str) + (string-upcase (symbol-name k)) + :test #'string=) + (push v result))) + *monitor-table*) + result)) diff --git a/src/interp/monitor.lisp.pamphlet b/src/interp/monitor.lisp.pamphlet deleted file mode 100644 index 47fc8fd4..00000000 --- a/src/interp/monitor.lisp.pamphlet +++ /dev/null @@ -1,806 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp monitor.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{verbatim} -MONITOR - -This file contains a set of function for monitoring the execution -of the functions in a file. It constructs a hash table that contains -the function name as the key and monitor-data structures as the value - -The technique is to use a :cond parameter on trace to call the -monitor-incr function to incr the count every time a function is called - -*monitor-table* HASH TABLE - is the monitor table containing the hash entries -*monitor-nrlibs* LIST of STRING - list of NRLIB filenames that are monitored -*monitor-domains* LIST of STRING - list of domains to monitor-report (default is all exposed domains) -monitor-data STRUCTURE - is the defstruct name of records in the table - name is the first field and is the name of the monitored function - count contains a count of times the function was called - monitorp is a flag that skips counting if nil, counts otherwise - sourcefile is the name of the file that contains the source code - - ***** SETUP, SHUTDOWN **** - -monitor-inittable () FUNCTION - creates the hashtable and sets *monitor-table* - note that it is called every time this file is loaded -monitor-end () FUNCTION - unhooks all of the trace hooks - - ***** TRACE, UNTRACE ***** - -monitor-add (name &optional sourcefile) FUNCTION - sets up the trace and adds the function to the table -monitor-delete (fn) FUNCTION - untraces a function and removes it from the table -monitor-enable (&optional fn) FUNCTION - starts tracing for all (or optionally one) functions that - are in the table -monitor-disable (&optional fn) FUNCTION - stops tracing for all (or optionally one) functions that - are in the table - -***** COUNTING, RECORDING ***** - -monitor-reset (&optional fn) FUNCTION - reset the table count for the table (or optionally, for a function) -monitor-incr (fn) FUNCTION - increments the count information for a function - it is called by trace to increment the count -monitor-decr (fn) FUNCTION - decrements the count information for a function -monitor-info (fn) FUNCTION - returns the monitor-data structure for a function - -***** FILE IO ***** - -monitor-write (items file) FUNCTION - writes a list of symbols or structures to a file -monitor-file (file) FUNCTION - will read a file, scan for defuns, monitor each defun - NOTE: monitor-file assumes that the file has been loaded - -***** RESULTS ***** - -monitor-results () FUNCTION - returns a list of the monitor-data structures -monitor-untested () FUNCTION - returns a list of files that have zero counts -monitor-tested (&optional delete) FUNCTION - returns a list of files that have nonzero counts - optionally calling monitor-delete on those functions - -***** CHECKPOINT/RESTORE ***** -monitor-checkpoint (file) FUNCTION - save the *monitor-table* in a loadable form -monitor-restore (file) FUNCTION - restore a checkpointed file so that everything is monitored - -***** ALGEBRA ***** -monitor-autoload () FUNCTION - traces autoload of algebra to monitor corresponding source files - NOTE: this requires the /spad/int/algebra directory -monitor-dirname (args) FUNCTION - expects a list of 1 libstream (loadvol's arglist) and monitors the source - this is a function called by monitor-autoload -monitor-nrlib (nrlib) FUNCTION - takes an nrlib name as a string (eg POLY) and returns a list of - monitor-data structures from that source file -monitor-report () FUNCTION - generate a report of the monitored activity for domains in - *monitor-domains* -monitor-spadfile (name) FUNCTION - given a spad file, report all NRLIBS it creates - this adds each NRLIB name to *monitor-domains* but does not - trace the functions from those domains -monitor-percent () FUNCTION - ratio of (functions executed)/(functions traced) -monitor-apropos (str) FUNCTION - given a string, find all monitored symbols containing the string - the search is case-insensitive. returns a list of monitor-data items - -for example: - suppose we have a file "/u/daly/testmon.lisp" that contains: - (defun foo1 () (print 'foo1)) - (defun foo2 () (print 'foo2)) - (defun foo3 () (foo1) (foo2) (print 'foo3)) - (defun foo4 () (print 'foo4)) - - an example session is: - - ; FIRST WE LOAD THE FILE (WHICH INITS *monitor-table*) - - >(load "/u/daly/monitor.lisp") - Loading /u/daly/monitor.lisp - Finished loading /u/daly/monitor.lisp - T - - ; SECOND WE LOAD THE TESTMON FILE - >(load "/u/daly/testmon.lisp") - T - - ; THIRD WE MONITOR THE FILE - >(monitor-file "/u/daly/testmon.lisp") - monitoring "/u/daly/testmon.lisp" - NIL - - ; FOURTH WE CALL A FUNCTION FROM THE FILE (BUMP ITS COUNT) - >(foo1) - - FOO1 - FOO1 - - ; AND ANOTHER FUNCTION (BUMP ITS COUNT) - >(foo2) - - FOO2 - FOO2 - - ; AND A THIRD FUNCTION THAT CALLS THE OTHER TWO (BUMP ALL THREE) - >(foo3) - - FOO1 - FOO2 - FOO3 - FOO3 - - ; CHECK THAT THE RESULTS ARE CORRECT - - >(monitor-results) - (#S(MONITOR-DATA NAME FOO1 COUNT 2 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp") - #S(MONITOR-DATA NAME FOO2 COUNT 2 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp") - #S(MONITOR-DATA NAME FOO3 COUNT 1 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp")) - #S(MONITOR-DATA NAME FOO4 COUNT 0 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp")) - - ; STOP COUNTING CALLS TO FOO2 - - >(monitor-disable 'foo2) - NIL - - ; INVOKE FOO2 THRU FOO3 - - >(foo3) - - FOO1 - FOO2 - FOO3 - FOO3 - - ; NOTICE THAT FOO1 AND FOO3 WERE BUMPED BUT NOT FOO2 - >(monitor-results) - (#S(MONITOR-DATA NAME FOO1 COUNT 3 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp") - #S(MONITOR-DATA NAME FOO2 COUNT 2 MONITORP NIL SOURCEFILE - "/u/daly/testmon.lisp") - #S(MONITOR-DATA NAME FOO3 COUNT 2 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp")) - #S(MONITOR-DATA NAME FOO4 COUNT 0 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp")) - - ; TEMPORARILY STOP ALL MONITORING - - >(monitor-disable) - NIL - - ; CHECK THAT NOTHING CHANGES - - >(foo3) - - FOO1 - FOO2 - FOO3 - FOO3 - - ; NO COUNT HAS CHANGED - - >(monitor-results) - (#S(MONITOR-DATA NAME FOO1 COUNT 3 MONITORP NIL SOURCEFILE - "/u/daly/testmon.lisp") - #S(MONITOR-DATA NAME FOO2 COUNT 2 MONITORP NIL SOURCEFILE - "/u/daly/testmon.lisp") - #S(MONITOR-DATA NAME FOO3 COUNT 2 MONITORP NIL SOURCEFILE - "/u/daly/testmon.lisp")) - #S(MONITOR-DATA NAME FOO4 COUNT 0 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp")) - - ; MONITOR ONLY CALLS TO FOO1 - - >(monitor-enable 'foo1) - T - - ; FOO3 CALLS FOO1 - - >(foo3) - - FOO1 - FOO2 - FOO3 - FOO3 - - ; FOO1 HAS CHANGED BUT NOT FOO2 OR FOO3 - - >(monitor-results) - (#S(MONITOR-DATA NAME FOO1 COUNT 4 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp") - #S(MONITOR-DATA NAME FOO2 COUNT 2 MONITORP NIL SOURCEFILE - "/u/daly/testmon.lisp") - #S(MONITOR-DATA NAME FOO3 COUNT 2 MONITORP NIL SOURCEFILE - "/u/daly/testmon.lisp")) - #S(MONITOR-DATA NAME FOO4 COUNT 0 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp")) - - ; MONITOR EVERYBODY - - >(monitor-enable) - NIL - - ; CHECK THAT EVERYBODY CHANGES - - >(foo3) - - FOO1 - FOO2 - FOO3 - FOO3 - - ; EVERYBODY WAS BUMPED - - >(monitor-results) - (#S(MONITOR-DATA NAME FOO1 COUNT 5 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp") - #S(MONITOR-DATA NAME FOO2 COUNT 3 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp") - #S(MONITOR-DATA NAME FOO3 COUNT 3 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp")) - #S(MONITOR-DATA NAME FOO4 COUNT 0 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp")) - - ; WHAT FUNCTIONS WERE TESTED? - - >(monitor-tested) - (FOO1 FOO2 FOO3) - - ; WHAT FUNCTIONS WERE NOT TESTED? - - >(monitor-untested) - (FOO4) - - ; UNTRACE THE WHOLE WORLD, MONITORING CANNOT RESTART - - >(monitor-end) - NIL - - ; CHECK THE RESULTS - - >(monitor-results) - (#S(MONITOR-DATA NAME FOO1 COUNT 5 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp") - #S(MONITOR-DATA NAME FOO2 COUNT 3 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp") - #S(MONITOR-DATA NAME FOO3 COUNT 3 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp")) - #S(MONITOR-DATA NAME FOO4 COUNT 0 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp")) - - ; CHECK THAT THE FUNCTIONS STILL WORK - - >(foo3) - - FOO1 - FOO2 - FOO3 - FOO3 - - ; CHECK THAT MONITORING IS NOT OCCURING - - >(monitor-results) - (#S(MONITOR-DATA NAME FOO1 COUNT 5 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp") - #S(MONITOR-DATA NAME FOO2 COUNT 3 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp") - #S(MONITOR-DATA NAME FOO3 COUNT 3 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp")) - #S(MONITOR-DATA NAME FOO4 COUNT 0 MONITORP T SOURCEFILE - "/u/daly/testmon.lisp")) - -\end{verbatim} -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -(in-package "BOOT") - -(defun monitor-help () - (format t "~% -;;; MONITOR -;;; -;;; This file contains a set of function for monitoring the execution -;;; of the functions in a file. It constructs a hash table that contains -;;; the function name as the key and monitor-data structures as the value -;;; -;;; The technique is to use a :cond parameter on trace to call the -;;; monitor-incr function to incr the count every time a function is called -;;; -;;; *monitor-table* HASH TABLE -;;; is the monitor table containing the hash entries -;;; *monitor-nrlibs* LIST of STRING -;;; list of NRLIB filenames that are monitored -;;; *monitor-domains* LIST of STRING -;;; list of domains to monitor-report (default is all exposed domains) -;;; monitor-data STRUCTURE -;;; is the defstruct name of records in the table -;;; name is the first field and is the name of the monitored function -;;; count contains a count of times the function was called -;;; monitorp is a flag that skips counting if nil, counts otherwise -;;; sourcefile is the name of the file that contains the source code -;;; -;;; ***** SETUP, SHUTDOWN **** -;;; -;;; monitor-inittable () FUNCTION -;;; creates the hashtable and sets *monitor-table* -;;; note that it is called every time this file is loaded -;;; monitor-end () FUNCTION -;;; unhooks all of the trace hooks -;;; -;;; ***** TRACE, UNTRACE ***** -;;; -;;; monitor-add (name &optional sourcefile) FUNCTION -;;; sets up the trace and adds the function to the table -;;; monitor-delete (fn) FUNCTION -;;; untraces a function and removes it from the table -;;; monitor-enable (&optional fn) FUNCTION -;;; starts tracing for all (or optionally one) functions that -;;; are in the table -;;; monitor-disable (&optional fn) FUNCTION -;;; stops tracing for all (or optionally one) functions that -;;; are in the table -;;; -;;; ***** COUNTING, RECORDING ***** -;;; -;;; monitor-reset (&optional fn) FUNCTION -;;; reset the table count for the table (or optionally, for a function) -;;; monitor-incr (fn) FUNCTION -;;; increments the count information for a function -;;; it is called by trace to increment the count -;;; monitor-decr (fn) FUNCTION -;;; decrements the count information for a function -;;; monitor-info (fn) FUNCTION -;;; returns the monitor-data structure for a function -;;; -;;; ***** FILE IO ***** -;;; -;;; monitor-write (items file) FUNCTION -;;; writes a list of symbols or structures to a file -;;; monitor-file (file) FUNCTION -;;; will read a file, scan for defuns, monitor each defun -;;; NOTE: monitor-file assumes that the file has been loaded -;;; -;;; ***** RESULTS ***** -;;; -;;; monitor-results () FUNCTION -;;; returns a list of the monitor-data structures -;;; monitor-untested () FUNCTION -;;; returns a list of files that have zero counts -;;; monitor-tested (&optional delete) FUNCTION -;;; returns a list of files that have nonzero counts -;;; optionally calling monitor-delete on those functions -;;; -;;; ***** CHECKPOINT/RESTORE ***** -;;; -;;; monitor-checkpoint (file) FUNCTION -;;; save the *monitor-table* in a loadable form -;;; monitor-restore (file) FUNCTION -;;; restore a checkpointed file so that everything is monitored -;;; -;;; ***** ALGEBRA ***** -;;; -;;; monitor-autoload () FUNCTION -;;; traces autoload of algebra to monitor corresponding source files -;;; NOTE: this requires the /spad/int/algebra directory -;;; monitor-dirname (args) FUNCTION -;;; expects a list of 1 libstream (loadvol's arglist) and monitors the source -;;; this is a function called by monitor-autoload -;;; monitor-nrlib (nrlib) FUNCTION -;;; takes an nrlib name as a string (eg POLY) and returns a list of -;;; monitor-data structures from that source file -;;; monitor-report () FUNCTION -;;; generate a report of the monitored activity for domains in -;;; *monitor-domains* -;;; monitor-spadfile (name) FUNCTION -;;; given a spad file, report all NRLIBS it creates -;;; this adds each NRLIB name to *monitor-domains* but does not -;;; trace the functions from those domains -;;; monitor-percent () FUNCTION -;;; ratio of (functions executed)/(functions traced) -;;; monitor-apropos (str) FUNCTION -;;; given a string, find all monitored symbols containing the string -;;; the search is case-insensitive. returns a list of monitor-data items -") nil) - -(defvar *monitor-domains* nil "a list of domains to report") - -(defvar *monitor-nrlibs* nil "a list of nrlibs that have been traced") - -(defvar *monitor-table* nil "a table of all of the monitored data") - -(defstruct monitor-data name count monitorp sourcefile) - -(unless (fboundp 'libstream-dirname) - (defstruct libstream mode dirname (indextable nil) (indexstream nil))) - -(defun monitor-inittable () - "initialize the table" - (setq *monitor-table* (make-hash-table))) - -(eval-when (eval load) - (unless *monitor-table* (monitor-inittable))) - -(defun monitor-end () - "stop the whole monitoring process. we cannot restart" - (maphash - #'(lambda (key value) - (declare (ignore value)) - (eval `(untrace ,key))) - *monitor-table*)) - -(defun monitor-results () - "return a list of the monitor-data structures" - (let (result) - (maphash - #'(lambda (key value) - (declare (ignore key)) - (push value result)) - *monitor-table*) - result)) - -(defun monitor-add (name &optional sourcefile) - "add a function to the hash table" - (unless (fboundp name) (load sourcefile)) - (when (gethash name *monitor-table*) - (monitor-delete name)) - (eval `(trace (,name :cond (progn (monitor-incr ',name) nil)))) - (setf (gethash name *monitor-table*) - (make-monitor-data - :name name :count 0 :monitorp t :sourcefile sourcefile))))) - -(defun monitor-delete (fn) - "delete a function from the monitor table" - (eval `(untrace ,fn)) - (remhash fn *monitor-table*)) - -(defun monitor-enable (&optional fn) - "enable all (or optionally one) function for monitoring" - (if fn - (progn - (eval `(trace (,fn :cond (progn (monitor-incr ',fn) nil)))) - (setf (monitor-data-monitorp (gethash fn *monitor-table*)) t)) - (maphash - #'(lambda (key value) - (declare (ignore value)) - (eval `(trace (,fn :cond (progn (monitor-incr ',fn) nil)))) - (setf (monitor-data-monitorp (gethash key *monitor-table*)) t)) - *monitor-table*))) - -(defun monitor-disable (&optional fn) - "disable all (or optionally one) function for monitoring" - (if fn - (progn - (eval `(untrace ,fn)) - (setf (monitor-data-monitorp (gethash fn *monitor-table*)) nil)) - (maphash - #'(lambda (key value) - (declare (ignore value)) - (eval `(untrace ,fn)) - (setf (monitor-data-monitorp (gethash key *monitor-table*)) nil)) - *monitor-table*))) - -(defun monitor-reset (&optional fn) - "reset the table count for the table (or optionally, for a function)" - (if fn - (setf (monitor-data-count (gethash fn *monitor-table*)) 0) - (maphash - #'(lambda (key value) - (declare (ignore value)) - (setf (monitor-data-count (gethash key *monitor-table*)) 0)) - *monitor-table*))) - -(defun monitor-incr (fn) - "incr the count of fn by 1" - (let (data) - (setq data (gethash fn *monitor-table*)) - (if data - (incf (monitor-data-count data)) ;; change table entry by side-effect - (warn "~s is monitored but not in table..do (untrace ~s)~%" fn fn)))) - -(defun monitor-decr (fn) - "decr the count of fn by 1" - (let (data) - (setq data (gethash fn *monitor-table*)) - (if data - (decf (monitor-data-count data)) ;; change table entry by side-effect - (warn "~s is monitored but not in table..do (untrace ~s)~%" fn fn)))) - -(defun monitor-info (fn) - "return the information for a function" - (gethash fn *monitor-table*)) - -(defun monitor-file (file) - "hang a monitor call on all of the defuns in a file" - (let (expr (package "BOOT")) - (format t "monitoring ~s~%" file) - (with-open-file (in file) - (catch 'done - (loop - (setq expr (read in nil 'done)) - (when (eq expr 'done) (throw 'done nil)) - (if (and (consp expr) (eq (car expr) 'in-package)) - (if (and (consp (second expr)) (eq (first (second expr)) 'quote)) - (setq package (string (second (second expr)))) - (setq package (second expr))) - (when (and (consp expr) (eq (car expr) 'defun)) - (monitor-add (intern (string (second expr)) package) file)))))))) - -(defun monitor-untested () - "return a list of the functions with zero count fields" - (let (result) - (maphash - #'(lambda (key value) - (if (and (monitor-data-monitorp value) (= (monitor-data-count value) 0)) - (push key result))) - *monitor-table*) - result)) - -(defun monitor-tested (&optional delete) - "return a list of the functions with non-zero count fields, optionally deleting them" - (let (result) - (maphash - #'(lambda (key value) - (when (and (monitor-data-monitorp value) (> (monitor-data-count value) 0)) - (when delete (monitor-delete key)) - (push key result))) - *monitor-table*) - result)) - -(defun monitor-write (items file) - "write out a list of symbols or structures to a file" - (with-open-file (out file :direction :output) - (dolist (item items) - (if (symbolp item) - (format out "~s~%" item) - (format out "~s~50t~s~100t~s~%" - (monitor-data-sourcefile item) - (monitor-data-name item) - (monitor-data-count item)))))) - -(defun monitor-checkpoint (file) - "save the *monitor-table* in loadable form" - (let ((*print-package* t)) - (declare (special *print-package*)) - (with-open-file (out file :direction :output) - (format out "(in-package \"BOOT\")~%") - (format out "(monitor-inittable)~%") - (dolist (data (monitor-results)) - (format out "(monitor-add '~s ~s)~%" - (monitor-data-name data) - (monitor-data-sourcefile data)) - (format out "(setf (gethash '~s *monitor-table*) - (make-monitor-data :name '~s :count ~s :monitorp ~s - :sourcefile ~s))~%" - (monitor-data-name data) - (monitor-data-name data) - (monitor-data-count data) - (monitor-data-monitorp data) - (monitor-data-sourcefile data)))))) - -(defun monitor-restore (file) - "restore a checkpointed file so that everything is monitored" - (load file)) - -;; these functions are used for testing the algebra code - -(defun monitor-dirname (args) - "expects a list of 1 libstream (loadvol's arglist) and monitors the source" - (let (name) - (setq name (libstream-dirname (car args))) - (setq name (file-namestring name)) - (setq name (concatenate 'string "/spad/int/algebra/" name "/code.lsp")) - (when (probe-file name) - (push name *monitor-nrlibs*) - (monitor-file name)))) - -(defun monitor-autoload () - "traces autoload of algebra to monitor corresponding source files" - (trace (loadvol - :entrycond nil - :exitcond (progn (monitor-dirname system::arglist) nil)))) - -(defun monitor-nrlib (nrlib) - "takes an nrlib name as a string (eg POLY) and returns a list of - monitor-data structures from that source file" - (let (result) - (maphash - #'(lambda (k v) - (declare (ignore k)) - (when (string= nrlib - (pathname-name (car (last - (pathname-directory (monitor-data-sourcefile v)))))) - (push v result))) - *monitor-table*) - result)) - -(defun monitor-libname (item) - "given a monitor-data item, extract the NRLIB name" - (pathname-name (car (last - (pathname-directory (monitor-data-sourcefile item)))))) - -(defun monitor-exposedp (fn) - "exposed functions have more than 1 semicolon. given a symbol, count them" - (> (count #\; (symbol-name fn)) 1)) - -(defun monitor-readinterp () - "read INTERP.EXPOSED to initialize *monitor-domains* to exposed domains. - this is the default action. adding or deleting domains from the list - will change the report results" - (let (skip expr name) - (declare (special *monitor-domains*)) - (setq *monitor-domains* nil) - (with-open-file (in "/spad/src/algebra/INTERP.EXPOSED") - (read-line in) - (read-line in) - (read-line in) - (read-line in) - (catch 'done - (loop - (setq expr (read-line in nil "done")) - (when (string= expr "done") (throw 'done nil)) - (cond - ((string= expr "basic") (setq skip nil)) - ((string= expr "categories") (setq skip t)) - ((string= expr "hidden") (setq skip t)) - ((string= expr "defaults") (setq skip nil))) - (when (and (not skip) (> (length expr) 58)) - (setq name (subseq expr 58 (length expr))) - (setq name (string-right-trim '(#\space) name)) - (when (> (length name) 0) - (push name *monitor-domains*)))))))) - -(defun monitor-report () - "generate a report of the monitored activity for domains in *monitor-domains*" - (let (nrlibs nonzero total) - (unless *monitor-domains* (monitor-readinterp)) - (setq nonzero 0) - (setq total 0) - (maphash - #'(lambda (k v) - (declare (ignore k)) - (let (nextlib point) - (when (> (monitor-data-count v) 0) (incf nonzero)) - (incf total) - (setq nextlib (monitor-libname v)) - (setq point (member nextlib nrlibs :test #'string= :key #'car)) - (if point - (setf (cdr (first point)) (cons v (cdr (first point)))) - (push (cons nextlib (list v)) nrlibs)))) - *monitor-table*) - (format t "~d of ~d (~d percent) tested~%" nonzero total - (round (/ (* 100.0 nonzero) total))) - (setq nrlibs (sort nrlibs #'string< :key #'car)) - (dolist (pair nrlibs) - (let ((exposedcount 0) (testcount 0)) - (when (member (car pair) *monitor-domains* :test #'string=) - (format t "for library ~s~%" (car pair)) - (dolist (item (sort (cdr pair) #'> :key #'monitor-data-count)) - (when (monitor-exposedp (monitor-data-name item)) - (incf exposedcount) - (when (> (monitor-data-count item) 0) (incf testcount)) - (format t "~5d ~s~%" - (monitor-data-count item) - (monitor-data-name item)))) - (if (= exposedcount testcount) - (format t "~a has all exposed functions tested~%" (car pair)) - (format t "Daly bug:~a has untested exposed functions~%" (car pair)))))) - nil)) - -(defun monitor-parse (expr) - (let (point1 point2) - (setq point1 (position #\space expr :test #'char=)) - (setq point1 (position #\space expr :start point1 :test-not #'char=)) - (setq point1 (position #\space expr :start point1 :test #'char=)) - (setq point1 (position #\space expr :start point1 :test-not #'char=)) - (setq point2 (position #\space expr :start point1 :test #'char=)) - (subseq expr point1 point2))) - -(defun monitor-spadfile (name) - "given a spad file, report all NRLIBS it creates" - (let (expr) - (with-open-file (in name) - (catch 'done - (loop - (setq expr (read-line in nil 'done)) - (when (eq expr 'done) (throw 'done nil)) - (when (and (> (length expr) 4) (string= (subseq expr 0 4) ")abb")) - (setq *monitor-domains* - (adjoin (monitor-parse expr) *monitor-domains* :test #'string=)))))))) - -(defun monitor-percent () - (let (nonzero total) - (setq nonzero 0) - (setq total 0) - (maphash - #'(lambda (k v) - (declare (ignore k)) - (when (> (monitor-data-count v) 0) (incf nonzero)) - (incf total)) - *monitor-table*) - (format t "~d of ~d (~d percent) tested~%" nonzero total - (round (/ (* 100.0 nonzero) total))))) - -(defun monitor-apropos (str) - "given a string, find all monitored symbols containing the string - the search is case-insensitive. returns a list of monitor-data items" - (let (result) - (maphash - #'(lambda (k v) - (when - (search (string-upcase str) - (string-upcase (symbol-name k)) - :test #'string=) - (push v result))) - *monitor-table*) - result)) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/newaux.lisp b/src/interp/newaux.lisp new file mode 100644 index 00000000..8837c699 --- /dev/null +++ b/src/interp/newaux.lisp @@ -0,0 +1,212 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + +; PURPOSE: This file sets up properties which are used by the Boot lexical +; analyzer for bottom-up recognition of operators. Also certain +; other character-class definitions are included, as well as +; table accessing functions. +; +; ORGANIZATION: Each section is organized in terms of Creation and Access code. +; +; 1. Led and Nud Tables +; 2. GLIPH Table +; 3. RENAMETOK Table +; 4. GENERIC Table +; 5. Character syntax class predicates + +; **** 1. LED and NUD Tables + +; ** TABLE PURPOSE + +; Led and Nud have to do with operators. An operator with a Led property takes +; an operand on its left (infix/suffix operator). + +; An operator with a Nud takes no operand on its left (prefix/nilfix). +; Some have both (e.g. - ). This terminology is from the Pratt parser. +; The translator for Scratchpad II is a modification of the Pratt parser which +; branches to special handlers when it is most convenient and practical to +; do so (Pratt's scheme cannot handle local contexts very easily). + +; Both LEDs and NUDs have right and left binding powers. This is meaningful +; for prefix and infix operators. These powers are stored as the values of +; the LED and NUD properties of an atom, if the atom has such a property. +; The format is: + +; > + +; where the Special-Handler is the name of a function to be evaluated when that +; keyword is encountered. + +; The default values of Left and Right Binding-Power are NIL. NIL is a +; legitimate value signifying no precedence. If the Special-Handler is NIL, +; this is just an ordinary operator (as opposed to a surfix operator like +; if-then-else). + + + +(IMPORT-MODULE "macros") +(in-package "BOOT") + +; ** TABLE CREATION + +(defparameter OpAssoc nil + "Information used by OUT BOOT operator pretty printing routines") + +(defun MAKENEWOP (X Y) (MAKEOP X Y '|PARSE-NewKEY|)) + +(defun MAKEOP (X Y KEYNAME) + (if (OR (NOT (CDR X)) (NUMBERP (SECOND X))) + (SETQ X (CONS (FIRST X) X))) + (if (AND (alpha-char-p (ELT (STRINGIMAGE (FIRST X)) 0)) + (NOT (MEMBER (FIRST X) (EVAL KEYNAME)))) + (SET KEYNAME (CONS (FIRST X) (EVAL KEYNAME)))) + (MAKEPROP (FIRST X) Y X) + (SETQ OPASSOC (ADDASSOC Y (CONS (CONS X X) (LASSOC Y OPASSOC)) OPASSOC)) + (SECOND X)) + +(defvar |PARSE-NewKEY| nil) ;;list of keywords + +(mapcar #'(LAMBDA(J) (MAKENEWOP J '|Led|)) + '((* 800 801) (|rem| 800 801) (|mod| 800 801) + (|quo| 800 801) (|div| 800 801) + (/ 800 801) (** 900 901) (^ 900 901) + (|exquo| 800 801) (+ 700 701) + (\- 700 701) (\-\> 1001 1002) (\<\- 1001 1002) + (\: 996 997) (\:\: 996 997) + (\@ 996 997) (|pretend| 995 996) + (\.) (\! \! 1002 1001) + (\, 110 111) + (\; 81 82 (|PARSE-SemiColon|)) + (\< 400 400) (\> 400 400) + (\<\< 400 400) (\>\> 400 400) + (\<= 400 400) (\>= 400 400) + (= 400 400) (^= 400 400) + (\~= 400 400) + (|in| 400 400) (|case| 400 400) + (|add| 400 120) (|with| 2000 400 (|PARSE-InfixWith|)) + (|has| 400 400) + (|where| 121 104) ; must be 121 for SPAD, 126 for boot--> nboot + (|when| 112 190) + (|otherwise| 119 190 (|PARSE-Suffix|)) + (|is| 400 400) (|isnt| 400 400) + (|and| 250 251) (|or| 200 201) + (/\\ 250 251) (\\/ 200 201) + (\.\. SEGMENT 401 699 (|PARSE-Seg|)) + (=\> 123 103) + (+-\> 998 102) + (== DEF 122 121) + (==\> MDEF 122 121) + (\| 108 111) ;was 190 190 + (\:- LETD 125 124) (\:= LET 125 124))) + +(mapcar #'(LAMBDA (J) (MAKENEWOP J `|Nud|)) + '((|for| 130 350 (|PARSE-Loop|)) + (|while| 130 190 (|PARSE-Loop|)) + (|until| 130 190 (|PARSE-Loop|)) + (|repeat| 130 190 (|PARSE-Loop|)) + (|import| 120 0 (|PARSE-Import|) ) + (|unless|) + (|add| 900 120) + (|with| 1000 300 (|PARSE-With|)) + (|has| 400 400) + (\- 701 700) ; right-prec. wants to be -1 + left-prec +;; (\+ 701 700) + (\# 999 998) + (\! 1002 1001) + (\' 999 999 (|PARSE-Data|)) + (\<\< 122 120 (|PARSE-LabelExpr|)) + (\>\>) + (^ 260 259 NIL) + (\-\> 1001 1002) + (\: 194 195) + (|not| 260 259 NIL) + (\~ 260 259 nil) + (\= 400 700) + (|return| 202 201 (|PARSE-Return|)) + (|leave| 202 201 (|PARSE-Leave|)) + (|exit| 202 201 (|PARSE-Exit|)) + (|from|) + (|iterate|) + (|yield|) + (|if| 130 0 (|PARSE-Conditional|)) ; was 130 + (\| 0 190) + (|suchthat|) + (|then| 0 114) + (|else| 0 114))) + + +;; Gliphs are symbol clumps. The gliph property of a symbol gives +;; the tree describing the tokens which begin with that symbol. +;; The token reader uses the gliph property to determine the longest token. +;; Thus `:=' is read as one token not as `:' followed by `='. + +(mapcar #'(lambda (x) (makeprop (car x) 'gliph (cdr x))) + `( + ( \| (\)) ) + ( * (*) ) + ( \( (<) (\|) ) + ( + (- (>)) ) + ( - (>) ) + ( < (=) (<) ) + ;; ( / (\\) ) breaks */xxx + ( \\ (/) ) + ( > (=) (>) (\))) + ( = (= (>)) (>) ) + ( \. (\.) ) + ( ^ (=) ) + ( \~ (=) ) + ( \: (=) (-) (\:)))) + +;; RENAMETOK defines alternate token strings which can be used for different +;; keyboards which define equivalent tokens. + +(mapcar + #'(lambda (x) (MAKEPROP (CAR X) 'RENAMETOK (CADR X)) (MAKENEWOP X NIL)) + '((\(\| \[) ; (| |) means [] + (\|\) \]) + (\(< \{) ; (< >) means {} + (>\) \}))) + +;; GENERIC operators be suffixed by `$' qualifications in SPAD code. +;; `$' is then followed by a domain label, such as I for Integer, which +;; signifies which domain the operator refers to. For example `+$Integer' +;; is `+' for Integers. + +(mapcar #'(lambda (x) (MAKEPROP X 'GENERIC 'TRUE)) + '(- = * |rem| |mod| |quo| |div| / ** |exquo| + - < > <= >= ^= )) + +(defun SPECIALCASESYNTAX () (OR (AND (char= TOK '#\#) (DIGITP CHR)))) + +(defun TERMINATOR (CHR) + (member CHR '(#\ #\( #\) #\. #\; #\, #\Return)) :test #'char=) + diff --git a/src/interp/newaux.lisp.pamphlet b/src/interp/newaux.lisp.pamphlet deleted file mode 100644 index 687b2fbf..00000000 --- a/src/interp/newaux.lisp.pamphlet +++ /dev/null @@ -1,252 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp newaux.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{Operator Precedence Table Initialization} -\begin{verbatim} -; PURPOSE: This file sets up properties which are used by the Boot lexical -; analyzer for bottom-up recognition of operators. Also certain -; other character-class definitions are included, as well as -; table accessing functions. -; -; ORGANIZATION: Each section is organized in terms of Creation and Access code. -; -; 1. Led and Nud Tables -; 2. GLIPH Table -; 3. RENAMETOK Table -; 4. GENERIC Table -; 5. Character syntax class predicates -\end{verbatim} -\subsection{LED and NUD Tables} -\begin{verbatim} -; **** 1. LED and NUD Tables - -; ** TABLE PURPOSE - -; Led and Nud have to do with operators. An operator with a Led property takes -; an operand on its left (infix/suffix operator). - -; An operator with a Nud takes no operand on its left (prefix/nilfix). -; Some have both (e.g. - ). This terminology is from the Pratt parser. -; The translator for Scratchpad II is a modification of the Pratt parser which -; branches to special handlers when it is most convenient and practical to -; do so (Pratt's scheme cannot handle local contexts very easily). - -; Both LEDs and NUDs have right and left binding powers. This is meaningful -; for prefix and infix operators. These powers are stored as the values of -; the LED and NUD properties of an atom, if the atom has such a property. -; The format is: - -; > - -; where the Special-Handler is the name of a function to be evaluated when that -; keyword is encountered. - -; The default values of Left and Right Binding-Power are NIL. NIL is a -; legitimate value signifying no precedence. If the Special-Handler is NIL, -; this is just an ordinary operator (as opposed to a surfix operator like -; if-then-else). - -\end{verbatim} -<>= -; ** TABLE CREATION - -(defparameter OpAssoc nil - "Information used by OUT BOOT operator pretty printing routines") - -(defun MAKENEWOP (X Y) (MAKEOP X Y '|PARSE-NewKEY|)) - -(defun MAKEOP (X Y KEYNAME) - (if (OR (NOT (CDR X)) (NUMBERP (SECOND X))) - (SETQ X (CONS (FIRST X) X))) - (if (AND (alpha-char-p (ELT (STRINGIMAGE (FIRST X)) 0)) - (NOT (MEMBER (FIRST X) (EVAL KEYNAME)))) - (SET KEYNAME (CONS (FIRST X) (EVAL KEYNAME)))) - (MAKEPROP (FIRST X) Y X) - (SETQ OPASSOC (ADDASSOC Y (CONS (CONS X X) (LASSOC Y OPASSOC)) OPASSOC)) - (SECOND X)) - -(defvar |PARSE-NewKEY| nil) ;;list of keywords - -(mapcar #'(LAMBDA(J) (MAKENEWOP J '|Led|)) - '((* 800 801) (|rem| 800 801) (|mod| 800 801) - (|quo| 800 801) (|div| 800 801) - (/ 800 801) (** 900 901) (^ 900 901) - (|exquo| 800 801) (+ 700 701) - (\- 700 701) (\-\> 1001 1002) (\<\- 1001 1002) - (\: 996 997) (\:\: 996 997) - (\@ 996 997) (|pretend| 995 996) - (\.) (\! \! 1002 1001) - (\, 110 111) - (\; 81 82 (|PARSE-SemiColon|)) - (\< 400 400) (\> 400 400) - (\<\< 400 400) (\>\> 400 400) - (\<= 400 400) (\>= 400 400) - (= 400 400) (^= 400 400) - (\~= 400 400) - (|in| 400 400) (|case| 400 400) - (|add| 400 120) (|with| 2000 400 (|PARSE-InfixWith|)) - (|has| 400 400) - (|where| 121 104) ; must be 121 for SPAD, 126 for boot--> nboot - (|when| 112 190) - (|otherwise| 119 190 (|PARSE-Suffix|)) - (|is| 400 400) (|isnt| 400 400) - (|and| 250 251) (|or| 200 201) - (/\\ 250 251) (\\/ 200 201) - (\.\. SEGMENT 401 699 (|PARSE-Seg|)) - (=\> 123 103) - (+-\> 998 102) - (== DEF 122 121) - (==\> MDEF 122 121) - (\| 108 111) ;was 190 190 - (\:- LETD 125 124) (\:= LET 125 124))) - -(mapcar #'(LAMBDA (J) (MAKENEWOP J `|Nud|)) - '((|for| 130 350 (|PARSE-Loop|)) - (|while| 130 190 (|PARSE-Loop|)) - (|until| 130 190 (|PARSE-Loop|)) - (|repeat| 130 190 (|PARSE-Loop|)) - (|import| 120 0 (|PARSE-Import|) ) - (|unless|) - (|add| 900 120) - (|with| 1000 300 (|PARSE-With|)) - (|has| 400 400) - (\- 701 700) ; right-prec. wants to be -1 + left-prec -;; (\+ 701 700) - (\# 999 998) - (\! 1002 1001) - (\' 999 999 (|PARSE-Data|)) - (\<\< 122 120 (|PARSE-LabelExpr|)) - (\>\>) - (^ 260 259 NIL) - (\-\> 1001 1002) - (\: 194 195) - (|not| 260 259 NIL) - (\~ 260 259 nil) - (\= 400 700) - (|return| 202 201 (|PARSE-Return|)) - (|leave| 202 201 (|PARSE-Leave|)) - (|exit| 202 201 (|PARSE-Exit|)) - (|from|) - (|iterate|) - (|yield|) - (|if| 130 0 (|PARSE-Conditional|)) ; was 130 - (\| 0 190) - (|suchthat|) - (|then| 0 114) - (|else| 0 114))) - -@ -\section{Gliph Table} -Gliphs are symbol clumps. The gliph property of a symbol gives -the tree describing the tokens which begin with that symbol. -The token reader uses the gliph property to determine the longest token. -Thus [[:=]] is read as one token not as [[:]] followed by [[=]]. - -<>= -(mapcar #'(lambda (x) (makeprop (car x) 'gliph (cdr x))) - `( - ( \| (\)) ) - ( * (*) ) - ( \( (<) (\|) ) - ( + (- (>)) ) - ( - (>) ) - ( < (=) (<) ) - ;; ( / (\\) ) breaks */xxx - ( \\ (/) ) - ( > (=) (>) (\))) - ( = (= (>)) (>) ) - ( \. (\.) ) - ( ^ (=) ) - ( \~ (=) ) - ( \: (=) (-) (\:)))) - -@ -\subsection{Rename Token Table} -RENAMETOK defines alternate token strings which can be used for different -keyboards which define equivalent tokens. -<>= -(mapcar - #'(lambda (x) (MAKEPROP (CAR X) 'RENAMETOK (CADR X)) (MAKENEWOP X NIL)) - '((\(\| \[) ; (| |) means [] - (\|\) \]) - (\(< \{) ; (< >) means {} - (>\) \}))) - -@ -\subsection{Generic function table} -GENERIC operators be suffixed by [[$]] qualifications in SPAD code. -[[$]] is then followed by a domain label, such as I for Integer, which -signifies which domain the operator refers to. For example [[+$Integer]] -is [[+]] for Integers. -<>= -(mapcar #'(lambda (x) (MAKEPROP X 'GENERIC 'TRUE)) - '(- = * |rem| |mod| |quo| |div| / ** |exquo| + - < > <= >= ^= )) - -@ -\subsection{Character Syntax Table} -<>= -(defun SPECIALCASESYNTAX () (OR (AND (char= TOK '#\#) (DIGITP CHR)))) - -(defun TERMINATOR (CHR) - (member CHR '(#\ #\( #\) #\. #\; #\, #\Return)) :test #'char=) - -@ -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -(IMPORT-MODULE "macros") -(in-package "BOOT") - -<> -<> -<> -<> -<> -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/nlib.lisp b/src/interp/nlib.lisp new file mode 100644 index 00000000..e462977e --- /dev/null +++ b/src/interp/nlib.lisp @@ -0,0 +1,437 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + +(IMPORT-MODULE "macros") +(in-package "BOOT") + +#+:AKCL (defvar *lisp-bin-filetype* "o") + +#+:AKCL (defvar *lisp-source-filetype* "lsp") + +;; definition of our stream structure +(defstruct libstream mode dirname (indextable nil) (indexstream nil)) +;indextable is a list of entries (key class ) +;filename is of the form filenumber.lsp or filenumber.o + +(defvar optionlist nil "alist which controls compiler output") + +(defun addoptions (key value) "adds pairs to optionlist" + (push (cons key value) optionlist) + (if (equal key 'FILE) + (push + (cons 'COMPILER-OUTPUT-STREAM + (open (concat (libstream-dirname value) "/" "code.lsp") + :direction :output :if-exists :supersede)) + optionlist))) + +;; (RDEFIOSTREAM ((MODE . IO) (FILE fn ft dir))) IO is I,O,INPUT,OUTPUT +(defun rdefiostream (options &optional (missing-file-error-flag t)) + (let ((mode (cdr (assoc 'mode options))) + (file (assoc 'file options)) + (stream nil) + (fullname nil) + (indextable nil)) + (cond ((equal (elt (string mode) 0) #\I) + ;;(setq fullname (make-input-filename (cdr file) 'LISPLIB)) + (setq fullname (make-input-filename (cdr file) 'NIL)) + (setq stream (get-input-index-stream fullname)) + (if (null stream) + (if missing-file-error-flag + (ERROR (format nil "Library ~s doesn't exist" + ;;(make-filename (cdr file) 'LISPLIB)) + (make-filename (cdr file) 'NIL))) + NIL) + (make-libstream :mode 'input :dirname fullname + :indextable (get-index-table-from-stream stream) + :indexstream stream))) + ((equal (elt (string mode) 0) #\O) + ;;(setq fullname (make-full-namestring (cdr file) 'LISPLIB)) + (setq fullname (make-full-namestring (cdr file) 'NIL)) + (case (|directoryp| fullname) + (-1 (makedir fullname)) + (0 (error (format nil "~s is an existing file, not a library" fullname))) + (otherwise)) + (multiple-value-setq (stream indextable) (get-io-index-stream fullname)) + (make-libstream :mode 'output :dirname fullname + :indextable indextable + :indexstream stream )) + ('t (ERROR "Unknown MODE"))))) + + +;get the index table of the lisplib in dirname +(defun getindextable (dirname) + (let ((index-file (concat dirname "/" *index-filename*))) + (if (probe-file index-file) + (with-open-file (stream index-file) (get-index-table-from-stream stream)) + ;; create empty index file to mark directory as lisplib + (with-open-file (stream index-file :direction :output) nil)))) + +;get the index stream of the lisplib in dirname +(defun get-input-index-stream (dirname) + (let ((index-file (concat dirname "/" *index-filename*))) + (open index-file :direction :input :if-does-not-exist nil))) + +(defun get-index-table-from-stream (stream) + (let ((pos (read stream))) + (cond ((numberp pos) + (file-position stream pos) + (read stream)) + (t pos)))) + +(defun get-io-index-stream (dirname) + (let* ((index-file (concat dirname "/" *index-filename*)) + (stream (open index-file :direction :io :if-exists :overwrite + :if-does-not-exist :create)) + (indextable ()) + (pos (read stream nil nil))) + (cond ((numberp pos) + (file-position stream pos) + (setq indextable (read stream)) + (file-position stream pos)) + (t (file-position stream 0) + (princ " " stream) + (setq indextable pos))) + (values stream indextable))) + +;substitute indextable in dirname + +(defun write-indextable (indextable stream) + (let ((pos (file-position stream))) + (write indextable :stream stream :level nil :length nil :escape t) + (finish-output stream) + (file-position stream 0) + (princ pos stream) + (finish-output stream))) + +;;#+:ccl +;;(defun putindextable (indextable dirname) +;; (with-open-file +;; (stream (concat dirname "/" *index-filename*) +;; :direction :io :if-does-not-exist :create) +;; (file-position stream :end) +;; (write-indextable indextable stream))) +;;#-:ccl +(defun putindextable (indextable dirname) + (with-open-file + (stream (concat dirname "/" *index-filename*) + :direction :io :if-exists :overwrite + :if-does-not-exist :create) + (file-position stream :end) + (write-indextable indextable stream))) + +;; makedir (fname) fname is a directory name. +(defun makedir (fname) + #+ (and (not :GCL) :COMMON-LISP) (ensure-directories-exist fname) + #+ :GCL (system (concat "mkdir " fname)) + ) + +;; (RREAD key rstream) +(defun rread (key rstream &optional (error-val nil error-val-p)) + (if (equal (libstream-mode rstream) 'output) (error "not input stream")) + (let* ((entry + (and (stringp key) + (assoc key (libstream-indextable rstream) :test #'string=))) + (file-or-pos (and entry (caddr entry)))) + (cond ((null entry) + (if error-val-p error-val (error (format nil "key ~a not found" key)))) + ((null (caddr entry)) (cdddr entry)) ;; for small items + ((numberp file-or-pos) + (file-position (libstream-indexstream rstream) file-or-pos) + (read (libstream-indexstream rstream))) + (t + (with-open-file + (stream (concat (libstream-dirname rstream) "/" file-or-pos)) + (read stream))) ))) + +(defvar *lib-var*) + +;; (RKEYIDS filearg) -- interned version of keys +(defun rkeyids (&rest filearg) + (mapcar #'intern (mapcar #'car (getindextable + (make-input-filename filearg 'NIL))))) +;;(defun rkeyids (&rest filearg) +;; (mapcar #'intern (mapcar #'car (getindextable +;; (make-input-filename filearg 'LISPLIB))))) + +;; (RWRITE cvec item rstream) +(defun rwrite (key item rstream) + (if (equal (libstream-mode rstream) 'input) (error "not output stream")) + (let ((stream (libstream-indexstream rstream)) + (pos (if item (cons (file-position (libstream-indexstream rstream)) nil) + (cons nil item)))) ;; for small items + (make-entry (string key) rstream pos) + (when (numberp (car pos)) + (write item :stream stream :level nil :length nil + :circle t :array t :escape t) + (terpri stream)))) + +(defun make-entry (key rstream value-or-pos) + (let ((entry (assoc key (libstream-indextable rstream) :test #'equal))) + (if (null entry) + (push (setq entry (cons key (cons 0 value-or-pos))) + (libstream-indextable rstream)) + (progn + (if (stringp (caddr entry)) ($erase (caddr entry))) + (setf (cddr entry) value-or-pos))) + entry)) + +;;(defun rshut (rstream) +;; (when (and (equal rstream (cdr (assoc 'FILE OPTIONLIST))) +;; (assoc 'compiler-output-stream optionlist)) +;; (close (cdr (assoc 'compiler-output-stream optionlist))) +;; (setq optionlist nil)) +;; (if (eq (libstream-mode rstream) 'output) +;; (write-indextable (libstream-indextable rstream) (libstream-indexstream rstream))) +;; (close (libstream-indexstream rstream))) +(defun rshut (rstream) + (when (and (equal rstream (cdr (assoc 'FILE OPTIONLIST))) + (assoc 'compiler-output-stream optionlist)) + (close (cdr (assoc 'compiler-output-stream optionlist))) + (setq optionlist (cddr optionlist))) + (if (eq (libstream-mode rstream) 'output) + (write-indextable (libstream-indextable rstream) (libstream-indexstream rstream))) + (close (libstream-indexstream rstream))) + +;; filespec is id or list of 1, 2 or 3 ids +;; filearg is filespec or 1, 2 or 3 ids +;; (RPACKFILE filearg) -- compiles code files and converts to compressed format +(defun rpackfile (filespec) + (setq filespec (make-filename filespec)) + (if (string= (pathname-type filespec) "NRLIB") +#-:GCL (recompile-lib-file-if-necessary + (concat (namestring filespec) "/code.lsp")) + +;; When we compile an algebra file we create an NRLIB directory which contains +;; several files. One of the files is named [[code.lsp]]. +;; On certain platforms this causes linking problems for GCL. +;; The problem is that the compiler produces an init code block which is +;; sensitive to the name of the source file. +;; Since all of the [[code.lsp]] files have the same name all of +;; the init blocks have the same name. At link time this causes +;; the names to collide. Here we rename the file before we compile, +;; do the compile, and then rename the result back to [[code.o]]. +;; This code used to read: +;; but has been changed to read: +#+:GCL (let* ((base (pathname-name filespec)) + (code (concatenate 'string (namestring filespec) "/code.lsp")) + (temp (concatenate 'string (namestring filespec) "/" base ".lsp")) + (o (make-pathname :type "o"))) + (si::system (format nil "cp ~S ~S" code temp)) + (recompile-lib-file-if-necessary temp) + (si::system (format nil "mv ~S ~S~%" + (namestring (merge-pathnames o temp)) + (namestring (merge-pathnames o code))))) + ;; only pack non libraries to avoid lucid file handling problems + (let* ((rstream (rdefiostream (list (cons 'file filespec) (cons 'mode 'input)))) + (nstream nil) + (nindextable nil) + (nrstream nil) + (index-file-name (concat (truename filespec) "/" *index-filename*)) + (temp-index-file-name (make-pathname :name "oldindex" + :defaults index-file-name))) + (rename-file index-file-name temp-index-file-name ) ;; stays until closed + (multiple-value-setq (nstream nindextable) (get-io-index-stream filespec)) + (setq nrstream (make-libstream :mode 'output :dirname filespec + :indextable nindextable + :indexstream nstream )) + (dolist (entry (libstream-indextable rstream)) + (rwrite (car entry) (rread (car entry) rstream) nrstream) + (if (stringp (caddr entry)) + (delete-file (concat filespec "/" (caddr entry))))) + (close (libstream-indexstream rstream)) + (delete-file temp-index-file-name) + (rshut nrstream))) + filespec) + +#+:AKCL +(defun recompile-lib-file-if-necessary (lfile) + (let* ((bfile (make-pathname :type *lisp-bin-filetype* :defaults lfile)) + (bdate (and (probe-file bfile) (file-write-date bfile))) + (ldate (and (probe-file lfile) (file-write-date lfile)))) + (if ldate + (if (and bdate (> bdate ldate)) nil + (progn (compile-lib-file lfile) (list bfile)))))) + +#+:CCL +(defun recompile-lib-file-if-necessary (lfile) + (let ( (mname (pathname-name (file-namestring (directory-namestring lfile)))) + (mdate (modulep mname)) + (ldate (filedate lfile)) ) + (if (or (not mdate) (datelessp mdate ldate)) + (seq + (if (null output-library) + (|openOutputLibrary| + (setq |$outputLibraryName| + (if (null |$outputLibraryName|) + (make-pathname :directory (get-current-directory) + :name "user.lib") + (if (filep |$outputLibraryName|) + (truename |$outputLibraryName|) + |$outputLibraryName|))))) + (compile-file lfile + :output-file (intern (pathname-name + (directory-namestring lfile)))))))) + + +#+:AKCL +(defun spad-fixed-arg (fname ) + (and (equal (symbol-package fname) (find-package "BOOT")) + (not (get fname 'compiler::spad-var-arg)) + (search ";" (symbol-name fname)) + (or (get fname 'compiler::fixed-args) + (setf (get fname 'compiler::fixed-args) t))) + nil) + +#+:AKCL +(defun compile-lib-file (fn &rest opts) + (unwind-protect + (progn + (trace (compiler::fast-link-proclaimed-type-p + :exitcond nil + :entrycond (spad-fixed-arg (car system::arglist)))) + (trace (compiler::t1defun :exitcond nil + :entrycond (spad-fixed-arg (caar system::arglist)))) + (apply #'compile-file fn opts)) + (untrace compiler::fast-link-proclaimed-type-p compiler::t1defun))) +#+:CCL +(define-function 'compile-lib-file #'compile-file) + +;; (RDROPITEMS filearg keys) don't delete, used in files.spad +(defun rdropitems (filearg keys &aux (ctable (getindextable filearg))) + (mapc #'(lambda(x) + (setq ctable (delete x ctable :key #'car :test #'equal)) ) + (mapcar #'string keys)) + (putindextable ctable filearg)) + +;; cms file operations +(defun make-filename (filearg &optional (filetype nil)) + (let ((filetype (if (symbolp filetype) + (symbol-name filetype) + filetype))) + (cond + ((pathnamep filearg) + (cond ((pathname-type filearg) (namestring filearg)) + (t (namestring (make-pathname :directory (pathname-directory filearg) + :name (pathname-name filearg) + :type filetype))))) + ;; Previously, given a filename containing "." and + ;; an extension this function would return filearg. MCD 23-8-95. + ((and (stringp filearg) (pathname-type filearg) (null filetype)) filearg) + ;; ((and (stringp filearg) + ;; (or (pathname-type filearg) (null filetype))) + ;; filearg) + ((and (stringp filearg) (stringp filetype) + (pathname-type filearg) + (string-equal (pathname-type filearg) filetype)) + filearg) + ((consp filearg) + (make-filename (car filearg) (or (cadr filearg) filetype))) + (t (if (stringp filetype) (setq filetype (intern filetype "BOOT"))) + (let ((ft (or (cdr (assoc filetype $filetype-table)) filetype))) + (if ft + (concatenate 'string (string filearg) "." (string ft)) + (string filearg))))))) + +(defun make-full-namestring (filearg &optional (filetype nil)) + (namestring (merge-pathnames (make-filename filearg filetype)))) + +(defun probe-name (file) + (if (probe-file file) (namestring file) nil)) + +(defun get-directory-list (ft &aux (cd (namestring (get-current-directory)))) + (cond ((member ft '("NRLIB" "DAASE" "EXPOSED") :test #'string=) + (if (eq |$UserLevel| '|development|) + (cons cd $library-directory-list) + $library-directory-list)) + (t (adjoin cd + (adjoin (namestring (user-homedir-pathname)) $directory-list + :test #'string=) + :test #'string=)))) + +(defun make-input-filename (filearg &optional (filetype nil)) + (let* + ((filename (make-filename filearg filetype)) + (dirname (pathname-directory filename)) + (ft (pathname-type filename)) + (dirs (get-directory-list ft)) + (newfn nil)) + (if (or (null dirname) (eqcar dirname :relative)) + (dolist (dir dirs (probe-name filename)) + (when + (probe-file + (setq newfn (concatenate 'string dir filename))) + (return newfn))) + (probe-name filename)))) + +(defun $FILEP (&rest filearg) (make-full-namestring filearg)) +(define-function '$OUTFILEP #'$FILEP) ;;temporary bogus def + +(defun $findfile (filespec filetypelist) + (let ((file-name (if (consp filespec) (car filespec) filespec)) + (file-type (if (consp filespec) (cadr filespec) nil))) + (if file-type (push file-type filetypelist)) + (some #'(lambda (ft) (make-input-filename file-name ft)) + filetypelist))) + +;; ($ERASE filearg) -> 0 if succeeds else 1 +(defun $erase (&rest filearg) + (system (concat "rm -rf "(make-full-namestring filearg)))) + +(defun $REPLACE (filespec1 filespec2) + ($erase (setq filespec1 (make-full-namestring filespec1))) + (rename-file (make-full-namestring filespec2) filespec1)) + + + +;;(defun move-file (namestring1 namestring2) +;; (rename-file namestring1 namestring2)) + +(defun $FCOPY (filespec1 filespec2) + (let ((name1 (make-full-namestring filespec1)) + (name2 (make-full-namestring filespec2))) + (if (library-file name1) + (copy-lib-directory name1 name2) + (copy-file name1 name2)))) + + +#+(OR :AKCL (AND :CCL :UNIX)) +(defun copy-lib-directory (name1 name2) + (makedir name2) + (system (concat "sh -c 'cp " name1 "/* " name2 "'"))) + +#+(OR :AKCL (AND :CCL :UNIX)) +(defun copy-file (namestring1 namestring2) + (system (concat "cp " namestring1 " " namestring2))) + + diff --git a/src/interp/nlib.lisp.pamphlet b/src/interp/nlib.lisp.pamphlet deleted file mode 100644 index e16a57b7..00000000 --- a/src/interp/nlib.lisp.pamphlet +++ /dev/null @@ -1,468 +0,0 @@ -%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/nlib.lisp} Pamphlet} -\author{Timothy Daly} - -\begin{document} -\maketitle - -\begin{abstract} -\end{abstract} - -\tableofcontents -\eject - -\section{GCL code.lsp name change} - -When we compile an algebra file we create an NRLIB directory which contains -several files. One of the files is named [[code.lsp]]. -On certain platforms this causes linking problems for GCL. -The problem is that the compiler produces an init code block which is -sensitive to the name of the source file. -Since all of the [[code.lsp]] files have the same name all of -the init blocks have the same name. At link time this causes -the names to collide. Here we rename the file before we compile, -do the compile, and then rename the result back to [[code.o]]. -This code used to read: -but has been changed to read: -<>= -#-:GCL (recompile-lib-file-if-necessary - (concat (namestring filespec) "/code.lsp")) -#+:GCL (let* ((base (pathname-name filespec)) - (code (concatenate 'string (namestring filespec) "/code.lsp")) - (temp (concatenate 'string (namestring filespec) "/" base ".lsp")) - (o (make-pathname :type "o"))) - (si::system (format nil "cp ~S ~S" code temp)) - (recompile-lib-file-if-necessary temp) - (si::system (format nil "mv ~S ~S~%" - (namestring (merge-pathnames o temp)) - (namestring (merge-pathnames o code))))) -@ - -\section{License} - -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -(IMPORT-MODULE "macros") -(in-package "BOOT") - -#+:AKCL (defvar *lisp-bin-filetype* "o") - -#+:AKCL (defvar *lisp-source-filetype* "lsp") - -;; definition of our stream structure -(defstruct libstream mode dirname (indextable nil) (indexstream nil)) -;indextable is a list of entries (key class ) -;filename is of the form filenumber.lsp or filenumber.o - -(defvar optionlist nil "alist which controls compiler output") - -(defun addoptions (key value) "adds pairs to optionlist" - (push (cons key value) optionlist) - (if (equal key 'FILE) - (push - (cons 'COMPILER-OUTPUT-STREAM - (open (concat (libstream-dirname value) "/" "code.lsp") - :direction :output :if-exists :supersede)) - optionlist))) - -;; (RDEFIOSTREAM ((MODE . IO) (FILE fn ft dir))) IO is I,O,INPUT,OUTPUT -(defun rdefiostream (options &optional (missing-file-error-flag t)) - (let ((mode (cdr (assoc 'mode options))) - (file (assoc 'file options)) - (stream nil) - (fullname nil) - (indextable nil)) - (cond ((equal (elt (string mode) 0) #\I) - ;;(setq fullname (make-input-filename (cdr file) 'LISPLIB)) - (setq fullname (make-input-filename (cdr file) 'NIL)) - (setq stream (get-input-index-stream fullname)) - (if (null stream) - (if missing-file-error-flag - (ERROR (format nil "Library ~s doesn't exist" - ;;(make-filename (cdr file) 'LISPLIB)) - (make-filename (cdr file) 'NIL))) - NIL) - (make-libstream :mode 'input :dirname fullname - :indextable (get-index-table-from-stream stream) - :indexstream stream))) - ((equal (elt (string mode) 0) #\O) - ;;(setq fullname (make-full-namestring (cdr file) 'LISPLIB)) - (setq fullname (make-full-namestring (cdr file) 'NIL)) - (case (|directoryp| fullname) - (-1 (makedir fullname)) - (0 (error (format nil "~s is an existing file, not a library" fullname))) - (otherwise)) - (multiple-value-setq (stream indextable) (get-io-index-stream fullname)) - (make-libstream :mode 'output :dirname fullname - :indextable indextable - :indexstream stream )) - ('t (ERROR "Unknown MODE"))))) - - -;get the index table of the lisplib in dirname -(defun getindextable (dirname) - (let ((index-file (concat dirname "/" *index-filename*))) - (if (probe-file index-file) - (with-open-file (stream index-file) (get-index-table-from-stream stream)) - ;; create empty index file to mark directory as lisplib - (with-open-file (stream index-file :direction :output) nil)))) - -;get the index stream of the lisplib in dirname -(defun get-input-index-stream (dirname) - (let ((index-file (concat dirname "/" *index-filename*))) - (open index-file :direction :input :if-does-not-exist nil))) - -(defun get-index-table-from-stream (stream) - (let ((pos (read stream))) - (cond ((numberp pos) - (file-position stream pos) - (read stream)) - (t pos)))) - -(defun get-io-index-stream (dirname) - (let* ((index-file (concat dirname "/" *index-filename*)) - (stream (open index-file :direction :io :if-exists :overwrite - :if-does-not-exist :create)) - (indextable ()) - (pos (read stream nil nil))) - (cond ((numberp pos) - (file-position stream pos) - (setq indextable (read stream)) - (file-position stream pos)) - (t (file-position stream 0) - (princ " " stream) - (setq indextable pos))) - (values stream indextable))) - -;substitute indextable in dirname - -(defun write-indextable (indextable stream) - (let ((pos (file-position stream))) - (write indextable :stream stream :level nil :length nil :escape t) - (finish-output stream) - (file-position stream 0) - (princ pos stream) - (finish-output stream))) - -;;#+:ccl -;;(defun putindextable (indextable dirname) -;; (with-open-file -;; (stream (concat dirname "/" *index-filename*) -;; :direction :io :if-does-not-exist :create) -;; (file-position stream :end) -;; (write-indextable indextable stream))) -;;#-:ccl -(defun putindextable (indextable dirname) - (with-open-file - (stream (concat dirname "/" *index-filename*) - :direction :io :if-exists :overwrite - :if-does-not-exist :create) - (file-position stream :end) - (write-indextable indextable stream))) - -;; makedir (fname) fname is a directory name. -(defun makedir (fname) - #+ (and (not :GCL) :COMMON-LISP) (ensure-directories-exist fname) - #+ :GCL (system (concat "mkdir " fname)) - ) - -;; (RREAD key rstream) -(defun rread (key rstream &optional (error-val nil error-val-p)) - (if (equal (libstream-mode rstream) 'output) (error "not input stream")) - (let* ((entry - (and (stringp key) - (assoc key (libstream-indextable rstream) :test #'string=))) - (file-or-pos (and entry (caddr entry)))) - (cond ((null entry) - (if error-val-p error-val (error (format nil "key ~a not found" key)))) - ((null (caddr entry)) (cdddr entry)) ;; for small items - ((numberp file-or-pos) - (file-position (libstream-indexstream rstream) file-or-pos) - (read (libstream-indexstream rstream))) - (t - (with-open-file - (stream (concat (libstream-dirname rstream) "/" file-or-pos)) - (read stream))) ))) - -(defvar *lib-var*) - -;; (RKEYIDS filearg) -- interned version of keys -(defun rkeyids (&rest filearg) - (mapcar #'intern (mapcar #'car (getindextable - (make-input-filename filearg 'NIL))))) -;;(defun rkeyids (&rest filearg) -;; (mapcar #'intern (mapcar #'car (getindextable -;; (make-input-filename filearg 'LISPLIB))))) - -;; (RWRITE cvec item rstream) -(defun rwrite (key item rstream) - (if (equal (libstream-mode rstream) 'input) (error "not output stream")) - (let ((stream (libstream-indexstream rstream)) - (pos (if item (cons (file-position (libstream-indexstream rstream)) nil) - (cons nil item)))) ;; for small items - (make-entry (string key) rstream pos) - (when (numberp (car pos)) - (write item :stream stream :level nil :length nil - :circle t :array t :escape t) - (terpri stream)))) - -(defun make-entry (key rstream value-or-pos) - (let ((entry (assoc key (libstream-indextable rstream) :test #'equal))) - (if (null entry) - (push (setq entry (cons key (cons 0 value-or-pos))) - (libstream-indextable rstream)) - (progn - (if (stringp (caddr entry)) ($erase (caddr entry))) - (setf (cddr entry) value-or-pos))) - entry)) - -;;(defun rshut (rstream) -;; (when (and (equal rstream (cdr (assoc 'FILE OPTIONLIST))) -;; (assoc 'compiler-output-stream optionlist)) -;; (close (cdr (assoc 'compiler-output-stream optionlist))) -;; (setq optionlist nil)) -;; (if (eq (libstream-mode rstream) 'output) -;; (write-indextable (libstream-indextable rstream) (libstream-indexstream rstream))) -;; (close (libstream-indexstream rstream))) -(defun rshut (rstream) - (when (and (equal rstream (cdr (assoc 'FILE OPTIONLIST))) - (assoc 'compiler-output-stream optionlist)) - (close (cdr (assoc 'compiler-output-stream optionlist))) - (setq optionlist (cddr optionlist))) - (if (eq (libstream-mode rstream) 'output) - (write-indextable (libstream-indextable rstream) (libstream-indexstream rstream))) - (close (libstream-indexstream rstream))) - -;; filespec is id or list of 1, 2 or 3 ids -;; filearg is filespec or 1, 2 or 3 ids -;; (RPACKFILE filearg) -- compiles code files and converts to compressed format -(defun rpackfile (filespec) - (setq filespec (make-filename filespec)) - (if (string= (pathname-type filespec) "NRLIB") -<> - ;; only pack non libraries to avoid lucid file handling problems - (let* ((rstream (rdefiostream (list (cons 'file filespec) (cons 'mode 'input)))) - (nstream nil) - (nindextable nil) - (nrstream nil) - (index-file-name (concat (truename filespec) "/" *index-filename*)) - (temp-index-file-name (make-pathname :name "oldindex" - :defaults index-file-name))) - (rename-file index-file-name temp-index-file-name ) ;; stays until closed - (multiple-value-setq (nstream nindextable) (get-io-index-stream filespec)) - (setq nrstream (make-libstream :mode 'output :dirname filespec - :indextable nindextable - :indexstream nstream )) - (dolist (entry (libstream-indextable rstream)) - (rwrite (car entry) (rread (car entry) rstream) nrstream) - (if (stringp (caddr entry)) - (delete-file (concat filespec "/" (caddr entry))))) - (close (libstream-indexstream rstream)) - (delete-file temp-index-file-name) - (rshut nrstream))) - filespec) - -#+:AKCL -(defun recompile-lib-file-if-necessary (lfile) - (let* ((bfile (make-pathname :type *lisp-bin-filetype* :defaults lfile)) - (bdate (and (probe-file bfile) (file-write-date bfile))) - (ldate (and (probe-file lfile) (file-write-date lfile)))) - (if ldate - (if (and bdate (> bdate ldate)) nil - (progn (compile-lib-file lfile) (list bfile)))))) - -#+:CCL -(defun recompile-lib-file-if-necessary (lfile) - (let ( (mname (pathname-name (file-namestring (directory-namestring lfile)))) - (mdate (modulep mname)) - (ldate (filedate lfile)) ) - (if (or (not mdate) (datelessp mdate ldate)) - (seq - (if (null output-library) - (|openOutputLibrary| - (setq |$outputLibraryName| - (if (null |$outputLibraryName|) - (make-pathname :directory (get-current-directory) - :name "user.lib") - (if (filep |$outputLibraryName|) - (truename |$outputLibraryName|) - |$outputLibraryName|))))) - (compile-file lfile - :output-file (intern (pathname-name - (directory-namestring lfile)))))))) - - -#+:AKCL -(defun spad-fixed-arg (fname ) - (and (equal (symbol-package fname) (find-package "BOOT")) - (not (get fname 'compiler::spad-var-arg)) - (search ";" (symbol-name fname)) - (or (get fname 'compiler::fixed-args) - (setf (get fname 'compiler::fixed-args) t))) - nil) - -#+:AKCL -(defun compile-lib-file (fn &rest opts) - (unwind-protect - (progn - (trace (compiler::fast-link-proclaimed-type-p - :exitcond nil - :entrycond (spad-fixed-arg (car system::arglist)))) - (trace (compiler::t1defun :exitcond nil - :entrycond (spad-fixed-arg (caar system::arglist)))) - (apply #'compile-file fn opts)) - (untrace compiler::fast-link-proclaimed-type-p compiler::t1defun))) -#+:CCL -(define-function 'compile-lib-file #'compile-file) - -;; (RDROPITEMS filearg keys) don't delete, used in files.spad -(defun rdropitems (filearg keys &aux (ctable (getindextable filearg))) - (mapc #'(lambda(x) - (setq ctable (delete x ctable :key #'car :test #'equal)) ) - (mapcar #'string keys)) - (putindextable ctable filearg)) - -;; cms file operations -(defun make-filename (filearg &optional (filetype nil)) - (let ((filetype (if (symbolp filetype) - (symbol-name filetype) - filetype))) - (cond - ((pathnamep filearg) - (cond ((pathname-type filearg) (namestring filearg)) - (t (namestring (make-pathname :directory (pathname-directory filearg) - :name (pathname-name filearg) - :type filetype))))) - ;; Previously, given a filename containing "." and - ;; an extension this function would return filearg. MCD 23-8-95. - ((and (stringp filearg) (pathname-type filearg) (null filetype)) filearg) - ;; ((and (stringp filearg) - ;; (or (pathname-type filearg) (null filetype))) - ;; filearg) - ((and (stringp filearg) (stringp filetype) - (pathname-type filearg) - (string-equal (pathname-type filearg) filetype)) - filearg) - ((consp filearg) - (make-filename (car filearg) (or (cadr filearg) filetype))) - (t (if (stringp filetype) (setq filetype (intern filetype "BOOT"))) - (let ((ft (or (cdr (assoc filetype $filetype-table)) filetype))) - (if ft - (concatenate 'string (string filearg) "." (string ft)) - (string filearg))))))) - -(defun make-full-namestring (filearg &optional (filetype nil)) - (namestring (merge-pathnames (make-filename filearg filetype)))) - -(defun probe-name (file) - (if (probe-file file) (namestring file) nil)) - -(defun get-directory-list (ft &aux (cd (namestring (get-current-directory)))) - (cond ((member ft '("NRLIB" "DAASE" "EXPOSED") :test #'string=) - (if (eq |$UserLevel| '|development|) - (cons cd $library-directory-list) - $library-directory-list)) - (t (adjoin cd - (adjoin (namestring (user-homedir-pathname)) $directory-list - :test #'string=) - :test #'string=)))) - -(defun make-input-filename (filearg &optional (filetype nil)) - (let* - ((filename (make-filename filearg filetype)) - (dirname (pathname-directory filename)) - (ft (pathname-type filename)) - (dirs (get-directory-list ft)) - (newfn nil)) - (if (or (null dirname) (eqcar dirname :relative)) - (dolist (dir dirs (probe-name filename)) - (when - (probe-file - (setq newfn (concatenate 'string dir filename))) - (return newfn))) - (probe-name filename)))) - -(defun $FILEP (&rest filearg) (make-full-namestring filearg)) -(define-function '$OUTFILEP #'$FILEP) ;;temporary bogus def - -(defun $findfile (filespec filetypelist) - (let ((file-name (if (consp filespec) (car filespec) filespec)) - (file-type (if (consp filespec) (cadr filespec) nil))) - (if file-type (push file-type filetypelist)) - (some #'(lambda (ft) (make-input-filename file-name ft)) - filetypelist))) - -;; ($ERASE filearg) -> 0 if succeeds else 1 -(defun $erase (&rest filearg) - (system (concat "rm -rf "(make-full-namestring filearg)))) - -(defun $REPLACE (filespec1 filespec2) - ($erase (setq filespec1 (make-full-namestring filespec1))) - (rename-file (make-full-namestring filespec2) filespec1)) - - - -;;(defun move-file (namestring1 namestring2) -;; (rename-file namestring1 namestring2)) - -(defun $FCOPY (filespec1 filespec2) - (let ((name1 (make-full-namestring filespec1)) - (name2 (make-full-namestring filespec2))) - (if (library-file name1) - (copy-lib-directory name1 name2) - (copy-file name1 name2)))) - - -#+(OR :AKCL (AND :CCL :UNIX)) -(defun copy-lib-directory (name1 name2) - (makedir name2) - (system (concat "sh -c 'cp " name1 "/* " name2 "'"))) - -#+(OR :AKCL (AND :CCL :UNIX)) -(defun copy-file (namestring1 namestring2) - (system (concat "cp " namestring1 " " namestring2))) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/nocompil.lisp b/src/interp/nocompil.lisp new file mode 100644 index 00000000..3adc630a --- /dev/null +++ b/src/interp/nocompil.lisp @@ -0,0 +1,77 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + +;; The function {\bf protected-symbol-warn} was added because it is +;; used in {\bf setvart.boot} but apparently is nowhere defined. It +;; is probably primitive to {\bf CCL}. + +;; The function {\bf protect-symbols} was added because it is +;; used in {\bf setvart.boot} but apparently is nowhere defined. It +;; is probably primitive to {\bf CCL}. + +;; The output of these functions is just a noisy warning message +;; and this has been commented out. +;; \section{GCL cmpnote function} +;; GCL keeps noting the fact that the compiler is performing tail-recursion. +;; Bill Schelter added this as a debugging tool for Axiom and it was never +;; removed. Patching the lisp code in the GCL build fails as the system +;; is actually built from the pre-compiled C code. Thus, we can only step +;; on this message after the fact. The cmpnote function is used nowhere +;; else in GCL so stepping on the function call seems best. We're unhappy +;; with this hack and will try to convince the GCL crowd to fix this. + + +#+:gcl (defun compiler::cmpnote (&rest x)) + +(import-module "boot-pkg") +(in-package "BOOT") + +(defun protected-symbol-warn (&rest arg)) +; (format t "protected-symbol-warn called with ~A~%" arg)) + +(defun protect-symbols (&rest arg)) +; (format t "protected-symbol-warn called with ~A~%" arg)) + +(defun use-fast-links (arg) +; (format t "use-fast-links called with ~A~%" arg) +#+:GCL (si::use-fast-links arg) + ) + +(defun verbos (arg)) +; (format t "verbos called with ~A~%" arg)) + +(defun enable-backtrace (&rest arg) +#+:ccl + (format t "protected-symbol-warn called with ~A~%" arg)) + diff --git a/src/interp/nocompil.lisp.pamphlet b/src/interp/nocompil.lisp.pamphlet deleted file mode 100644 index 6e7b6bf1..00000000 --- a/src/interp/nocompil.lisp.pamphlet +++ /dev/null @@ -1,98 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp nocompil.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -The function {\bf protected-symbol-warn} was added because it is -used in {\bf setvart.boot} but apparently is nowhere defined. It -is probably primitive to {\bf CCL}. - -The function {\bf protect-symbols} was added because it is -used in {\bf setvart.boot} but apparently is nowhere defined. It -is probably primitive to {\bf CCL}. - -The output of these functions is just a noisy warning message -and this has been commented out. -\section{GCL cmpnote function} -GCL keeps noting the fact that the compiler is performing tail-recursion. -Bill Schelter added this as a debugging tool for Axiom and it was never -removed. Patching the lisp code in the GCL build fails as the system -is actually built from the pre-compiled C code. Thus, we can only step -on this message after the fact. The cmpnote function is used nowhere -else in GCL so stepping on the function call seems best. We're unhappy -with this hack and will try to convince the GCL crowd to fix this. -<>= -#+:gcl (defun compiler::cmpnote (&rest x)) -@ -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -<> - -(import-module "boot-pkg") -(in-package "BOOT") - -(defun protected-symbol-warn (&rest arg)) -; (format t "protected-symbol-warn called with ~A~%" arg)) - -(defun protect-symbols (&rest arg)) -; (format t "protected-symbol-warn called with ~A~%" arg)) - -(defun use-fast-links (arg) -; (format t "use-fast-links called with ~A~%" arg) -#+:GCL (si::use-fast-links arg) - ) - -(defun verbos (arg)) -; (format t "verbos called with ~A~%" arg)) - -(defun enable-backtrace (&rest arg) -#+:ccl - (format t "protected-symbol-warn called with ~A~%" arg)) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/nspadaux.lisp b/src/interp/nspadaux.lisp index 299b5240..cc31a68a 100644 --- a/src/interp/nspadaux.lisp +++ b/src/interp/nspadaux.lisp @@ -1,5 +1,7 @@ ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are diff --git a/src/interp/obey.lisp b/src/interp/obey.lisp index 8636fef4..9d19fa1f 100644 --- a/src/interp/obey.lisp +++ b/src/interp/obey.lisp @@ -1,5 +1,7 @@ ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are diff --git a/src/interp/parsing.lisp b/src/interp/parsing.lisp index 54ee8efd..21ec9745 100644 --- a/src/interp/parsing.lisp +++ b/src/interp/parsing.lisp @@ -1,5 +1,7 @@ ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are diff --git a/src/interp/patches.lisp b/src/interp/patches.lisp new file mode 100644 index 00000000..408e92d9 --- /dev/null +++ b/src/interp/patches.lisp @@ -0,0 +1,398 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + +(in-package "BOOT") +;;patches for now + +;; browser stuff: +;; gdr NOTES: it is WRONG to test for platforms, when in fact +;; gdr NOTES: one should test for functionalities. +#+:UNIX (defvar |$standard| 't) +#-:UNIX (defvar |$standard| 'nil) +#+(or :UNIX :winnt) (defvar |$saturn| 'nil) +#-(or :UNIX :winnt) (defvar |$saturn| 't) + +(defun CATCHALL (a &rest b) a) ;; not correct but ok for now +(defvar |$demoFlag| nil) + +(define-function '|construct| #'list) ;; NEEDED , SPAD-COMPILER generated Lisp code +(define-function '|COMP,TRAN| #'comp-tran) ;called by |compWithMappingMode| + +(defvar |Undef| (function |Undef|)) ;needed in NewbFVectorCopy +(define-function '|spadHash| #'sxhash) + +(defun |mkAutoLoad| (fn cname) + (function (lambda (&rest args) + (|autoLoad| fn cname) + (apply cname args)))) + +(setq |$printTimeIfTrue| nil) + + +(defmacro dribinit (streamvar) + `(if (is-console ,streamvar) + (setq ,streamvar *terminal-io*))) + +(defun |cd| (args) + (let ((dir (truename (string (or (car args) ""))))) + #+ :SBCL (sb-posix::chdir (namestring dir)) + #+ :GCL (system::chdir (namestring dir)) + #- (or :SBCL :GCL) (error "don't know how to chdir in this Lisp") + ;; FIXME: some Lisps may not properly end the name with slash + ;; investigate. + (setf *default-pathname-defaults* dir) + (|sayKeyedMsg| 'S2IZ0070 + (list (namestring *default-pathname-defaults*))))) + +;; The function top-level is the very root of the normal invocation +;; history stack. Control will pass to the restart function which is +;; also in this file. +;; For some unknown reason toplevel was redefined to incorrectly +;; call lisp::unwind whereas it is defined (in this file) to be +;; interned in the boot package. We've returned toplevel to its +;; previous definition. +(defun toplevel (&rest foo) (throw '|top_level| '|restart|)) +;;(defun toplevel (&rest foo) (lisp::unwind)) + +(define-function 'top-level #'toplevel) +(define-function 'unwind #'|spadThrow|) +(define-function 'resume #'|spadThrow|) + +(DEFUN BUMPCOMPERRORCOUNT () ()) + +(define-function '|isBpiOrLambda| #'FBOUNDP) +;;(defun |isSharpVar| (x) (and (identp x) (char= (elt (pname x) 0) #\#))) + +(setq |$useInternalHistoryTable| T) +(defvar |$internalHistoryTable| ()) +(setq |nullstream| '|nullstream|) +(setq |nonnullstream| '|nonnullstream|) +(defun |cpCms| (prefix &optional (string (|getSystemCommandLine|))) + (setq string (concat prefix string)) + (if (equal string "") (obey "sh") + (obey string)) + (|terminateSystemCommand|)) +(setq *print-escape* nil) ;; so stringimage doesn't escape idents? +#+(and :GCL :IEEE-FLOATING-POINT ) + (setq system:*print-nans* T) + +(defun /RF (&rest foo &aux (Echo-Meta 'T)) + (declare (special Echo-Meta)) + (/RF-1 nil)) + +(defun /RQ (&rest foo &aux (Echo-Meta nil)) + (declare (special Echo-Meta)) + (/RF-1 nil)) + +(defun |/RQ,LIB| (&rest foo &aux (Echo-Meta nil) ($LISPLIB T)) + (declare (special Echo-Meta $LISPLIB)) + (/RF-1 nil)) + +(defun /RF-1 (ignore) + (declare (ignore ignore)) + (let* ((input-file (make-input-filename /EDITFILE)) + (lfile ()) + (type (pathname-type input-file))) + (cond + ((string= type "boot") +#-:CCL + (boot input-file + (setq lfile (make-pathname :type "lisp" + :defaults input-file))) +#+:CCL + (boot input-file + (setq lfile (make-pathname :name (pathname-name input-file) + :type "lisp"))) + (load lfile)) + ((string= type "lisp") (load input-file)) + ((string= type "bbin") (load input-file)) + ((and (string= type "input") + |$useNewParser|) + (|ncINTERPFILE| input-file Echo-Meta)) + (t (spad input-file))))) + +(defun /EF (&rest foo) + (obey (concat "vi " (namestring (make-input-filename /EDITFILE))))) +#-:CCL + (defun user::start () (in-package "BOOT") (boot::|start|)) +#+:CCL + (defun user::start () (setq *package* (find-package "BOOT")) (boot::|start|)) + +(setq |$algebraOutputStream| + (setq |$fortranOutputStream| + (setq |$texOutputStream| + (setq |$formulaOutputStream| + (setq |conOutStream| (make-synonym-stream '*terminal-io*)))))) + +;; non-interactive restarts... +(defun restart0 () +#+(and :NAG :ccl) (lisp::init-lm 0) + (compressopen);; set up the compression tables + (interpopen);; open up the interpreter database + (operationopen);; all of the operations known to the system + (categoryopen);; answer hasCategory question + (browseopen) + (let ((asharprootlib (strconc (|systemRootDirectory|) "/aldor/lib/"))) + (set-file-getter (strconc asharprootlib "runtime.o")) + (set-file-getter (strconc asharprootlib "lang.o")) + (set-file-getter (strconc asharprootlib "attrib.o")) + (set-file-getter (strconc asharprootlib "axlit.o")) + (set-file-getter (strconc asharprootlib "minimach.o")) + (set-file-getter (strconc asharprootlib "axextend.o"))) +) + +(defun SHAREDITEMS (x) T) ;;checked in history code +(defun whocalled (n) nil) ;; no way to look n frames up the stack +(defun setletprintflag (x) x) +(defun |normalizeTimeAndStringify| (time) + (if (= time 0.0) "0" (format nil "~,1F" time))) + +(define-function '|eval| #'eval) + +(defun |libraryFileLists| () '((SPAD SPADLIBS J))) + +;;--------------------> NEW DEFINITION (see cattable.boot.pamphlet) +(defun |compressHashTable| (ht) ht) +(defun GETZEROVEC (n) (MAKE-ARRAY n :initial-element 0)) + +(defun |normalizeArgFileName| (l) l) + +(defun READSPADEXPR () + (let* ((line (cdar (preparse in-stream)))) + (cond ((or (not (stringp line)) (zerop (SIZE line))) + (SAY " Scratchpad -- input") + (READSPADEXPR)) + (t (|parseTransform| (|postTransform| (|string2SpadTree| line))))))) + +(setq |$sourceFiles| ()) ;; set in readSpad2Cmd + +(setq |$localVars| ()) ;checked by isType + +(setq |$highlightFontOn| (concat " " |$boldString|)) +(setq |$highlightFontOff| (concat |$normalString| " ")) +(define-function 'SUBSTQ #'SUBSTEQ) ;; needed for substNames (always copy) +#+(and :lucid (not :ibm/370)) + (define-function 'RUN-AIX-PROGRAM #'SYS:RUN-AIX-PROGRAM) +;; following should be no longer necessary +;; (eval-when (eval load compile) (shadow 'delete)) +;; (define-function 'boot::delete #'|delete|) + +;; following code is to mimic def of MAP in NEWSPAD LISP +;; i.e. MAP in boot package is a self evaluating form +;; #-:CCL (eval-when (eval load compile) (shadow 'map)) +;; #-:CCL (defmacro map (&rest args) `'(map ,@args)) +(eval-when (eval load compile) (shadow 'map)) +(defmacro map (&rest args) `'(map ,@args)) + +#+:Lucid +(defun save-system (filename) + (in-package "BOOT") + (UNTRACE) + (|untrace| NIL) + (|clearClams|) + ;; bind output to nulloutstream + (let ((*standard-output* (make-broadcast-stream))) + (|resetWorkspaceVariables|)) + (setq |$specialCharacters| |$plainRTspecialCharacters|) + + (load (make-absolute-filename "lib/interp/obey")) + (system:disksave filename :restart-function restart-hook :full-gc t)) +#+:Lucid (define-function 'user::save-system #'boot::save-system) +(defun |undoINITIALIZE| () ()) +;; following are defined in spadtest.boot and stantest.boot +(defun |installStandardTestPackages| () ()) +(defun |spadtestValueHook| (val type) ()) +(defun |testError| (errotype erroValue) ()) +(defvar |$TestOptions| ()) +;; following in defined in word.boot +(defun |bootFind| (word) ()) +;; following 3 are replacements for g-util.boot +(define-function '|isLowerCaseLetter| #'LOWER-CASE-P) +(define-function '|isUpperCaseLetter| #'UPPER-CASE-P) +(define-function '|isLetter| #'ALPHA-CHAR-P) +;; reset from /spad/lisp/setq.lisp +(setq |$consistencyCheck| ()) ;; prevents wasting time checking consistency + + +#+(or :CCL (and :lucid :ibm/370)) +(setq $current-directory (truename ".")) +#-(or :CCL (and :lucid :ibm/370)) +(setq $current-directory (make-directory *default-pathname-defaults*)) + +(defvar *msghash* nil "hash table keyed by msg number") + +(defun cacheKeyedMsg (file) + (let ((line "") (msg "") key) + (with-open-file (in file) + (catch 'done + (loop + (setq line (read-line in nil nil)) + (cond + ((null line) + (when key + (setf (gethash key *msghash*) msg)) + (throw 'done nil)) + ((= (length line) 0)) + ((char= (schar line 0) #\S) + (when key + (setf (gethash key *msghash*) msg)) + (setq key (intern line "BOOT")) + (setq msg "")) + ('else + (setq msg (concatenate 'string msg line))))))))) + +(defun |fetchKeyedMsg| (key ignore) + (declare (ignore ignore)) + (setq key (|object2Identifier| key)) + (unless *msghash* + (setq *msghash* (make-hash-table)) + (cacheKeyedMsg |$defaultMsgDatabaseName|)) + (gethash key *msghash*)) + +#+:AKCL (proclaim '(ftype (function (t) t) identity)) +#+:AKCL (defun identity (x) x) + +(|initializeTimedNames| |$interpreterTimedNames| |$interpreterTimedClasses|) + +(defun |rebuild| (filemode) + "rebuild MODEMAP.DAASE, exit lisp with bad return code on failure" + (let ((returncode -16)) + (unwind-protect + (let (|$databaseQueue| |$e|) + (declare (special |$databaseQueue| |$e|)) + (|clearConstructorAndLisplibCaches|) + (setq |$databaseQueue| nil) + (setq |$e| (cons (cons nil nil) nil)) + (|buildDatabase| filemode t) + (setq |$IOindex| 1) + (setq |$InteractiveFrame| (cons (cons nil nil) nil)) + (setq returncode 0)) + (unless (zerop returncode) (bye returncode))))) + +#+:dos +(setq $current-directory (truename ".")) +#+:dos +(defun user-homedir-pathname () + (truename ".")) + +(defun boot::|printCopyright| () + (format t "there is no such thing as a simple job -- ((iHy))~%")) + +(defun |setViewportProcess| () + (setq |$ViewportProcessToWatch| + (stringimage (CDR + (|processInteractive| '(|key| (|%%| -2)) NIL) )))) + +(defun |waitForViewport| () + (progn + (do () + ((not (zerop (obey + (concat + "ps " + |$ViewportProcessToWatch| + " > /dev/null"))))) + ()) + (|sockSendInt| |$MenuServer| 1) + (|setIOindex| (- |$IOindex| 3)) + ) +) + + +(defun |makeVector| (els type) + (make-array (length els) :element-type (or type t) :initial-contents els)) + + +(defun |makeList| (size el) (make-list size :initial-element el) ) + +#+:akcl +(defun print-xdr-stream (x y z) (format y "XDR:~A" (xdr-stream-name x))) +#+:akcl +(defstruct (xdr-stream + (:print-function print-xdr-stream)) + "A structure to hold XDR streams. The stream is printed out." + (handle ) ;; this is what is used for xdr-open xdr-read xdr-write + (name )) ;; this is used for printing +#+(and :gcl (not (or :dos :win32))) +(defun |xdrOpen| (str dir) (make-xdr-stream :handle (system:xdr-open str) :name str)) +#+:CCL +(defun |xdrOpen| (str dir) (xdr-open str dir) ) +#+(and :gcl (or :dos :win32)) +(defun |xdrOpen| (str dir) (format t "xdrOpen called")) + +#+(and :akcl (not (or :dos :win32))) +(defun |xdrRead| (xstr r) (system:xdr-read (xdr-stream-handle xstr) r) ) +#+:CCL +(defun |xdrRead| (xstr r) (xdr-read xstr r) ) +#+(and :gcl (or :dos :win32)) +(defun |xdrRead| (str) (format t "xdrRead called")) + +#+(and :akcl (not (or :dos :win32))) +(defun |xdrWrite| (xstr d) (system:xdr-write (xdr-stream-handle xstr) d) ) +#+:CCL +(defun |xdrWrite| (xstr d) (xdr-write xstr d) ) +#+(and :gcl (or :dos :win32)) +(defun |xdrWrite| (str) (format t "xdrWrite called")) + +;; here is a test for XDR +;; (setq *print-array* T) +;; (setq foo (open "xdrtest" :direction :output)) +;; (setq xfoo (|xdrOpen| foo)) +;; (|xdrWrite| xfoo "hello: This contains an integer, a float and a float array") +;; (|xdrWrite| xfoo 42) +;; (|xdrWrite| xfoo 3.14159) +;; (|xdrWrite| xfoo (make-array 10 :element-type 'long-float :initial-element 2.78111D12)) +;; (close foo) +;; (setq foo (open "xdrtest" :direction :input)) +;; (setq xfoo (|xdrOpen| foo)) +;; (|xdrRead| xfoo "") +;; (|xdrRead| xfoo 0) +;; (|xdrRead| xfoo 0.0) +;; (|xdrRead| xfoo (make-array 10 :element-type 'long-float )) +;; (setq *print-array* NIL) + +;; clearParserMacro has problems as boot code (package notation) +;; defined here in Lisp +;;--------------------> NEW DEFINITION (see i-syscmd.boot.pamphlet) +(DEFUN |clearParserMacro| (|macro|) + (PROG () + (RETURN (COND + ((NULL (IFCDR (|assoc| |macro| |$pfMacros|))) NIL) + ((QUOTE T) (SPADLET |$pfMacros| + (REMALIST |$pfMacros| |macro|))))))) +; + +(setq /MAJOR-VERSION 2) +(setq echo-meta nil) +(defun /versioncheck (n) (unless (= n /MAJOR-VERSION) (throw 'versioncheck -1))) + diff --git a/src/interp/patches.lisp.pamphlet b/src/interp/patches.lisp.pamphlet deleted file mode 100644 index 25dd354f..00000000 --- a/src/interp/patches.lisp.pamphlet +++ /dev/null @@ -1,423 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp patches.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\subsection{toplevel} -The function top-level is the very root of the normal invocation -history stack. Control will pass to the restart function which is -also in this file. - -For some unknown reason toplevel was redefined to incorrectly -call lisp::unwind whereas it is defined (in this file) to be -interned in the boot package. We've returned toplevel to its -previous definition. -<>= -(defun toplevel (&rest foo) (throw '|top_level| '|restart|)) -;;(defun toplevel (&rest foo) (lisp::unwind)) - -@ -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -(in-package "BOOT") -;;patches for now - -;; browser stuff: -;; gdr NOTES: it is WRONG to test for platforms, when in fact -;; gdr NOTES: one should test for functionalities. -#+:UNIX (defvar |$standard| 't) -#-:UNIX (defvar |$standard| 'nil) -#+(or :UNIX :winnt) (defvar |$saturn| 'nil) -#-(or :UNIX :winnt) (defvar |$saturn| 't) - -(defun CATCHALL (a &rest b) a) ;; not correct but ok for now -(defvar |$demoFlag| nil) - -(define-function '|construct| #'list) ;; NEEDED , SPAD-COMPILER generated Lisp code -(define-function '|COMP,TRAN| #'comp-tran) ;called by |compWithMappingMode| - -(defvar |Undef| (function |Undef|)) ;needed in NewbFVectorCopy -(define-function '|spadHash| #'sxhash) - -(defun |mkAutoLoad| (fn cname) - (function (lambda (&rest args) - (|autoLoad| fn cname) - (apply cname args)))) - -(setq |$printTimeIfTrue| nil) - - -(defmacro dribinit (streamvar) - `(if (is-console ,streamvar) - (setq ,streamvar *terminal-io*))) - -(defun |cd| (args) - (let ((dir (truename (string (or (car args) ""))))) - #+ :SBCL (sb-posix::chdir (namestring dir)) - #+ :GCL (system::chdir (namestring dir)) - #- (or :SBCL :GCL) (error "don't know how to chdir in this Lisp") - ;; FIXME: some Lisps may not properly end the name with slash - ;; investigate. - (setf *default-pathname-defaults* dir) - (|sayKeyedMsg| 'S2IZ0070 - (list (namestring *default-pathname-defaults*))))) - -<> -(define-function 'top-level #'toplevel) -(define-function 'unwind #'|spadThrow|) -(define-function 'resume #'|spadThrow|) - -(DEFUN BUMPCOMPERRORCOUNT () ()) - -(define-function '|isBpiOrLambda| #'FBOUNDP) -;;(defun |isSharpVar| (x) (and (identp x) (char= (elt (pname x) 0) #\#))) - -(setq |$useInternalHistoryTable| T) -(defvar |$internalHistoryTable| ()) -(setq |nullstream| '|nullstream|) -(setq |nonnullstream| '|nonnullstream|) -(defun |cpCms| (prefix &optional (string (|getSystemCommandLine|))) - (setq string (concat prefix string)) - (if (equal string "") (obey "sh") - (obey string)) - (|terminateSystemCommand|)) -(setq *print-escape* nil) ;; so stringimage doesn't escape idents? -#+(and :GCL :IEEE-FLOATING-POINT ) - (setq system:*print-nans* T) - -(defun /RF (&rest foo &aux (Echo-Meta 'T)) - (declare (special Echo-Meta)) - (/RF-1 nil)) - -(defun /RQ (&rest foo &aux (Echo-Meta nil)) - (declare (special Echo-Meta)) - (/RF-1 nil)) - -(defun |/RQ,LIB| (&rest foo &aux (Echo-Meta nil) ($LISPLIB T)) - (declare (special Echo-Meta $LISPLIB)) - (/RF-1 nil)) - -(defun /RF-1 (ignore) - (declare (ignore ignore)) - (let* ((input-file (make-input-filename /EDITFILE)) - (lfile ()) - (type (pathname-type input-file))) - (cond - ((string= type "boot") -#-:CCL - (boot input-file - (setq lfile (make-pathname :type "lisp" - :defaults input-file))) -#+:CCL - (boot input-file - (setq lfile (make-pathname :name (pathname-name input-file) - :type "lisp"))) - (load lfile)) - ((string= type "lisp") (load input-file)) - ((string= type "bbin") (load input-file)) - ((and (string= type "input") - |$useNewParser|) - (|ncINTERPFILE| input-file Echo-Meta)) - (t (spad input-file))))) - -(defun /EF (&rest foo) - (obey (concat "vi " (namestring (make-input-filename /EDITFILE))))) -#-:CCL - (defun user::start () (in-package "BOOT") (boot::|start|)) -#+:CCL - (defun user::start () (setq *package* (find-package "BOOT")) (boot::|start|)) - -(setq |$algebraOutputStream| - (setq |$fortranOutputStream| - (setq |$texOutputStream| - (setq |$formulaOutputStream| - (setq |conOutStream| (make-synonym-stream '*terminal-io*)))))) - -;; non-interactive restarts... -(defun restart0 () -#+(and :NAG :ccl) (lisp::init-lm 0) - (compressopen);; set up the compression tables - (interpopen);; open up the interpreter database - (operationopen);; all of the operations known to the system - (categoryopen);; answer hasCategory question - (browseopen) - (let ((asharprootlib (strconc (|systemRootDirectory|) "/aldor/lib/"))) - (set-file-getter (strconc asharprootlib "runtime.o")) - (set-file-getter (strconc asharprootlib "lang.o")) - (set-file-getter (strconc asharprootlib "attrib.o")) - (set-file-getter (strconc asharprootlib "axlit.o")) - (set-file-getter (strconc asharprootlib "minimach.o")) - (set-file-getter (strconc asharprootlib "axextend.o"))) -) - -(defun SHAREDITEMS (x) T) ;;checked in history code -(defun whocalled (n) nil) ;; no way to look n frames up the stack -(defun setletprintflag (x) x) -(defun |normalizeTimeAndStringify| (time) - (if (= time 0.0) "0" (format nil "~,1F" time))) - -(define-function '|eval| #'eval) - -(defun |libraryFileLists| () '((SPAD SPADLIBS J))) - -;;--------------------> NEW DEFINITION (see cattable.boot.pamphlet) -(defun |compressHashTable| (ht) ht) -(defun GETZEROVEC (n) (MAKE-ARRAY n :initial-element 0)) - -(defun |normalizeArgFileName| (l) l) - -(defun READSPADEXPR () - (let* ((line (cdar (preparse in-stream)))) - (cond ((or (not (stringp line)) (zerop (SIZE line))) - (SAY " Scratchpad -- input") - (READSPADEXPR)) - (t (|parseTransform| (|postTransform| (|string2SpadTree| line))))))) - -(setq |$sourceFiles| ()) ;; set in readSpad2Cmd - -(setq |$localVars| ()) ;checked by isType - -(setq |$highlightFontOn| (concat " " |$boldString|)) -(setq |$highlightFontOff| (concat |$normalString| " ")) -(define-function 'SUBSTQ #'SUBSTEQ) ;; needed for substNames (always copy) -#+(and :lucid (not :ibm/370)) - (define-function 'RUN-AIX-PROGRAM #'SYS:RUN-AIX-PROGRAM) -;; following should be no longer necessary -;; (eval-when (eval load compile) (shadow 'delete)) -;; (define-function 'boot::delete #'|delete|) - -;; following code is to mimic def of MAP in NEWSPAD LISP -;; i.e. MAP in boot package is a self evaluating form -;; #-:CCL (eval-when (eval load compile) (shadow 'map)) -;; #-:CCL (defmacro map (&rest args) `'(map ,@args)) -(eval-when (eval load compile) (shadow 'map)) -(defmacro map (&rest args) `'(map ,@args)) - -#+:Lucid -(defun save-system (filename) - (in-package "BOOT") - (UNTRACE) - (|untrace| NIL) - (|clearClams|) - ;; bind output to nulloutstream - (let ((*standard-output* (make-broadcast-stream))) - (|resetWorkspaceVariables|)) - (setq |$specialCharacters| |$plainRTspecialCharacters|) - - (load (make-absolute-filename "lib/interp/obey")) - (system:disksave filename :restart-function restart-hook :full-gc t)) -#+:Lucid (define-function 'user::save-system #'boot::save-system) -(defun |undoINITIALIZE| () ()) -;; following are defined in spadtest.boot and stantest.boot -(defun |installStandardTestPackages| () ()) -(defun |spadtestValueHook| (val type) ()) -(defun |testError| (errotype erroValue) ()) -(defvar |$TestOptions| ()) -;; following in defined in word.boot -(defun |bootFind| (word) ()) -;; following 3 are replacements for g-util.boot -(define-function '|isLowerCaseLetter| #'LOWER-CASE-P) -(define-function '|isUpperCaseLetter| #'UPPER-CASE-P) -(define-function '|isLetter| #'ALPHA-CHAR-P) -;; reset from /spad/lisp/setq.lisp -(setq |$consistencyCheck| ()) ;; prevents wasting time checking consistency - - -#+(or :CCL (and :lucid :ibm/370)) -(setq $current-directory (truename ".")) -#-(or :CCL (and :lucid :ibm/370)) -(setq $current-directory (make-directory *default-pathname-defaults*)) - -(defvar *msghash* nil "hash table keyed by msg number") - -(defun cacheKeyedMsg (file) - (let ((line "") (msg "") key) - (with-open-file (in file) - (catch 'done - (loop - (setq line (read-line in nil nil)) - (cond - ((null line) - (when key - (setf (gethash key *msghash*) msg)) - (throw 'done nil)) - ((= (length line) 0)) - ((char= (schar line 0) #\S) - (when key - (setf (gethash key *msghash*) msg)) - (setq key (intern line "BOOT")) - (setq msg "")) - ('else - (setq msg (concatenate 'string msg line))))))))) - -(defun |fetchKeyedMsg| (key ignore) - (declare (ignore ignore)) - (setq key (|object2Identifier| key)) - (unless *msghash* - (setq *msghash* (make-hash-table)) - (cacheKeyedMsg |$defaultMsgDatabaseName|)) - (gethash key *msghash*)) - -#+:AKCL (proclaim '(ftype (function (t) t) identity)) -#+:AKCL (defun identity (x) x) - -(|initializeTimedNames| |$interpreterTimedNames| |$interpreterTimedClasses|) - -(defun |rebuild| (filemode) - "rebuild MODEMAP.DAASE, exit lisp with bad return code on failure" - (let ((returncode -16)) - (unwind-protect - (let (|$databaseQueue| |$e|) - (declare (special |$databaseQueue| |$e|)) - (|clearConstructorAndLisplibCaches|) - (setq |$databaseQueue| nil) - (setq |$e| (cons (cons nil nil) nil)) - (|buildDatabase| filemode t) - (setq |$IOindex| 1) - (setq |$InteractiveFrame| (cons (cons nil nil) nil)) - (setq returncode 0)) - (unless (zerop returncode) (bye returncode))))) - -#+:dos -(setq $current-directory (truename ".")) -#+:dos -(defun user-homedir-pathname () - (truename ".")) - -(defun boot::|printCopyright| () - (format t "there is no such thing as a simple job -- ((iHy))~%")) - -(defun |setViewportProcess| () - (setq |$ViewportProcessToWatch| - (stringimage (CDR - (|processInteractive| '(|key| (|%%| -2)) NIL) )))) - -(defun |waitForViewport| () - (progn - (do () - ((not (zerop (obey - (concat - "ps " - |$ViewportProcessToWatch| - " > /dev/null"))))) - ()) - (|sockSendInt| |$MenuServer| 1) - (|setIOindex| (- |$IOindex| 3)) - ) -) - - -(defun |makeVector| (els type) - (make-array (length els) :element-type (or type t) :initial-contents els)) - - -(defun |makeList| (size el) (make-list size :initial-element el) ) - -#+:akcl -(defun print-xdr-stream (x y z) (format y "XDR:~A" (xdr-stream-name x))) -#+:akcl -(defstruct (xdr-stream - (:print-function print-xdr-stream)) - "A structure to hold XDR streams. The stream is printed out." - (handle ) ;; this is what is used for xdr-open xdr-read xdr-write - (name )) ;; this is used for printing -#+(and :gcl (not (or :dos :win32))) -(defun |xdrOpen| (str dir) (make-xdr-stream :handle (system:xdr-open str) :name str)) -#+:CCL -(defun |xdrOpen| (str dir) (xdr-open str dir) ) -#+(and :gcl (or :dos :win32)) -(defun |xdrOpen| (str dir) (format t "xdrOpen called")) - -#+(and :akcl (not (or :dos :win32))) -(defun |xdrRead| (xstr r) (system:xdr-read (xdr-stream-handle xstr) r) ) -#+:CCL -(defun |xdrRead| (xstr r) (xdr-read xstr r) ) -#+(and :gcl (or :dos :win32)) -(defun |xdrRead| (str) (format t "xdrRead called")) - -#+(and :akcl (not (or :dos :win32))) -(defun |xdrWrite| (xstr d) (system:xdr-write (xdr-stream-handle xstr) d) ) -#+:CCL -(defun |xdrWrite| (xstr d) (xdr-write xstr d) ) -#+(and :gcl (or :dos :win32)) -(defun |xdrWrite| (str) (format t "xdrWrite called")) - -;; here is a test for XDR -;; (setq *print-array* T) -;; (setq foo (open "xdrtest" :direction :output)) -;; (setq xfoo (|xdrOpen| foo)) -;; (|xdrWrite| xfoo "hello: This contains an integer, a float and a float array") -;; (|xdrWrite| xfoo 42) -;; (|xdrWrite| xfoo 3.14159) -;; (|xdrWrite| xfoo (make-array 10 :element-type 'long-float :initial-element 2.78111D12)) -;; (close foo) -;; (setq foo (open "xdrtest" :direction :input)) -;; (setq xfoo (|xdrOpen| foo)) -;; (|xdrRead| xfoo "") -;; (|xdrRead| xfoo 0) -;; (|xdrRead| xfoo 0.0) -;; (|xdrRead| xfoo (make-array 10 :element-type 'long-float )) -;; (setq *print-array* NIL) - -;; clearParserMacro has problems as boot code (package notation) -;; defined here in Lisp -;;--------------------> NEW DEFINITION (see i-syscmd.boot.pamphlet) -(DEFUN |clearParserMacro| (|macro|) - (PROG () - (RETURN (COND - ((NULL (IFCDR (|assoc| |macro| |$pfMacros|))) NIL) - ((QUOTE T) (SPADLET |$pfMacros| - (REMALIST |$pfMacros| |macro|))))))) -; - -(setq /MAJOR-VERSION 2) -(setq echo-meta nil) -(defun /versioncheck (n) (unless (= n /MAJOR-VERSION) (throw 'versioncheck -1))) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} CMUCL {\bf src/interp/util.lisp.pamphlet} -\end{thebibliography} -\end{document} diff --git a/src/interp/postprop.lisp b/src/interp/postprop.lisp index 30ac7248..857ec26b 100644 --- a/src/interp/postprop.lisp +++ b/src/interp/postprop.lisp @@ -1,5 +1,7 @@ ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are diff --git a/src/interp/preparse.lisp b/src/interp/preparse.lisp new file mode 100644 index 00000000..5c2cf911 --- /dev/null +++ b/src/interp/preparse.lisp @@ -0,0 +1,399 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + +;; NAME: Pre-Parsing Code +;; PURPOSE: BOOT lines are massaged by PREPARSE to make them easier to parse: +;; 1. Trailing -- comments are removed (this is already done, actually). +;; 2. Comments between { and } are removed. +;; 3. BOOT code is column-sensitive. Code which lines up columnarly is +;; parenthesized and semicolonized accordingly. For example, +;; +;; a +;; b +;; c +;; d +;; e +;; +;; becomes +;; +;; a +;; (b; +;; c +;; d) +;; e +;; +;; Note that to do this correctly, we also need to keep track of +;; parentheses already in the code. + + + +(IMPORT-MODULE "fnewmeta") + +(in-package "BOOT") + +; Global storage + +(defparameter $INDEX 0 "File line number of most recently read line.") +(defparameter $preparse-last-line () "Most recently read line.") +(defparameter $preparseReportIfTrue NIL "Should we print listings?") +(defparameter $LineList nil "Stack of preparsed lines.") +(defparameter $EchoLineStack nil "Stack of lines to list.") +(defparameter $IOIndex 0 "Number of latest terminal input line.") + +(defun Initialize-Preparse (strm) + (setq $INDEX 0 $LineList nil $EchoLineStack nil) + (setq $preparse-last-line (get-a-line strm))) + +(defmacro pptest () `(/rp ">scratchpad>test.boot")) + +(defun /RP (&optional (*boot-input-file* nil) (*boot-output-file* nil) + ($preparseReportIfTrue t)) + (with-open-stream + (in-stream (or (and *boot-input-file* (open *boot-input-file* :direction :input)) + *terminal-io*)) + (declare (special in-stream)) + (with-open-stream + (out-stream (if *boot-output-file* + (open *boot-output-file* :direction :output) + *terminal-io*)) + (declare (special out-stream)) + (initialize-preparse in-stream) + (do ((lines (PREPARSE in-stream) (PREPARSE in-stream))) ((null lines))))) + T) + + +(defvar $skipme) +(defvar $COMBLOCKLIST) + +(defun PREPARSE (Strm &aux (stack ())) + (SETQ $COMBLOCKLIST NIL $skipme NIL) + (when $preparse-last-line + (if (pairp $preparse-last-line) + (setq stack $preparse-last-line) + (push $preparse-last-line stack)) + (setq $INDEX (- $INDEX (length stack)))) + (let ((U (PREPARSE1 stack))) + (if $skipme (preparse strm) + (progn + (if $preparseReportIfTrue (PARSEPRINT U)) + (setq |$headerDocumentation| NIL) + (SETQ |$docList| NIL) + (SETQ |$maxSignatureLineNumber| 0) + (SETQ |$constructorLineNumber| (IFCAR (IFCAR U))) + U)))) + +(defun PREPARSE1 (LineList) + (PROG (($LINELIST LineList) $EchoLineStack NUM A I L PSLOC + INSTRING PCOUNT COMSYM STRSYM OPARSYM CPARSYM N NCOMSYM + (SLOC -1) (CONTINUE NIL) (PARENLEV 0) (NCOMBLOCK ()) + (LINES ()) (LOCS ()) (NUMS ()) functor ) + READLOOP (DCQ (NUM . A) (preparseReadLine LineList)) + (cond ((atEndOfUnit A) + (PREPARSE-ECHO LineList) + (COND ((NULL LINES) (RETURN NIL)) + (NCOMBLOCK + (FINCOMBLOCK NIL NUMS LOCS NCOMBLOCK NIL))) + (RETURN (PAIR (NREVERSE NUMS) + (PARSEPILES (NREVERSE LOCS) (NREVERSE LINES)))))) + (cond ((and (NULL LINES) (> (LENGTH A) 0) (EQ (CHAR A 0) #\) )) + ; this is a command line, don't parse it + (PREPARSE-ECHO LineList) + (setq $preparse-last-line nil) ;don't reread this line + (SETQ LINE a) + (CATCH 'SPAD_READER (|doSystemCommand| (subseq LINE 1))) + (GO READLOOP))) + (setq L (LENGTH A)) + (if (EQ L 0) (GO READLOOP)) + (setq PSLOC SLOC) + (setq I 0 INSTRING () PCOUNT 0) + STRLOOP (setq STRSYM (OR (position #\" A :start I ) L)) + (setq COMSYM (OR (search "--" A :start2 I ) L)) + (setq NCOMSYM (OR (search "++" A :start2 I ) L)) + (setq OPARSYM (OR (position #\( A :start I ) L)) + (setq CPARSYM (OR (position #\) A :start I ) L)) + (setq N (MIN STRSYM COMSYM NCOMSYM OPARSYM CPARSYM)) + (cond ((= N L) (GO NOCOMS)) + ((ESCAPED A N)) + ((= N STRSYM) (setq INSTRING (NOT INSTRING))) + (INSTRING) + ((= N COMSYM) (setq A (subseq A 0 N)) (GO NOCOMS)) ; discard trailing comment + ((= N NCOMSYM) + (setq SLOC (INDENT-POS A)) + (COND + ((= SLOC N) + (COND ((AND NCOMBLOCK (NOT (= N (CAR NCOMBLOCK)))) + (FINCOMBLOCK NUM NUMS LOCS NCOMBLOCK linelist) + (SETQ NCOMBLOCK NIL))) + (SETQ NCOMBLOCK (CONS N (CONS A (IFCDR NCOMBLOCK)))) + (SETQ A "")) + ('T (PUSH (STRCONC (GETFULLSTR N " ") + (SUBSTRING A N ())) $LINELIST) + (SETQ $INDEX (SUB1 $INDEX)) + (SETQ A (SUBSEQ A 0 N)))) + (GO NOCOMS)) + ((= N OPARSYM) (setq PCOUNT (1+ PCOUNT))) + ((= N CPARSYM) (setq PCOUNT (1- PCOUNT)))) + (setq I (1+ N)) + (GO STRLOOP) + NOCOMS (setq SLOC (INDENT-POS A)) + (setq A (DROPTRAILINGBLANKS A)) + (cond ((NULL SLOC) (setq SLOC PSLOC) (GO READLOOP))) + (cond ((EQ (ELT A (MAXINDEX A)) XCAPE) + (setq CONTINUE T a (subseq A (MAXINDEX A)))) + ((setq CONTINUE NIL))) + (if (and (null LINES) (= SLOC 0)) ;;test for skipping constructors + (if (and |$byConstructors| + (null (search "==>" a)) + (not (member (setq functor (intern + (substring a 0 (STRPOSL ": (=" A 0 NIL)))) + |$byConstructors|))) + (setq $skipme 't) + (progn (push functor |$constructorsSeen|) (setq $skipme nil)))) + (when (and LINES (EQL SLOC 0)) + (IF (AND NCOMBLOCK (NOT (ZEROP (CAR NCOMBLOCK)))) + (FINCOMBLOCK NUM NUMS LOCS NCOMBLOCK linelist)) + (IF (NOT (IS-CONSOLE in-stream)) + (setq $preparse-last-line + (nreverse $echolinestack))) + (RETURN (PAIR (NREVERSE NUMS) + (PARSEPILES (NREVERSE LOCS) (NREVERSE LINES))))) + (cond ((> PARENLEV 0) (PUSH NIL LOCS) (setq SLOC PSLOC) (GO REREAD))) + (COND (NCOMBLOCK + (FINCOMBLOCK NUM NUMS LOCS NCOMBLOCK linelist) + (setq NCOMBLOCK ()))) + (PUSH SLOC LOCS) + REREAD (PREPARSE-ECHO LineList) + (PUSH A LINES) + (PUSH NUM NUMS) + (setq PARENLEV (+ PARENLEV PCOUNT)) + (when (and (is-console in-stream) (not continue)) + (setq $preparse-last-line nil) + (RETURN (PAIR (NREVERSE NUMS) + (PARSEPILES (NREVERSE LOCS) (NREVERSE LINES))))) + + (GO READLOOP))) + +;; NUM is the line number of the current line +;; OLDNUMS is the list of line numbers of previous lines +;; OLDLOCS is the list of previous indentation locations +;; NCBLOCK is the current comment block +(DEFUN FINCOMBLOCK (NUM OLDNUMS OLDLOCS NCBLOCK linelist) + (PUSH + (COND ((EQL (CAR NCBLOCK) 0) (CONS (1- NUM) (REVERSE (CDR NCBLOCK)))) + ;; comment for constructor itself paired with 1st line -1 + ('T + (COND ($EchoLineStack + (setq NUM (POP $EchoLineStack)) + (PREPARSE-ECHO linelist) + (SETQ $EchoLineStack (LIST NUM)))) + (cons + ;; scan backwards for line to left of current + (DO ((onums oldnums (cdr onums)) + (olocs oldlocs (cdr olocs)) + (sloc (car ncblock))) + ((null onums) nil) + (if (and (numberp (car olocs)) + (<= (car olocs) sloc)) + (return (car onums)))) + (REVERSE (CDR NCBLOCK))))) + $COMBLOCKLIST)) + +(defun PARSEPRINT (L) + (if L + (progn (format t "~&~% *** PREPARSE ***~%~%") + (dolist (X L) (format t "~5d. ~a~%" (car x) (cdr x))) + (format t "~%")))) + +(DEFUN STOREBLANKS (LINE N) + (DO ((I 0 (ADD1 I))) ((= I N) LINE) (SETF (CHAR LINE I) #\ ))) + +(DEFUN INITIAL-SUBSTRING (PATTERN LINE) + (let ((ind (mismatch PATTERN LINE))) + (OR (NULL IND) (EQL IND (SIZE PATTERN))))) + +(DEFUN SKIP-IFBLOCK (X) + (PROG (LINE IND) + (DCQ (IND . LINE) (preparseReadLine1 X)) + (IF (NOT (STRINGP LINE)) (RETURN (CONS IND LINE))) + (IF (ZEROP (SIZE LINE)) (RETURN (SKIP-IFBLOCK X))) + (COND ((CHAR= (ELT LINE 0) #\) ) + (COND + ((INITIAL-SUBSTRING ")if" LINE) + (COND ((EVAL (|string2BootTree| (STOREBLANKS LINE 3))) + (RETURN (preparseReadLine X))) + ('T (RETURN (SKIP-IFBLOCK X))))) + ((INITIAL-SUBSTRING ")elseif" LINE) + (COND ((EVAL (|string2BootTree| (STOREBLANKS LINE 7))) + (RETURN (preparseReadLine X))) + ('T (RETURN (SKIP-IFBLOCK X))))) + ((INITIAL-SUBSTRING ")else" LINE) + (RETURN (preparseReadLine X))) + ((INITIAL-SUBSTRING ")endif" LINE) + (RETURN (preparseReadLine X))) + ((INITIAL-SUBSTRING ")fin" LINE) + (RETURN (CONS IND NIL)))))) + (RETURN (SKIP-IFBLOCK X)) ) ) + +(DEFUN SKIP-TO-ENDIF (X) + (PROG (LINE IND) + (DCQ (IND . LINE) (preparseReadLine1 X)) + (COND ((NOT (STRINGP LINE)) (RETURN (CONS IND LINE))) + ((INITIAL-SUBSTRING LINE ")endif") + (RETURN (preparseReadLine X))) + ((INITIAL-SUBSTRING LINE ")fin") (RETURN (CONS IND NIL))) + ('T (RETURN (SKIP-TO-ENDIF X)))))) + +(DEFUN preparseReadLine (X) + (PROG (LINE IND) + (DCQ (IND . LINE) (preparseReadLine1 X)) + (COND ((NOT (STRINGP LINE)) (RETURN (CONS IND LINE)))) + (COND ((ZEROP (SIZE LINE)) + (RETURN (CONS IND LINE)))) + (COND ((CHAR= (ELT LINE 0) #\) ) + (COND + ((INITIAL-SUBSTRING ")if" LINE) + (COND ((EVAL (|string2BootTree| (STOREBLANKS LINE 3))) + (RETURN (preparseReadLine X))) + ('T (RETURN (SKIP-IFBLOCK X))))) + ((INITIAL-SUBSTRING ")elseif" LINE) + (RETURN (SKIP-TO-ENDIF X))) + ((INITIAL-SUBSTRING ")else" LINE) + (RETURN (SKIP-TO-ENDIF X))) + ((INITIAL-SUBSTRING ")endif" LINE) + (RETURN (preparseReadLine X))) + ((INITIAL-SUBSTRING ")fin" LINE) + (SETQ *EOF* T) + (RETURN (CONS IND NIL)) ) ))) + (RETURN (CONS IND LINE)) )) + +(DEFUN preparseReadLine1 (X) + (PROG (LINE IND) + (SETQ LINE (if $LINELIST + (pop $LINELIST) + (expand-tabs (get-a-line in-stream)))) + (setq $preparse-last-line LINE) + (and (stringp line) (incf $INDEX)) + (COND + ( (NOT (STRINGP LINE)) + (RETURN (CONS $INDEX LINE)) ) ) + (SETQ LINE (DROPTRAILINGBLANKS LINE)) + (PUSH (COPY-SEQ LINE) $EchoLineStack) + ;; next line must evaluate $INDEX before recursive call + (RETURN + (CONS + $INDEX + (COND + ( (AND (> (SETQ IND (MAXINDEX LINE)) -1) (char= (ELT LINE IND) #\_)) + (setq $preparse-last-line + (STRCONC (SUBSTRING LINE 0 IND) (CDR (preparseReadLine1 X))) )) + ( 'T + LINE ) ))) ) ) + +;;(defun preparseReadLine (X) +;; (declare (special $LINELIST $echoLineStack)) +;; (PROG (LINE IND) +;; (setq LINE +;; (if $LINELIST +;; (pop $LINELIST) +;; (get-a-line in-stream))) +;; (setq $preparse-last-line LINE) +;; (and (stringp line) (incf $INDEX)) +;; (if (NOT (STRINGP LINE)) (RETURN (CONS $INDEX LINE))) +;; (setq LINE (DROPTRAILINGBLANKS LINE)) +;; (if Echo-Meta (PUSH (COPY-SEQ LINE) $EchoLineStack)) +;; ; next line must evaluate $INDEX before recursive call +;; (RETURN +;; (CONS $INDEX +;; (if (and (> (setq IND (MAXINDEX LINE)) -1) +;; (EQ (ELT LINE IND) #\_)) +;; (setq $preparse-last-line +;; (STRCONC (SUBSEQ LINE 0 IND) +;; (CDR (preparseReadLine X)))) +;; LINE))))) + +(defun PREPARSE-ECHO (linelist) + (if Echo-Meta (REPEAT (IN X (REVERSE $EchoLineStack)) + (format out-stream "~&;~A~%" X))) + (setq $EchoLineStack ())) + +(defun ESCAPED (STR N) (and (> N 0) (EQ (CHAR STR (1- N)) XCAPE))) + +(defun atEndOfUnit (X) (NULL (STRINGP X)) ) + +(defun PARSEPILES (LOCS LINES) + "Add parens and semis to lines to aid parsing." + (mapl #'add-parens-and-semis-to-line (NCONC LINES '(" ")) (nconc locs '(nil))) + LINES) + +(defun add-parens-and-semis-to-line (slines slocs) + + "The line to be worked on is (CAR SLINES). It's indentation is (CAR SLOCS). There +is a notion of current indentation. Then: + +A. Add open paren to beginning of following line if following line's indentation + is greater than current, and add close paren to end of last succeeding line + with following line's indentation. +B. Add semicolon to end of line if following line's indentation is the same. +C. If the entire line consists of the single keyword then or else, leave it alone." + + (let ((start-column (car slocs))) + (if (and start-column (> start-column 0)) + (let ((count 0) (i 0)) + (seq + (mapl #'(lambda (next-lines nlocs) + (let ((next-line (car next-lines)) (next-column (car nlocs))) + (incf i) + (if next-column + (progn (setq next-column (abs next-column)) + (if (< next-column start-column) (exit nil)) + (cond ((and (eq next-column start-column) + (rplaca nlocs (- (car nlocs))) + (not (infixtok next-line))) + (setq next-lines (drop (1- i) slines)) + (rplaca next-lines (addclose (car next-lines) #\;)) + (setq count (1+ count)))))))) + (cdr slines) (cdr slocs))) + (if (> count 0) + (progn (setf (char (car slines) (1- (nonblankloc (car slines)))) + #\( ) + (setq slines (drop (1- i) slines)) + (rplaca slines (addclose (car slines) #\) )))))))) + +(defun INFIXTOK (S) (MEMBER (STRING2ID-N S 1) '(|then| |else|) :test #'eq)) + + +(defun ADDCLOSE (LINE CHAR) + (cond ((char= (FETCHCHAR LINE (MAXINDEX LINE)) #\; ) + (SETELT LINE (MAXINDEX LINE) CHAR) + (if (char= CHAR #\;) LINE (suffix #\; LINE))) + ((suffix char LINE)))) diff --git a/src/interp/preparse.lisp.pamphlet b/src/interp/preparse.lisp.pamphlet deleted file mode 100644 index 55eb34d9..00000000 --- a/src/interp/preparse.lisp.pamphlet +++ /dev/null @@ -1,420 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp preparse.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{verbatim} -NAME: Pre-Parsing Code -PURPOSE: BOOT lines are massaged by PREPARSE to make them easier to parse: - 1. Trailing -- comments are removed (this is already done, actually). - 2. Comments between { and } are removed. - 3. BOOT code is column-sensitive. Code which lines up columnarly is - parenthesized and semicolonized accordingly. For example, - - a - b - c - d - e - - becomes - - a - (b; - c - d) - e - - Note that to do this correctly, we also need to keep track of - parentheses already in the code. - -\end{verbatim} -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -(IMPORT-MODULE "fnewmeta") - -(in-package "BOOT") - -; Global storage - -(defparameter $INDEX 0 "File line number of most recently read line.") -(defparameter $preparse-last-line () "Most recently read line.") -(defparameter $preparseReportIfTrue NIL "Should we print listings?") -(defparameter $LineList nil "Stack of preparsed lines.") -(defparameter $EchoLineStack nil "Stack of lines to list.") -(defparameter $IOIndex 0 "Number of latest terminal input line.") - -(defun Initialize-Preparse (strm) - (setq $INDEX 0 $LineList nil $EchoLineStack nil) - (setq $preparse-last-line (get-a-line strm))) - -(defmacro pptest () `(/rp ">scratchpad>test.boot")) - -(defun /RP (&optional (*boot-input-file* nil) (*boot-output-file* nil) - ($preparseReportIfTrue t)) - (with-open-stream - (in-stream (or (and *boot-input-file* (open *boot-input-file* :direction :input)) - *terminal-io*)) - (declare (special in-stream)) - (with-open-stream - (out-stream (if *boot-output-file* - (open *boot-output-file* :direction :output) - *terminal-io*)) - (declare (special out-stream)) - (initialize-preparse in-stream) - (do ((lines (PREPARSE in-stream) (PREPARSE in-stream))) ((null lines))))) - T) - - -(defvar $skipme) -(defvar $COMBLOCKLIST) - -(defun PREPARSE (Strm &aux (stack ())) - (SETQ $COMBLOCKLIST NIL $skipme NIL) - (when $preparse-last-line - (if (pairp $preparse-last-line) - (setq stack $preparse-last-line) - (push $preparse-last-line stack)) - (setq $INDEX (- $INDEX (length stack)))) - (let ((U (PREPARSE1 stack))) - (if $skipme (preparse strm) - (progn - (if $preparseReportIfTrue (PARSEPRINT U)) - (setq |$headerDocumentation| NIL) - (SETQ |$docList| NIL) - (SETQ |$maxSignatureLineNumber| 0) - (SETQ |$constructorLineNumber| (IFCAR (IFCAR U))) - U)))) - -(defun PREPARSE1 (LineList) - (PROG (($LINELIST LineList) $EchoLineStack NUM A I L PSLOC - INSTRING PCOUNT COMSYM STRSYM OPARSYM CPARSYM N NCOMSYM - (SLOC -1) (CONTINUE NIL) (PARENLEV 0) (NCOMBLOCK ()) - (LINES ()) (LOCS ()) (NUMS ()) functor ) - READLOOP (DCQ (NUM . A) (preparseReadLine LineList)) - (cond ((atEndOfUnit A) - (PREPARSE-ECHO LineList) - (COND ((NULL LINES) (RETURN NIL)) - (NCOMBLOCK - (FINCOMBLOCK NIL NUMS LOCS NCOMBLOCK NIL))) - (RETURN (PAIR (NREVERSE NUMS) - (PARSEPILES (NREVERSE LOCS) (NREVERSE LINES)))))) - (cond ((and (NULL LINES) (> (LENGTH A) 0) (EQ (CHAR A 0) #\) )) - ; this is a command line, don't parse it - (PREPARSE-ECHO LineList) - (setq $preparse-last-line nil) ;don't reread this line - (SETQ LINE a) - (CATCH 'SPAD_READER (|doSystemCommand| (subseq LINE 1))) - (GO READLOOP))) - (setq L (LENGTH A)) - (if (EQ L 0) (GO READLOOP)) - (setq PSLOC SLOC) - (setq I 0 INSTRING () PCOUNT 0) - STRLOOP (setq STRSYM (OR (position #\" A :start I ) L)) - (setq COMSYM (OR (search "--" A :start2 I ) L)) - (setq NCOMSYM (OR (search "++" A :start2 I ) L)) - (setq OPARSYM (OR (position #\( A :start I ) L)) - (setq CPARSYM (OR (position #\) A :start I ) L)) - (setq N (MIN STRSYM COMSYM NCOMSYM OPARSYM CPARSYM)) - (cond ((= N L) (GO NOCOMS)) - ((ESCAPED A N)) - ((= N STRSYM) (setq INSTRING (NOT INSTRING))) - (INSTRING) - ((= N COMSYM) (setq A (subseq A 0 N)) (GO NOCOMS)) ; discard trailing comment - ((= N NCOMSYM) - (setq SLOC (INDENT-POS A)) - (COND - ((= SLOC N) - (COND ((AND NCOMBLOCK (NOT (= N (CAR NCOMBLOCK)))) - (FINCOMBLOCK NUM NUMS LOCS NCOMBLOCK linelist) - (SETQ NCOMBLOCK NIL))) - (SETQ NCOMBLOCK (CONS N (CONS A (IFCDR NCOMBLOCK)))) - (SETQ A "")) - ('T (PUSH (STRCONC (GETFULLSTR N " ") - (SUBSTRING A N ())) $LINELIST) - (SETQ $INDEX (SUB1 $INDEX)) - (SETQ A (SUBSEQ A 0 N)))) - (GO NOCOMS)) - ((= N OPARSYM) (setq PCOUNT (1+ PCOUNT))) - ((= N CPARSYM) (setq PCOUNT (1- PCOUNT)))) - (setq I (1+ N)) - (GO STRLOOP) - NOCOMS (setq SLOC (INDENT-POS A)) - (setq A (DROPTRAILINGBLANKS A)) - (cond ((NULL SLOC) (setq SLOC PSLOC) (GO READLOOP))) - (cond ((EQ (ELT A (MAXINDEX A)) XCAPE) - (setq CONTINUE T a (subseq A (MAXINDEX A)))) - ((setq CONTINUE NIL))) - (if (and (null LINES) (= SLOC 0)) ;;test for skipping constructors - (if (and |$byConstructors| - (null (search "==>" a)) - (not (member (setq functor (intern - (substring a 0 (STRPOSL ": (=" A 0 NIL)))) - |$byConstructors|))) - (setq $skipme 't) - (progn (push functor |$constructorsSeen|) (setq $skipme nil)))) - (when (and LINES (EQL SLOC 0)) - (IF (AND NCOMBLOCK (NOT (ZEROP (CAR NCOMBLOCK)))) - (FINCOMBLOCK NUM NUMS LOCS NCOMBLOCK linelist)) - (IF (NOT (IS-CONSOLE in-stream)) - (setq $preparse-last-line - (nreverse $echolinestack))) - (RETURN (PAIR (NREVERSE NUMS) - (PARSEPILES (NREVERSE LOCS) (NREVERSE LINES))))) - (cond ((> PARENLEV 0) (PUSH NIL LOCS) (setq SLOC PSLOC) (GO REREAD))) - (COND (NCOMBLOCK - (FINCOMBLOCK NUM NUMS LOCS NCOMBLOCK linelist) - (setq NCOMBLOCK ()))) - (PUSH SLOC LOCS) - REREAD (PREPARSE-ECHO LineList) - (PUSH A LINES) - (PUSH NUM NUMS) - (setq PARENLEV (+ PARENLEV PCOUNT)) - (when (and (is-console in-stream) (not continue)) - (setq $preparse-last-line nil) - (RETURN (PAIR (NREVERSE NUMS) - (PARSEPILES (NREVERSE LOCS) (NREVERSE LINES))))) - - (GO READLOOP))) - -;; NUM is the line number of the current line -;; OLDNUMS is the list of line numbers of previous lines -;; OLDLOCS is the list of previous indentation locations -;; NCBLOCK is the current comment block -(DEFUN FINCOMBLOCK (NUM OLDNUMS OLDLOCS NCBLOCK linelist) - (PUSH - (COND ((EQL (CAR NCBLOCK) 0) (CONS (1- NUM) (REVERSE (CDR NCBLOCK)))) - ;; comment for constructor itself paired with 1st line -1 - ('T - (COND ($EchoLineStack - (setq NUM (POP $EchoLineStack)) - (PREPARSE-ECHO linelist) - (SETQ $EchoLineStack (LIST NUM)))) - (cons - ;; scan backwards for line to left of current - (DO ((onums oldnums (cdr onums)) - (olocs oldlocs (cdr olocs)) - (sloc (car ncblock))) - ((null onums) nil) - (if (and (numberp (car olocs)) - (<= (car olocs) sloc)) - (return (car onums)))) - (REVERSE (CDR NCBLOCK))))) - $COMBLOCKLIST)) - -(defun PARSEPRINT (L) - (if L - (progn (format t "~&~% *** PREPARSE ***~%~%") - (dolist (X L) (format t "~5d. ~a~%" (car x) (cdr x))) - (format t "~%")))) - -(DEFUN STOREBLANKS (LINE N) - (DO ((I 0 (ADD1 I))) ((= I N) LINE) (SETF (CHAR LINE I) #\ ))) - -(DEFUN INITIAL-SUBSTRING (PATTERN LINE) - (let ((ind (mismatch PATTERN LINE))) - (OR (NULL IND) (EQL IND (SIZE PATTERN))))) - -(DEFUN SKIP-IFBLOCK (X) - (PROG (LINE IND) - (DCQ (IND . LINE) (preparseReadLine1 X)) - (IF (NOT (STRINGP LINE)) (RETURN (CONS IND LINE))) - (IF (ZEROP (SIZE LINE)) (RETURN (SKIP-IFBLOCK X))) - (COND ((CHAR= (ELT LINE 0) #\) ) - (COND - ((INITIAL-SUBSTRING ")if" LINE) - (COND ((EVAL (|string2BootTree| (STOREBLANKS LINE 3))) - (RETURN (preparseReadLine X))) - ('T (RETURN (SKIP-IFBLOCK X))))) - ((INITIAL-SUBSTRING ")elseif" LINE) - (COND ((EVAL (|string2BootTree| (STOREBLANKS LINE 7))) - (RETURN (preparseReadLine X))) - ('T (RETURN (SKIP-IFBLOCK X))))) - ((INITIAL-SUBSTRING ")else" LINE) - (RETURN (preparseReadLine X))) - ((INITIAL-SUBSTRING ")endif" LINE) - (RETURN (preparseReadLine X))) - ((INITIAL-SUBSTRING ")fin" LINE) - (RETURN (CONS IND NIL)))))) - (RETURN (SKIP-IFBLOCK X)) ) ) - -(DEFUN SKIP-TO-ENDIF (X) - (PROG (LINE IND) - (DCQ (IND . LINE) (preparseReadLine1 X)) - (COND ((NOT (STRINGP LINE)) (RETURN (CONS IND LINE))) - ((INITIAL-SUBSTRING LINE ")endif") - (RETURN (preparseReadLine X))) - ((INITIAL-SUBSTRING LINE ")fin") (RETURN (CONS IND NIL))) - ('T (RETURN (SKIP-TO-ENDIF X)))))) - -(DEFUN preparseReadLine (X) - (PROG (LINE IND) - (DCQ (IND . LINE) (preparseReadLine1 X)) - (COND ((NOT (STRINGP LINE)) (RETURN (CONS IND LINE)))) - (COND ((ZEROP (SIZE LINE)) - (RETURN (CONS IND LINE)))) - (COND ((CHAR= (ELT LINE 0) #\) ) - (COND - ((INITIAL-SUBSTRING ")if" LINE) - (COND ((EVAL (|string2BootTree| (STOREBLANKS LINE 3))) - (RETURN (preparseReadLine X))) - ('T (RETURN (SKIP-IFBLOCK X))))) - ((INITIAL-SUBSTRING ")elseif" LINE) - (RETURN (SKIP-TO-ENDIF X))) - ((INITIAL-SUBSTRING ")else" LINE) - (RETURN (SKIP-TO-ENDIF X))) - ((INITIAL-SUBSTRING ")endif" LINE) - (RETURN (preparseReadLine X))) - ((INITIAL-SUBSTRING ")fin" LINE) - (SETQ *EOF* T) - (RETURN (CONS IND NIL)) ) ))) - (RETURN (CONS IND LINE)) )) - -(DEFUN preparseReadLine1 (X) - (PROG (LINE IND) - (SETQ LINE (if $LINELIST - (pop $LINELIST) - (expand-tabs (get-a-line in-stream)))) - (setq $preparse-last-line LINE) - (and (stringp line) (incf $INDEX)) - (COND - ( (NOT (STRINGP LINE)) - (RETURN (CONS $INDEX LINE)) ) ) - (SETQ LINE (DROPTRAILINGBLANKS LINE)) - (PUSH (COPY-SEQ LINE) $EchoLineStack) - ;; next line must evaluate $INDEX before recursive call - (RETURN - (CONS - $INDEX - (COND - ( (AND (> (SETQ IND (MAXINDEX LINE)) -1) (char= (ELT LINE IND) #\_)) - (setq $preparse-last-line - (STRCONC (SUBSTRING LINE 0 IND) (CDR (preparseReadLine1 X))) )) - ( 'T - LINE ) ))) ) ) - -;;(defun preparseReadLine (X) -;; (declare (special $LINELIST $echoLineStack)) -;; (PROG (LINE IND) -;; (setq LINE -;; (if $LINELIST -;; (pop $LINELIST) -;; (get-a-line in-stream))) -;; (setq $preparse-last-line LINE) -;; (and (stringp line) (incf $INDEX)) -;; (if (NOT (STRINGP LINE)) (RETURN (CONS $INDEX LINE))) -;; (setq LINE (DROPTRAILINGBLANKS LINE)) -;; (if Echo-Meta (PUSH (COPY-SEQ LINE) $EchoLineStack)) -;; ; next line must evaluate $INDEX before recursive call -;; (RETURN -;; (CONS $INDEX -;; (if (and (> (setq IND (MAXINDEX LINE)) -1) -;; (EQ (ELT LINE IND) #\_)) -;; (setq $preparse-last-line -;; (STRCONC (SUBSEQ LINE 0 IND) -;; (CDR (preparseReadLine X)))) -;; LINE))))) - -(defun PREPARSE-ECHO (linelist) - (if Echo-Meta (REPEAT (IN X (REVERSE $EchoLineStack)) - (format out-stream "~&;~A~%" X))) - (setq $EchoLineStack ())) - -(defun ESCAPED (STR N) (and (> N 0) (EQ (CHAR STR (1- N)) XCAPE))) - -(defun atEndOfUnit (X) (NULL (STRINGP X)) ) - -(defun PARSEPILES (LOCS LINES) - "Add parens and semis to lines to aid parsing." - (mapl #'add-parens-and-semis-to-line (NCONC LINES '(" ")) (nconc locs '(nil))) - LINES) - -(defun add-parens-and-semis-to-line (slines slocs) - - "The line to be worked on is (CAR SLINES). It's indentation is (CAR SLOCS). There -is a notion of current indentation. Then: - -A. Add open paren to beginning of following line if following line's indentation - is greater than current, and add close paren to end of last succeeding line - with following line's indentation. -B. Add semicolon to end of line if following line's indentation is the same. -C. If the entire line consists of the single keyword then or else, leave it alone." - - (let ((start-column (car slocs))) - (if (and start-column (> start-column 0)) - (let ((count 0) (i 0)) - (seq - (mapl #'(lambda (next-lines nlocs) - (let ((next-line (car next-lines)) (next-column (car nlocs))) - (incf i) - (if next-column - (progn (setq next-column (abs next-column)) - (if (< next-column start-column) (exit nil)) - (cond ((and (eq next-column start-column) - (rplaca nlocs (- (car nlocs))) - (not (infixtok next-line))) - (setq next-lines (drop (1- i) slines)) - (rplaca next-lines (addclose (car next-lines) #\;)) - (setq count (1+ count)))))))) - (cdr slines) (cdr slocs))) - (if (> count 0) - (progn (setf (char (car slines) (1- (nonblankloc (car slines)))) - #\( ) - (setq slines (drop (1- i) slines)) - (rplaca slines (addclose (car slines) #\) )))))))) - -(defun INFIXTOK (S) (MEMBER (STRING2ID-N S 1) '(|then| |else|) :test #'eq)) - - -(defun ADDCLOSE (LINE CHAR) - (cond ((char= (FETCHCHAR LINE (MAXINDEX LINE)) #\; ) - (SETELT LINE (MAXINDEX LINE) CHAR) - (if (char= CHAR #\;) LINE (suffix #\; LINE))) - ((suffix char LINE)))) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/property.lisp b/src/interp/property.lisp new file mode 100644 index 00000000..08cd1b57 --- /dev/null +++ b/src/interp/property.lisp @@ -0,0 +1,603 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + +;; This file contains most of the code that puts properties on +;; identifiers in the Scratchpad II system. If it was not possible +;; to actually put the code here, we have pointers to where such +;; property list manipulation is being done. + +;; Pointers: +;; o see NEWAUX LISP for some code that puts GENERIC and RENAMETOK +;; properties on identifiers for the parser +;; o coerceIntCommute puts the "commute" property on constructors. +;; o coerceRetract puts the "retract" property on constructors. +;; o there is some code at the end of SPECEVAL BOOT that puts "up" +;; properties on some special handlers. + + + +(in-package "BOOT") + +;; following was in NEWSPAD LISP + +(MAKEPROP 'END_UNIT 'KEY 'T) + +;; following was in OUTINIT LISP + +(MAKEPROP 'TAG 'Led '(TAG TAG 122 121)) +(MAKEPROP 'EQUATNUM '|Nud| '(|dummy| |dummy| 0 0)) +(MAKEPROP 'EQUATNUM '|Led| '(|dummy| |dummy| 10000 0)) +(MAKEPROP 'LET '|Led| '(|:=| LET 125 124)) +(MAKEPROP 'RARROW '|Led| '(== DEF 122 121)) +(MAKEPROP 'SEGMENT '|Led| '(|..| SEGMENT 401 699 (|P:Seg|))) +(MAKEPROP 'SEGMENT '|isSuffix| 'T) +(MAKEPROP 'EQUAL1 'CHRYBNAM 'EQ) + +(REPEAT (IN X '( + (LET " := ") + (= "=") + (|/| "/") + (+ "+") + (* "*") + (** "**") + (^ "^") + (|:| ":") + (|::| "::") + (|@| "@") + (SEL ".") + (|exquo| " exquo ") + (|div| " div ") + (|quo| " quo ") + (|rem| " rem ") + (|case| " case ") + (|and| " and ") + (|or| " or ") + (TAG " -> ") + (|+->| " +-> ") + (RARROW ": ") + (SEGMENT "..") + (in " in ") + (|^=| "^=") + (EL* ":") + (JOIN " JOIN ") + (EQUATNUM " ") + (IQUOTIENT "//") + (= "= ") + (|>=| " >= ") + (|>| " > ") + (|<=| " <= ") + (|<| " < ") + (\| " \| ") + (+ " + ") + (- " - ") + (MEMBER " in ") + (NMEMBER " nin ") + (WHERE " WHERE ") + (AT " AT ") + (MAX " MAX ") + (MIN " MIN ") + )) (MAKEPROP (CAR X) 'INFIXOP (CADR X))) + +(REPEAT (IN X '( + (= "=") + (|:| ":") + (|not| "^ ") + (\| " \| ") + (SEGMENT "..") ;" 0.. is represented by (SEGMENT 0)" + )) (MAKEPROP (CAR X) 'PREFIXOP (CADR X))) + +(REPEAT (IN X '( + (+ WIDTH |sumWidth|) + (- APP |appneg|) + (- WIDTH |minusWidth|) + (/ APP |appfrac|) + (/ SUBSPAN |fracsub|) + (/ SUPERSPAN |fracsuper|) + (/ WIDTH |fracwidth|) + (AGGSET APP |argsapp|) + (AGGSET SUBSPAN |agggsub|) + (AGGSET SUPERSPAN |agggsuper|) + (AGGSET WIDTH |agggwidth|) + (|binom| APP |binomApp|) + (|binom| SUBSPAN |binomSub|) + (|binom| SUPERSPAN |binomSuper|) + (|binom| WIDTH |binomWidth|) + (ALTSUPERSUB APP |altSuperSubApp|) + (ALTSUPERSUB SUBSPAN |altSuperSubSub|) + (ALTSUPERSUB SUPERSPAN |altSuperSubSuper|) + (ALTSUPERSUB WIDTH |altSuperSubWidth|) + (BOX APP |boxApp|) + (BOX SUBSPAN |boxSub|) + (BOX SUPERSPAN |boxSuper|) + (BOX WIDTH |boxWidth|) + (BRACKET SUBSPAN |qTSub|) + (BRACKET SUPERSPAN |qTSuper|) + (BRACKET WIDTH |qTWidth|) + (CENTER APP |centerApp|) + (EXT APP |appext|) + (EXT SUBSPAN |extsub|) + (EXT SUPERSPAN |extsuper|) + (EXT WIDTH |extwidth|) + (MATRIX APP |appmat|) + (MATRIX SUBSPAN |matSub|) + (MATRIX SUPERSPAN |matSuper|) + (MATRIX WIDTH |matWidth|) + (NOTHING APP |nothingApp|) + (NOTHING SUPERSPAN |nothingSuper|) + (NOTHING SUBSPAN |nothingSub|) + (NOTHING WIDTH |nothingWidth|) + (OVER APP |appfrac|) + (OVER SUBSPAN |fracsub|) + (OVER SUPERSPAN |fracsuper|) + (OVER WIDTH |fracwidth|) + (OVERLABEL APP |overlabelApp|) + (OVERLABEL SUPERSPAN |overlabelSuper|) + (OVERLABEL WIDTH |overlabelWidth|) + (OVERBAR APP |overbarApp|) + (OVERBAR SUPERSPAN |overbarSuper|) + (OVERBAR WIDTH |overbarWidth|) + (PAREN APP |appparu1|) + (PAREN SUBSPAN |qTSub|) + (PAREN SUPERSPAN |qTSuper|) + (PAREN WIDTH |qTWidth|) + (ROOT APP |rootApp|) + (ROOT SUBSPAN |rootSub|) + (ROOT SUPERSPAN |rootSuper|) + (ROOT WIDTH |rootWidth|) + (ROW WIDTH |eq0|) + (SC APP |appsc|) + (SC SUBSPAN |agggsub|) + (SC SUPERSPAN |agggsuper|) + (SC WIDTH |widthSC|) + (SETQ APP |appsetq|) + (SETQ WIDTH |letWidth|) + (SLASH APP |slashApp|) + (SLASH SUBSPAN |slashSub|) + (SLASH SUPERSPAN |slashSuper|) + (SLASH WIDTH |slashWidth|) + (SUB APP |appsub|) + (SUB SUBSPAN |subSub|) + (SUB SUPERSPAN |subSuper|) + (SUB WIDTH |suScWidth|) + (SUPERSUB APP |superSubApp|) + (SUPERSUB SUBSPAN |superSubSub|) + (SUPERSUB SUPERSPAN |superSubSuper|) + (SUPERSUB WIDTH |superSubWidth|) + (VCONCAT APP |vconcatapp|) + (VCONCAT SUBSPAN |vConcatSub|) + (VCONCAT SUPERSPAN |vConcatSuper|) + (VCONCAT WIDTH |vConcatWidth|) + (BINOMIAL APP |binomialApp|) + (BINOMIAL SUBSPAN |binomialSub|) + (BINOMIAL SUPERSPAN |binomialSuper|) + (BINOMIAL WIDTH |binomialWidth|) + (ZAG APP |zagApp|) + (ZAG SUBSPAN |zagSub|) + (ZAG SUPERSPAN |zagSuper|) + (ZAG WIDTH |zagWidth|) +)) (PROGN (MAKEPROP (CAR X) (CADR X) (CADDR X))) +) + +(REPEAT (IN X '( + (+ APP |plusApp|) + (* APP |timesApp|) + (* WIDTH |timesWidth|) + (** APP |exptApp|) + (** WIDTH |exptWidth|) + (** SUBSPAN |exptSub|) + (** SUPERSPAN |exptSuper|) + (^ APP |exptApp|) + (^ WIDTH |exptWidth|) + (^ SUBSPAN |exptSub|) + (^ SUPERSPAN |exptSuper|) + (STEP APP |stepApp|) + (STEP WIDTH |stepWidth|) + (STEP SUBSPAN |stepSub|) + (STEP SUPERSPAN |stepSuper|) + (IN APP |inApp|) + (IN WIDTH |inWidth|) + (IN SUBSPAN |inSub|) + (IN SUPERSPAN |inSuper|) + (AGGLST APP |aggApp|) + (AGGLST SUBSPAN |aggSub|) + (AGGLST SUPERSPAN |aggSuper|) + (CONCATB APP |concatbApp|) + (CONCATB SUBSPAN |concatSub|) + (CONCATB SUPERSPAN |concatSuper|) + (CONCATB WIDTH |concatbWidth|) + (CONCAT APP |concatApp|) + (CONCAT SUBSPAN |concatSub|) + (CONCAT SUPERSPAN |concatSuper|) + (CONCAT WIDTH |concatWidth|) + (QUOTE APP |quoteApp|) + (QUOTE SUBSPAN |quoteSub|) + (QUOTE SUPERSPAN |quoteSuper|) + (QUOTE WIDTH |quoteWidth|) + (STRING APP |stringApp|) + (STRING SUBSPAN |eq0|) + (STRING SUPERSPAN |eq0|) + (STRING WIDTH |stringWidth|) + (SIGMA APP |sigmaApp|) + (SIGMA SUBSPAN |sigmaSub|) + (SIGMA SUPERSPAN |sigmaSup|) + (SIGMA WIDTH |sigmaWidth|) + (SIGMA2 APP |sigma2App|) + (SIGMA2 SUBSPAN |sigma2Sub|) + (SIGMA2 SUPERSPAN |sigma2Sup|) + (SIGMA2 WIDTH |sigma2Width|) + (INTSIGN APP |intApp|) + (INTSIGN SUBSPAN |intSub|) + (INTSIGN SUPERSPAN |intSup|) + (INTSIGN WIDTH |intWidth|) + (INDEFINTEGRAL APP |indefIntegralApp|) + (INDEFINTEGRAL SUBSPAN |indefIntegralSub|) + (INDEFINTEGRAL SUPERSPAN |indefIntegralSup|) + (INDEFINTEGRAL WIDTH |indefIntegralWidth|) + (PI APP |piApp|) + (PI SUBSPAN |piSub|) + (PI SUPERSPAN |piSup|) + (PI WIDTH |piWidth|) + (PI2 APP |pi2App|) + (PI2 SUBSPAN |pi2Sub|) + (PI2 SUPERSPAN |pi2Sup|) + (PI2 WIDTH |pi2Width|) + (AGGLST WIDTH |aggWidth|) + (BRACKET APP |bracketApp|) + (BRACE APP |braceApp|) + (BRACE WIDTH |qTWidth|) +)) (PROGN (MAKEPROP (CAR X) (CADR X) (CADDR X))) +) + +;; from DEF LISP + +(REPEAT (IN X '( + (|:| |DEF-:|) + (|::| |DEF-::|) + (ELT DEF-ELT) + (SETELT DEF-SETELT) + (LET DEF-LET) + (COLLECT DEF-COLLECT) + (LESSP DEF-LESSP) + (|<| DEF-LESSP) + (REPEAT DEF-REPEAT) +;;(|TRACE,LET| DEF-TRACE-LET) + (CATEGORY DEF-CATEGORY) + (EQUAL DEF-EQUAL) + (|is| DEF-IS) + (SEQ DEF-SEQ) + (|isnt| DEF-ISNT) + (|where| DEF-WHERE) +)) (PROGN (MAKEPROP (CAR X) '|DEF-TRAN| (CADR X)) (CREATE-SBC (CADR X)))) + +;; following was in INIT LISP + +(REPEAT (IN X '( + |Polynomial| |UnivariatePoly| |SquareMatrix| |QuotientField| + )) (MAKEPROP X '|status| + (CREATE-SBC (INTERNL (STRCONC "status" (STRINGIMAGE X))) ))) + +(REPEAT (IN X '( + |UnivariatePoly| |Matrix| |QuotientField| |Gaussian| + )) (MAKEPROP X '|dataCoerce| + (CREATE-SBC (INTERNL (STRCONC "coerce" (STRINGIMAGE X))) ))) + +(REPEAT (IN X '( + (|Integer| . (INTEGERP |#1|)) + ;; (|Float| . (FLOATP |#1|)) + (|DoubleFloat| . (FLOATP |#1|)) + ;; (|Symbol| . (IDENTP |#1|)) + ;;(|Boolean| . (BOOLEANP |#1|)) worthless predicate is always true + (|String| . (STRINGP |#1|)) + (|PrimitiveSymbol| . (IDENTP |#1|)) + )) (MAKEPROP (CAR X) '|BasicPredicate| (CDR X))) + +(MAKEPROP '|Integer| '|Subsets| + '((|PositiveInteger| . (|>| * 0)) + (|NonNegativeInteger| . (|>=| * 0)) + (|NegativeInteger| . (|<| * 0)) + (|NonPositiveInteger| . (|<=| * 0)) + (|NonZeroInteger| . (^= * 0)) + (|SingleInteger| . (SMINTP *)) + )) + +(MAKEPROP '|NonNegativeInteger| '|Subsets| '( + (|PositiveInteger| . (|>| * 0)) + )) + +(MAKEPROP '|NonPositiveInteger| '|Subsets| '( + (|NegativeInteger| . (|<| * 0)) + )) + +(FLAG '(|Union| |Record| |Enumration| |Mapping| |Enumeration|) 'FUNCTOR) + +(FLAG '(* + AND OR PROGN) 'NARY) + +(REPEAT (IN X '( + (|Record| |mkRecordFunList|) + (|Union| |mkUnionFunList|) + (|Mapping| |mkMappingFunList|) + (|Enumeration| |mkEnumerationFunList|) +)) (MAKEPROP (CAR X) '|makeFunctionList| (CREATE-SBC (CADR X)))) + +(REPEAT (IN X '( + (|<=| |parseLessEqual|) + (|>| |parseGreaterThan|) + (|>=| |parseGreaterEqual|) + (|$<=| |parseDollarLessEqual|) + (|$>| |parseDollarGreaterThan|) + (|$>=| |parseDollarGreaterEqual|) + ($^= |parseDollarNotEqual|) + (^ |parseNot|) + (^= |parseNotEqual|) + (\: |parseColon|) + (|::| |parseCoerce|) + (@ |parseAtSign|) +;; These two lines were commented out in the original sources. +;; However both of these lines involved control characters that +;; latex cannot handle. control-V and control-H should be the +;; actual control characters, not the text replacement shown here. +;; ;;(control-V |parseUpArrow|) +;; ;;(|control-H| |parseLeftArrow|) + (|and| |parseAnd|) + (CATEGORY |parseCategory|) + (|construct| |parseConstruct|) + (DEF |parseDEF|) + (|eqv| |parseEquivalence|) + (|exit| |parseExit|) + (|has| |parseHas|) + (IF |parseIf|) + (|implies| |parseImplies|) + (IN |parseIn|) + (INBY |parseInBy|) + (|is| |parseIs|) + (|isnt| |parseIsnt|) + (|Join| |parseJoin|) + (|leave| |parseLeave|) + (LET |parseLET|) + (LETD |parseLETD|) + (MDEF |parseMDEF|) + (|not| |parseNot|) + (|or| |parseOr|) + (|pretend| |parsePretend|) + (|return| |parseReturn|) + (SEGMENT |parseSegment|) + (SEQ |parseSeq|) + (VCONS |parseVCONS|) + (|where| |parseWhere|) +;; (|xor| |parseExclusiveOr|) +)) (MAKEPROP (CAR X) '|parseTran| (CADR X))) + +(REPEAT (IN X '( + (|with| |postWith|) + (|Scripts| |postScripts|) + (/ |postSlash|) + (|construct| |postConstruct|) + (|Block| |postBlock|) + (QUOTE |postQUOTE|) + (COLLECT |postCollect|) + (|:BF:| |postBigFloat|) + (|in| |postin|) ;" the infix operator version of in" + (IN |postIn|) ;" the iterator form of in" + (REPEAT |postRepeat|) + (|TupleCollect| |postTupleCollect|) + (|add| |postAdd|) + (|Reduce| |postReduce|) + (\, |postComma|) + (\; |postSemiColon|) + (|where| |postWhere|) + (|::| |postColonColon|) + (\: |postColon|) + (@ |postAtSign|) + (|pretend| |postPretend|) + (|if| |postIf|) + (|Join| |postJoin|) + (|Signature| |postSignature|) + (CATEGORY |postCategory|) +;;( |postDef|) + (== |postDef|) + (|==>| |postMDef|) + (|->| |postMapping|) + (|=>| |postExit|) + (|Tuple| |postTuple|) +)) (MAKEPROP (CAR X) '|postTran| (CADR X))) + +(MAKEPROP 'INTEGER 'ISFUNCTION 'FIXP) +(MAKEPROP '|Integer| '|isFunction| '|IsInteger|) +(MAKEPROP '|Boolean| '|isFunction| '|isBoolean|) + +;; Many of the following are now in COMPAT LISP +(REPEAT (IN X '( + (+ PLUS) + (|and| AND) + (|append| APPEND) + (|apply| APPLY) + (|atom| ATOM) + (|brace| REMDUP) + (|car| CAR) + (|cdr| CDR) + (|cons| CONS) + (|copy| COPY) + (|croak| CROAK) + (|drop| DROP) + (|exit| EXIT) + (|false| NIL) + (|first| CAR) + (|genvar| GENVAR) + (|in| |member|) + (|is| IS) + (|lastNode| LASTNODE) + (|list| LIST) + (|mkpf| MKPF) + (|nconc| NCONC) + (|nil| NIL) + (|not| NULL) + (|NOT| NULL) + (|nreverse| NREVERSE) + (|null| NULL) + (|or| OR) + (|otherwise| 'T) + (|removeDuplicates| REMDUP) + (|rest| CDR) + (|return| RETURN) + (|reverse| REVERSE) + (|setDifference| SETDIFFERENCE) + (|setIntersection| |intersection|) + (|setPart| SETELT) + (|setUnion| |union|) + (|size| SIZE) + (|strconc| STRCONC) + (|substitute| MSUBST) + (SUBST MSUBST) + (|take| TAKE) + (|true| 'T) + (|where| WHERE) + (* TIMES) + (** EXPT) + (^ NULL) + (^= NEQUAL) + (- SPADDIFFERENCE) + (/ QUOTIENT) + (= EQUAL) + (ASSOC |assoc|) + (DELETE |delete|) + (GET GETL) + (INTERSECTION |intersection|) + (LAST |last|) + (MEMBER |member|) + (RASSOC |rassoc|) + (READ VMREAD) + (READ-LINE |read-line|) + (REDUCE SPADREDUCE) + (REMOVE |remove|) + (\| SUCHTHAT) + (T T$) + (UNION |union|) +)) (MAKEPROP (CAR X) 'RENAME (CDR X))) + +;; these are accessor names for fields in data structures. Thus one would +;; write datastructure.setName +(REPEAT (IN X '( + (|setName| 0) + (|setLabel| 1) + (|setLevel| 2) + (|setType| 3) + (|setVar| 4) + (|setLeaf| 5) + (|setDef| 6) + (|aGeneral| 4) + (|aMode| 1) + (|aModeSet| 3) + (|aTree| 0) + (|attributes| CADDR) + (|aValue| 2) + (|cacheCount| CADDDDR) + (|cacheName| CADR) + (|cacheReset| CADDDR) + (|cacheType| CADDR) + (|env| CADDR) + (|expr| CAR) + (|first| CAR) + (|mmCondition| CAADR) + (|mmDC| CAAR) + (|mmImplementation| CADADR) + (|mmSignature| CDAR) + (|mmTarget| CADAR) + (|mode| CADR) + (|op| CAR) + (|opcode| CADR) + (|opSig| CADR) + (|rest| CDR) + (|sig| CDDR) + (|source| CDR) + (|streamCode| CADDDR) + (|streamDef| CADDR) + (|streamName| CADR) + (|target| CAR) +)) (MAKEPROP (CAR X) '|SEL,FUNCTION| (CADR X))) + +(REPEAT (IN X '( + (\| |compSuchthat|) + (\@ |compAtSign|) + (|:| |compColon|) + (\:\: |compCoerce|) + (QUOTE |compQuote|) +;; We have a similar problem with the control-G character. +;; ;; (control-G |compContained|) + + (|add| |compAdd|) + (CAPSULE |compCapsule|) + (|case| |compCase|) + (CATEGORY |compCategory|) + (COLLECT |compRepeatOrCollect|) + (COLLECTV |compCollectV|) + (CONS |compCons|) + (|construct| |compConstruct|) + (DEF |compDefine|) + (|elt| |compElt|) + (|exit| |compExit|) + (|has| |compHas|) + (IF |compIf|) + (|import| |compImport|) + (|is| |compIs|) + (|Join| |compJoin|) + (|leave| |compLeave|) + (LET |compSetq|) + (|ListCategory| |compConstructorCategory|) + (MDEF |compMacro|) + (|pretend| |compPretend|) + (|Record| |compCat|) + (|RecordCategory| |compConstructorCategory|) + (REDUCE |compReduce|) + (REPEAT |compRepeatOrCollect|) + (|return| |compReturn|) + (SEQ |compSeq|) + (SETQ |compSetq|) + (|String| |compString|) + (|SubDomain| |compSubDomain|) + (|SubsetCategory| |compSubsetCategory|) + (|Union| |compCat|) + (|Mapping| |compCat|) + (|UnionCategory| |compConstructorCategory|) + (VECTOR |compVector|) + (|VectorCategory| |compConstructorCategory|) + (|where| |compWhere|) +)) (MAKEPROP (CAR X) 'SPECIAL (CREATE-SBC (CADR X)))) + +(REPEAT (IN X '( + (\: |compColonInteractive|) + (DEF |compDefineInteractive|) + (|construct| |compConstructInteractive|) + (LET |compSetqInteractive|) +)) (MAKEPROP (CAR X) 'INTERACTIVE (CREATE-SBC (CADR X)))) + diff --git a/src/interp/property.lisp.pamphlet b/src/interp/property.lisp.pamphlet deleted file mode 100644 index d79d44d3..00000000 --- a/src/interp/property.lisp.pamphlet +++ /dev/null @@ -1,639 +0,0 @@ -%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/property.lisp} Pamphlet} -\author{Timothy Daly} - -\begin{document} -\maketitle - -\begin{abstract} -\end{abstract} - -\tableofcontents -\eject - -\begin{verbatim} -This file contains most of the code that puts properties on -identifiers in the Scratchpad II system. If it was not possible -to actually put the code here, we have pointers to where such -property list manipulation is being done. - -Pointers: -o see NEWAUX LISP for some code that puts GENERIC and RENAMETOK - properties on identifiers for the parser -o coerceIntCommute puts the "commute" property on constructors. -o coerceRetract puts the "retract" property on constructors. -o there is some code at the end of SPECEVAL BOOT that puts "up" - properties on some special handlers. - -\end{verbatim} - -\section{License} - -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ - -\section{bug fix} - -These two lines were commented out in the original sources. -However both of these lines involved control characters that -latex cannot handle. control-V and control-H should be the -actual control characters, not the text replacement shown here. -;;(control-V |parseUpArrow|) -;;(|control-H| |parseLeftArrow|) -<>= -@ -We have a similar problem with the control-G character. -;; (control-G |compContained|) -<>= -@ - -<<*>>= -<> - -(in-package "BOOT") - -;; following was in NEWSPAD LISP - -(MAKEPROP 'END_UNIT 'KEY 'T) - -;; following was in OUTINIT LISP - -(MAKEPROP 'TAG 'Led '(TAG TAG 122 121)) -(MAKEPROP 'EQUATNUM '|Nud| '(|dummy| |dummy| 0 0)) -(MAKEPROP 'EQUATNUM '|Led| '(|dummy| |dummy| 10000 0)) -(MAKEPROP 'LET '|Led| '(|:=| LET 125 124)) -(MAKEPROP 'RARROW '|Led| '(== DEF 122 121)) -(MAKEPROP 'SEGMENT '|Led| '(|..| SEGMENT 401 699 (|P:Seg|))) -(MAKEPROP 'SEGMENT '|isSuffix| 'T) -(MAKEPROP 'EQUAL1 'CHRYBNAM 'EQ) - -(REPEAT (IN X '( - (LET " := ") - (= "=") - (|/| "/") - (+ "+") - (* "*") - (** "**") - (^ "^") - (|:| ":") - (|::| "::") - (|@| "@") - (SEL ".") - (|exquo| " exquo ") - (|div| " div ") - (|quo| " quo ") - (|rem| " rem ") - (|case| " case ") - (|and| " and ") - (|or| " or ") - (TAG " -> ") - (|+->| " +-> ") - (RARROW ": ") - (SEGMENT "..") - (in " in ") - (|^=| "^=") - (EL* ":") - (JOIN " JOIN ") - (EQUATNUM " ") - (IQUOTIENT "//") - (= "= ") - (|>=| " >= ") - (|>| " > ") - (|<=| " <= ") - (|<| " < ") - (\| " \| ") - (+ " + ") - (- " - ") - (MEMBER " in ") - (NMEMBER " nin ") - (WHERE " WHERE ") - (AT " AT ") - (MAX " MAX ") - (MIN " MIN ") - )) (MAKEPROP (CAR X) 'INFIXOP (CADR X))) - -(REPEAT (IN X '( - (= "=") - (|:| ":") - (|not| "^ ") - (\| " \| ") - (SEGMENT "..") ;" 0.. is represented by (SEGMENT 0)" - )) (MAKEPROP (CAR X) 'PREFIXOP (CADR X))) - -(REPEAT (IN X '( - (+ WIDTH |sumWidth|) - (- APP |appneg|) - (- WIDTH |minusWidth|) - (/ APP |appfrac|) - (/ SUBSPAN |fracsub|) - (/ SUPERSPAN |fracsuper|) - (/ WIDTH |fracwidth|) - (AGGSET APP |argsapp|) - (AGGSET SUBSPAN |agggsub|) - (AGGSET SUPERSPAN |agggsuper|) - (AGGSET WIDTH |agggwidth|) - (|binom| APP |binomApp|) - (|binom| SUBSPAN |binomSub|) - (|binom| SUPERSPAN |binomSuper|) - (|binom| WIDTH |binomWidth|) - (ALTSUPERSUB APP |altSuperSubApp|) - (ALTSUPERSUB SUBSPAN |altSuperSubSub|) - (ALTSUPERSUB SUPERSPAN |altSuperSubSuper|) - (ALTSUPERSUB WIDTH |altSuperSubWidth|) - (BOX APP |boxApp|) - (BOX SUBSPAN |boxSub|) - (BOX SUPERSPAN |boxSuper|) - (BOX WIDTH |boxWidth|) - (BRACKET SUBSPAN |qTSub|) - (BRACKET SUPERSPAN |qTSuper|) - (BRACKET WIDTH |qTWidth|) - (CENTER APP |centerApp|) - (EXT APP |appext|) - (EXT SUBSPAN |extsub|) - (EXT SUPERSPAN |extsuper|) - (EXT WIDTH |extwidth|) - (MATRIX APP |appmat|) - (MATRIX SUBSPAN |matSub|) - (MATRIX SUPERSPAN |matSuper|) - (MATRIX WIDTH |matWidth|) - (NOTHING APP |nothingApp|) - (NOTHING SUPERSPAN |nothingSuper|) - (NOTHING SUBSPAN |nothingSub|) - (NOTHING WIDTH |nothingWidth|) - (OVER APP |appfrac|) - (OVER SUBSPAN |fracsub|) - (OVER SUPERSPAN |fracsuper|) - (OVER WIDTH |fracwidth|) - (OVERLABEL APP |overlabelApp|) - (OVERLABEL SUPERSPAN |overlabelSuper|) - (OVERLABEL WIDTH |overlabelWidth|) - (OVERBAR APP |overbarApp|) - (OVERBAR SUPERSPAN |overbarSuper|) - (OVERBAR WIDTH |overbarWidth|) - (PAREN APP |appparu1|) - (PAREN SUBSPAN |qTSub|) - (PAREN SUPERSPAN |qTSuper|) - (PAREN WIDTH |qTWidth|) - (ROOT APP |rootApp|) - (ROOT SUBSPAN |rootSub|) - (ROOT SUPERSPAN |rootSuper|) - (ROOT WIDTH |rootWidth|) - (ROW WIDTH |eq0|) - (SC APP |appsc|) - (SC SUBSPAN |agggsub|) - (SC SUPERSPAN |agggsuper|) - (SC WIDTH |widthSC|) - (SETQ APP |appsetq|) - (SETQ WIDTH |letWidth|) - (SLASH APP |slashApp|) - (SLASH SUBSPAN |slashSub|) - (SLASH SUPERSPAN |slashSuper|) - (SLASH WIDTH |slashWidth|) - (SUB APP |appsub|) - (SUB SUBSPAN |subSub|) - (SUB SUPERSPAN |subSuper|) - (SUB WIDTH |suScWidth|) - (SUPERSUB APP |superSubApp|) - (SUPERSUB SUBSPAN |superSubSub|) - (SUPERSUB SUPERSPAN |superSubSuper|) - (SUPERSUB WIDTH |superSubWidth|) - (VCONCAT APP |vconcatapp|) - (VCONCAT SUBSPAN |vConcatSub|) - (VCONCAT SUPERSPAN |vConcatSuper|) - (VCONCAT WIDTH |vConcatWidth|) - (BINOMIAL APP |binomialApp|) - (BINOMIAL SUBSPAN |binomialSub|) - (BINOMIAL SUPERSPAN |binomialSuper|) - (BINOMIAL WIDTH |binomialWidth|) - (ZAG APP |zagApp|) - (ZAG SUBSPAN |zagSub|) - (ZAG SUPERSPAN |zagSuper|) - (ZAG WIDTH |zagWidth|) -)) (PROGN (MAKEPROP (CAR X) (CADR X) (CADDR X))) -) - -(REPEAT (IN X '( - (+ APP |plusApp|) - (* APP |timesApp|) - (* WIDTH |timesWidth|) - (** APP |exptApp|) - (** WIDTH |exptWidth|) - (** SUBSPAN |exptSub|) - (** SUPERSPAN |exptSuper|) - (^ APP |exptApp|) - (^ WIDTH |exptWidth|) - (^ SUBSPAN |exptSub|) - (^ SUPERSPAN |exptSuper|) - (STEP APP |stepApp|) - (STEP WIDTH |stepWidth|) - (STEP SUBSPAN |stepSub|) - (STEP SUPERSPAN |stepSuper|) - (IN APP |inApp|) - (IN WIDTH |inWidth|) - (IN SUBSPAN |inSub|) - (IN SUPERSPAN |inSuper|) - (AGGLST APP |aggApp|) - (AGGLST SUBSPAN |aggSub|) - (AGGLST SUPERSPAN |aggSuper|) - (CONCATB APP |concatbApp|) - (CONCATB SUBSPAN |concatSub|) - (CONCATB SUPERSPAN |concatSuper|) - (CONCATB WIDTH |concatbWidth|) - (CONCAT APP |concatApp|) - (CONCAT SUBSPAN |concatSub|) - (CONCAT SUPERSPAN |concatSuper|) - (CONCAT WIDTH |concatWidth|) - (QUOTE APP |quoteApp|) - (QUOTE SUBSPAN |quoteSub|) - (QUOTE SUPERSPAN |quoteSuper|) - (QUOTE WIDTH |quoteWidth|) - (STRING APP |stringApp|) - (STRING SUBSPAN |eq0|) - (STRING SUPERSPAN |eq0|) - (STRING WIDTH |stringWidth|) - (SIGMA APP |sigmaApp|) - (SIGMA SUBSPAN |sigmaSub|) - (SIGMA SUPERSPAN |sigmaSup|) - (SIGMA WIDTH |sigmaWidth|) - (SIGMA2 APP |sigma2App|) - (SIGMA2 SUBSPAN |sigma2Sub|) - (SIGMA2 SUPERSPAN |sigma2Sup|) - (SIGMA2 WIDTH |sigma2Width|) - (INTSIGN APP |intApp|) - (INTSIGN SUBSPAN |intSub|) - (INTSIGN SUPERSPAN |intSup|) - (INTSIGN WIDTH |intWidth|) - (INDEFINTEGRAL APP |indefIntegralApp|) - (INDEFINTEGRAL SUBSPAN |indefIntegralSub|) - (INDEFINTEGRAL SUPERSPAN |indefIntegralSup|) - (INDEFINTEGRAL WIDTH |indefIntegralWidth|) - (PI APP |piApp|) - (PI SUBSPAN |piSub|) - (PI SUPERSPAN |piSup|) - (PI WIDTH |piWidth|) - (PI2 APP |pi2App|) - (PI2 SUBSPAN |pi2Sub|) - (PI2 SUPERSPAN |pi2Sup|) - (PI2 WIDTH |pi2Width|) - (AGGLST WIDTH |aggWidth|) - (BRACKET APP |bracketApp|) - (BRACE APP |braceApp|) - (BRACE WIDTH |qTWidth|) -)) (PROGN (MAKEPROP (CAR X) (CADR X) (CADDR X))) -) - -;; from DEF LISP - -(REPEAT (IN X '( - (|:| |DEF-:|) - (|::| |DEF-::|) - (ELT DEF-ELT) - (SETELT DEF-SETELT) - (LET DEF-LET) - (COLLECT DEF-COLLECT) - (LESSP DEF-LESSP) - (|<| DEF-LESSP) - (REPEAT DEF-REPEAT) -;;(|TRACE,LET| DEF-TRACE-LET) - (CATEGORY DEF-CATEGORY) - (EQUAL DEF-EQUAL) - (|is| DEF-IS) - (SEQ DEF-SEQ) - (|isnt| DEF-ISNT) - (|where| DEF-WHERE) -)) (PROGN (MAKEPROP (CAR X) '|DEF-TRAN| (CADR X)) (CREATE-SBC (CADR X)))) - -;; following was in INIT LISP - -(REPEAT (IN X '( - |Polynomial| |UnivariatePoly| |SquareMatrix| |QuotientField| - )) (MAKEPROP X '|status| - (CREATE-SBC (INTERNL (STRCONC "status" (STRINGIMAGE X))) ))) - -(REPEAT (IN X '( - |UnivariatePoly| |Matrix| |QuotientField| |Gaussian| - )) (MAKEPROP X '|dataCoerce| - (CREATE-SBC (INTERNL (STRCONC "coerce" (STRINGIMAGE X))) ))) - -(REPEAT (IN X '( - (|Integer| . (INTEGERP |#1|)) - ;; (|Float| . (FLOATP |#1|)) - (|DoubleFloat| . (FLOATP |#1|)) - ;; (|Symbol| . (IDENTP |#1|)) - ;;(|Boolean| . (BOOLEANP |#1|)) worthless predicate is always true - (|String| . (STRINGP |#1|)) - (|PrimitiveSymbol| . (IDENTP |#1|)) - )) (MAKEPROP (CAR X) '|BasicPredicate| (CDR X))) - -(MAKEPROP '|Integer| '|Subsets| - '((|PositiveInteger| . (|>| * 0)) - (|NonNegativeInteger| . (|>=| * 0)) - (|NegativeInteger| . (|<| * 0)) - (|NonPositiveInteger| . (|<=| * 0)) - (|NonZeroInteger| . (^= * 0)) - (|SingleInteger| . (SMINTP *)) - )) - -(MAKEPROP '|NonNegativeInteger| '|Subsets| '( - (|PositiveInteger| . (|>| * 0)) - )) - -(MAKEPROP '|NonPositiveInteger| '|Subsets| '( - (|NegativeInteger| . (|<| * 0)) - )) - -(FLAG '(|Union| |Record| |Enumration| |Mapping| |Enumeration|) 'FUNCTOR) - -(FLAG '(* + AND OR PROGN) 'NARY) - -(REPEAT (IN X '( - (|Record| |mkRecordFunList|) - (|Union| |mkUnionFunList|) - (|Mapping| |mkMappingFunList|) - (|Enumeration| |mkEnumerationFunList|) -)) (MAKEPROP (CAR X) '|makeFunctionList| (CREATE-SBC (CADR X)))) - -(REPEAT (IN X '( - (|<=| |parseLessEqual|) - (|>| |parseGreaterThan|) - (|>=| |parseGreaterEqual|) - (|$<=| |parseDollarLessEqual|) - (|$>| |parseDollarGreaterThan|) - (|$>=| |parseDollarGreaterEqual|) - ($^= |parseDollarNotEqual|) - (^ |parseNot|) - (^= |parseNotEqual|) - (\: |parseColon|) - (|::| |parseCoerce|) - (@ |parseAtSign|) -<> - (|and| |parseAnd|) - (CATEGORY |parseCategory|) - (|construct| |parseConstruct|) - (DEF |parseDEF|) - (|eqv| |parseEquivalence|) - (|exit| |parseExit|) - (|has| |parseHas|) - (IF |parseIf|) - (|implies| |parseImplies|) - (IN |parseIn|) - (INBY |parseInBy|) - (|is| |parseIs|) - (|isnt| |parseIsnt|) - (|Join| |parseJoin|) - (|leave| |parseLeave|) - (LET |parseLET|) - (LETD |parseLETD|) - (MDEF |parseMDEF|) - (|not| |parseNot|) - (|or| |parseOr|) - (|pretend| |parsePretend|) - (|return| |parseReturn|) - (SEGMENT |parseSegment|) - (SEQ |parseSeq|) - (VCONS |parseVCONS|) - (|where| |parseWhere|) -;; (|xor| |parseExclusiveOr|) -)) (MAKEPROP (CAR X) '|parseTran| (CADR X))) - -(REPEAT (IN X '( - (|with| |postWith|) - (|Scripts| |postScripts|) - (/ |postSlash|) - (|construct| |postConstruct|) - (|Block| |postBlock|) - (QUOTE |postQUOTE|) - (COLLECT |postCollect|) - (|:BF:| |postBigFloat|) - (|in| |postin|) ;" the infix operator version of in" - (IN |postIn|) ;" the iterator form of in" - (REPEAT |postRepeat|) - (|TupleCollect| |postTupleCollect|) - (|add| |postAdd|) - (|Reduce| |postReduce|) - (\, |postComma|) - (\; |postSemiColon|) - (|where| |postWhere|) - (|::| |postColonColon|) - (\: |postColon|) - (@ |postAtSign|) - (|pretend| |postPretend|) - (|if| |postIf|) - (|Join| |postJoin|) - (|Signature| |postSignature|) - (CATEGORY |postCategory|) -;;( |postDef|) - (== |postDef|) - (|==>| |postMDef|) - (|->| |postMapping|) - (|=>| |postExit|) - (|Tuple| |postTuple|) -)) (MAKEPROP (CAR X) '|postTran| (CADR X))) - -(MAKEPROP 'INTEGER 'ISFUNCTION 'FIXP) -(MAKEPROP '|Integer| '|isFunction| '|IsInteger|) -(MAKEPROP '|Boolean| '|isFunction| '|isBoolean|) - -;; Many of the following are now in COMPAT LISP -(REPEAT (IN X '( - (+ PLUS) - (|and| AND) - (|append| APPEND) - (|apply| APPLY) - (|atom| ATOM) - (|brace| REMDUP) - (|car| CAR) - (|cdr| CDR) - (|cons| CONS) - (|copy| COPY) - (|croak| CROAK) - (|drop| DROP) - (|exit| EXIT) - (|false| NIL) - (|first| CAR) - (|genvar| GENVAR) - (|in| |member|) - (|is| IS) - (|lastNode| LASTNODE) - (|list| LIST) - (|mkpf| MKPF) - (|nconc| NCONC) - (|nil| NIL) - (|not| NULL) - (|NOT| NULL) - (|nreverse| NREVERSE) - (|null| NULL) - (|or| OR) - (|otherwise| 'T) - (|removeDuplicates| REMDUP) - (|rest| CDR) - (|return| RETURN) - (|reverse| REVERSE) - (|setDifference| SETDIFFERENCE) - (|setIntersection| |intersection|) - (|setPart| SETELT) - (|setUnion| |union|) - (|size| SIZE) - (|strconc| STRCONC) - (|substitute| MSUBST) - (SUBST MSUBST) - (|take| TAKE) - (|true| 'T) - (|where| WHERE) - (* TIMES) - (** EXPT) - (^ NULL) - (^= NEQUAL) - (- SPADDIFFERENCE) - (/ QUOTIENT) - (= EQUAL) - (ASSOC |assoc|) - (DELETE |delete|) - (GET GETL) - (INTERSECTION |intersection|) - (LAST |last|) - (MEMBER |member|) - (RASSOC |rassoc|) - (READ VMREAD) - (READ-LINE |read-line|) - (REDUCE SPADREDUCE) - (REMOVE |remove|) - (\| SUCHTHAT) - (T T$) - (UNION |union|) -)) (MAKEPROP (CAR X) 'RENAME (CDR X))) - -;; these are accessor names for fields in data structures. Thus one would -;; write datastructure.setName -(REPEAT (IN X '( - (|setName| 0) - (|setLabel| 1) - (|setLevel| 2) - (|setType| 3) - (|setVar| 4) - (|setLeaf| 5) - (|setDef| 6) - (|aGeneral| 4) - (|aMode| 1) - (|aModeSet| 3) - (|aTree| 0) - (|attributes| CADDR) - (|aValue| 2) - (|cacheCount| CADDDDR) - (|cacheName| CADR) - (|cacheReset| CADDDR) - (|cacheType| CADDR) - (|env| CADDR) - (|expr| CAR) - (|first| CAR) - (|mmCondition| CAADR) - (|mmDC| CAAR) - (|mmImplementation| CADADR) - (|mmSignature| CDAR) - (|mmTarget| CADAR) - (|mode| CADR) - (|op| CAR) - (|opcode| CADR) - (|opSig| CADR) - (|rest| CDR) - (|sig| CDDR) - (|source| CDR) - (|streamCode| CADDDR) - (|streamDef| CADDR) - (|streamName| CADR) - (|target| CAR) -)) (MAKEPROP (CAR X) '|SEL,FUNCTION| (CADR X))) - -(REPEAT (IN X '( - (\| |compSuchthat|) - (\@ |compAtSign|) - (|:| |compColon|) - (\:\: |compCoerce|) - (QUOTE |compQuote|) -<> - (|add| |compAdd|) - (CAPSULE |compCapsule|) - (|case| |compCase|) - (CATEGORY |compCategory|) - (COLLECT |compRepeatOrCollect|) - (COLLECTV |compCollectV|) - (CONS |compCons|) - (|construct| |compConstruct|) - (DEF |compDefine|) - (|elt| |compElt|) - (|exit| |compExit|) - (|has| |compHas|) - (IF |compIf|) - (|import| |compImport|) - (|is| |compIs|) - (|Join| |compJoin|) - (|leave| |compLeave|) - (LET |compSetq|) - (|ListCategory| |compConstructorCategory|) - (MDEF |compMacro|) - (|pretend| |compPretend|) - (|Record| |compCat|) - (|RecordCategory| |compConstructorCategory|) - (REDUCE |compReduce|) - (REPEAT |compRepeatOrCollect|) - (|return| |compReturn|) - (SEQ |compSeq|) - (SETQ |compSetq|) - (|String| |compString|) - (|SubDomain| |compSubDomain|) - (|SubsetCategory| |compSubsetCategory|) - (|Union| |compCat|) - (|Mapping| |compCat|) - (|UnionCategory| |compConstructorCategory|) - (VECTOR |compVector|) - (|VectorCategory| |compConstructorCategory|) - (|where| |compWhere|) -)) (MAKEPROP (CAR X) 'SPECIAL (CREATE-SBC (CADR X)))) - -(REPEAT (IN X '( - (\: |compColonInteractive|) - (DEF |compDefineInteractive|) - (|construct| |compConstructInteractive|) - (LET |compSetqInteractive|) -)) (MAKEPROP (CAR X) 'INTERACTIVE (CREATE-SBC (CADR X)))) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/setq.lisp b/src/interp/setq.lisp new file mode 100644 index 00000000..bc9908ac --- /dev/null +++ b/src/interp/setq.lisp @@ -0,0 +1,469 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + +(setq copyrights '( + "Copyright The Numerical Algorithms Group Limited 1991-94." + "All rights reserved" + "Certain derivative-work portions Copyright (C) 1998 by Leslie Lamport." + "Portions (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984." + "All rights reserved")) + +(in-package "BOOT") + +(SETQ |/MAJOR-VERSION| 7) +(SETQ /RELEASE 0) + +(defconstant |$cclSystem| +#+:CCL 't +#-:CCL nil +) + +;; These two variables are referred to in setvars.boot. +#+:kcl (setq input-libraries nil) +#+:kcl (setq output-library nil) + +;; For the browser, used for building local databases when a user compiles +;; their own code. +(SETQ |$newConstructorList| nil) +(SETQ |$newConlist| nil) +(SETQ |$createLocalLibDb| 't) + + +;; These were originally in SPAD LISP + +(SETQ $BOOT NIL) +(setq |$interpOnly| nil) +(SETQ |$testingSystem| NIL) +(SETQ |$publicSystem| NIL) +(SETQ |$newcompMode| NIL) +(SETQ |$newComp| NIL) +(SETQ |$newCompCompare| NIL) +(SETQ |$permitWhere| NIL) +(SETQ |$newSystem| T) +(SETQ |$compileDontDefineFunctions| 'T) +(SETQ |$compileOnlyCertainItems| NIL) +(SETQ |$devaluateList| NIL) +(SETQ |$doNotCompressHashTableIfTrue| NIL) +(SETQ |$mutableChecking| NIL) ; used in DEFINE BOOT +(SETQ |$mutableDomains| NIL) ; checked in DEFINE BOOT +(SETQ |$functionLocations| NIL) +(SETQ |$functorLocalParameters| NIL) ; used in compSymbol +(SETQ /RELEASE '"UNKNOWN") +(SETQ |$insideCategoryPackageIfTrue| NIL) +(SETQ |$insideCompileBodyIfTrue| NIL) +(SETQ |$globalExposureGroupAlist| NIL) +(SETQ |$localExposureDataDefault| + (VECTOR (LIST '|basic| '|categories| '|naglink| '|anna| ) NIL NIL)) +(SETQ |$localExposureData| + (VECTOR (LIST '|basic| '|categories| '|naglink| '|anna| ) NIL NIL)) +(SETQ |$compilingInputFile| NIL) +(SETQ |$minivectorNames| NIL) +(setq |$ReadingFile| NIL) +(setq |$NonNullStream| "NonNullStream") +(setq |$NullStream| "NullStream") +(setq |$domPvar| nil) +(defvar $dalymode nil "if true then leading paren implies lisp cmd") +(setq |$Newline| #\Newline) + + +(SETQ STAKCOLUMN -1) +(SETQ ECHOMETA NIL) +(SETQ |$checkParseIfTrue| 'NIL) +(SETQ |$oldParserExpandAbbrs| NIL) +(SETQ |S:SPADKEY| NIL) ;" this is augmented by MAKESPADOP" +(SETQ |/EDIT,FT| 'SPAD) +(SETQ |/EDIT,FM| 'A) +(SETQ /EDITFILE NIL) +(SETQ INITCOLUMN 0) +(SETQ |$functionTable| NIL) +(SETQ |$spaddefs| NIL) +(SETQ |$xeditIsConsole| NIL) +(SETQ |$echoInputLines| NIL) ;; This is in SETVART also +(SETQ |$Slot1DataBase| (MAKE-HASHTABLE 'ID)) ;; See NRUNTIME BOOT +(SETQ |$pfKeysForBrowse| NIL) +(SETQ MARG 0) + ;" Margin for testing by ?OP" +(SETQ LCTRUE '|true|) +(SETQ |$displayParserOutput| 'T) + +(SETQ |$insideReadRulesIfTrue| NIL) +(SETQ |$consistencyCheck| 'T) +(SETQ |$useUndo| NIL) +(SETQ |$ruleSetsInitialized| NIL) + +;; tell the system not to use the new parser +(SETQ |$useNewParser| NIL) + +(SETQ |$htPrecedenceTable| NIL) + +(SETQ |$NRTmakeCompactDirect| NIL) +(SETQ |$NRTquick| NIL) +(SETQ |$NRTmakeShortDirect| NIL) +(SETQ |$newWorld| NIL) +(SETQ |$returnNowhereFromGoGet| NIL) + +(SETQ |$insideCanCoerceFrom| NIL) + +(SETQ |$useCoerceOrCroak| T) + +(SETQ |$abbreviateJoin| NIL) + +(SETQ |$InterpreterMacroAlist| + '((|%i| . (|complex| 0 1)) + (|%e| . (|exp| 1)) + (|%pi| . (|pi|)) + (|SF| . (|DoubleFloat|)) + (|%infinity| . (|infinity|)) + (|%plusInfinity| . (|plusInfinity|)) + (|%minusInfinity| . (|minusInfinity|)))) + +;; variables controlling companion pages (see copage.boot) +(SETQ |$HTCompanionWindowID| nil) +(SETQ |$HTPreviousDomain| nil) +(SETQ |$HTOperationError| nil) + +;; Common lisp control variables +;;(setq *load-verbose* nil) +(setq *print-array* nil) +(setq *print-pretty* nil) +(setq *print-circle* nil) + +(SETQ |S:SPADTOK| 'SPADSYSTOK) +(SETQ APLMODE NIL) +(SETQ RLGENSYMFG NIL) +(SETQ RLGENSYMLST NIL) +(SETQ XTOKENREADER 'SPADTOK) +(SETQ |$delimiterTokenList| + '(| | |)| |(| |{| |}| |[| |]| ENDOFLINECHR EOI EOL |END_LINE|)) +(SETQ |$generalTokenIfTrue| NIL) +(SETQ OPASSOC NIL) +(SETQ SPADSYSKEY '(EOI EOL)) + +;; These are for the output routines in OUT BOOT + +(SETQ $LINELENGTH 77) +(SETQ $MARGIN 3) +(SETQ *TALLPAR NIL) +(SETQ ALLSTAR NIL) +(SETQ BLANK " ") +(SETQ COLON ":") +(SETQ COMMA ",") +(SETQ DASH "-") +(SETQ DOLLAR "$") +(SETQ EQSIGN "=") +(SETQ LPAR "(") +(SETQ MATBORCH "*") +(SETQ PERIOD ".") +(SETQ PLUSS "+") +(SETQ RPAR ")") +(SETQ SLASH "/") +(SETQ STAR "*") +(SETQ UNDERBAR "_") +(SETQ |$fortranArrayStartingIndex| 0) + +;; These were originally in INIT LISP + +(SETQ |$dependeeClosureAlist| NIL) +(SETQ |$userModemaps| NIL) +(SETQ |$functorForm| NIL) + +(SETQ |$InitialCommandSynonymAlist| '( + (|?| . "what commands") + (|ap| . "what things") + (|apr| . "what things") + (|apropos| . "what things") + (|cache| . "set functions cache") + (|cl| . "clear") + (|cls| . "zsystemdevelopment )cls") + (|cms| . "system") + (|co| . "compiler") + (|d| . "display") + (|dep| . "display dependents") + (|dependents| . "display dependents") + (|e| . "edit") + (|expose| . "set expose add constructor") + (|fc| . "zsystemdevelopment )c") + (|fd| . "zsystemdevelopment )d") + (|fdt| . "zsystemdevelopment )dt") + (|fct| . "zsystemdevelopment )ct") + (|fctl| . "zsystemdevelopment )ctl") + (|fe| . "zsystemdevelopment )e") + (|fec| . "zsystemdevelopment )ec") + (|fect| . "zsystemdevelopment )ect") + (|fns| . "exec spadfn") + (|fortran| . "set output fortran") + (|h| . "help") + (|hd| . "system hypertex &") + (|kclam| . "boot clearClams ( )") + (|killcaches| . "boot clearConstructorAndLisplibCaches ( )") + (|patch| . "zsystemdevelopment )patch") + (|pause| . "zsystemdevelopment )pause") + (|prompt| . "set message prompt") + (|recurrence| . "set functions recurrence") + (|restore| . "history )restore") + (|save| . "history )save") + (|startGraphics| . "system $AXIOM/lib/viewman &") + (|startNAGLink| . "system $AXIOM/lib/nagman &") + (|stopGraphics| . "lisp (|sockSendSignal| 2 15)") + (|stopNAGLink| . "lisp (|sockSendSignal| 8 15)") + (|time| . "set message time") + (|type| . "set message type") + (|unexpose| . "set expose drop constructor") + (|up| . "zsystemdevelopment )update") + (|version| . "lisp *yearweek*") + (|w| . "what") + (|wc| . "what categories") + (|wd| . "what domains") + (|who| . "lisp (pprint credits)") + (|wp| . "what packages") + (|ws| . "what synonyms") +)) + +(SETQ |$CommandSynonymAlist| (COPY |$InitialCommandSynonymAlist|)) + +(SETQ |$existingFiles| (MAKE-HASHTABLE 'UEQUAL)) + +(SETQ |$instantRecord| (MAKE-HASHTABLE 'ID)) +(SETQ |$immediateDataSymbol| '|--immediateData--|) + +(SETQ |$useIntegerSubdomain| 'T) +(SETQ |$useNewFloat| 'T) + +;; the following symbol holds the canonical "failed" value +(SETQ |$failed| "failed") + +(SETQ |$constructorDataTable| NIL) + +(SETQ |$univariateDomains| '( + |UnivariatePolynomial| + |UnivariateTaylorSeries| + |UnivariateLaurentSeries| + |UnivariatePuiseuxSeries| + )) +(SETQ |$multivariateDomains| '( + |MultivariatePolynomial| + |DistributedMultivariatePolynomial| + |HomogeneousDistributedMultivariatePolynomial| + |GeneralDistributedMultivariatePolynomial| + )) + +(SETQ |$DomainsWithoutLisplibs| '( + CAPSULE |Union| |Record| |SubDomain| |Mapping| |Enumeration| |Domain| |Mode|)) + +(SETQ |$tracedMapSignatures| ()) +(SETQ |$highlightAllowed| 'T) + ;" used in BRIGHTPRINT and is a )set variable" + +(SETQ |$printStorageIfTrue| NIL) ;; storage info disabled in common lisp + +(SETQ |$AnonymousFunction| '(|AnonymousFunction|)) +(SETQ |$Any| '(|Any|)) + +(SETQ |$OutputForm| '(|OutputForm|)) + +(SETQ |$ComplexInteger| (LIST '|Complex| |$Integer|)) +(SETQ |$QuotientField| '|Fraction|) +(SETQ |$FunctionalExpression| '|Expression|) +(SETQ |$defaultFunctionTargets| '(())) + +;; New Names +(SETQ |$SingleInteger| '(|SingleInteger|)) + +(SETQ $NE (LIST (LIST NIL))) +(SETQ |$suffix| NIL) +(SETQ |$coerceIntByMapCounter| 0) +(SETQ |$prefix| NIL) +(SETQ |$formalArgList| ()) +(SETQ |$TriangleVariableList| + '(|t#1| |t#2| |t#3| |t#4| |t#5| |t#6| |t#7| |t#8| |t#9| |t#10| + |t#11| |t#12| |t#13| |t#14| |t#15| |t#16| |t#17| |t#18| |t#19| |t#20| + |t#21| |t#22| |t#23| |t#24| |t#25| |t#26| |t#27| |t#28| |t#29| |t#30| + |t#31| |t#32| |t#33| |t#34| |t#35| |t#36| |t#37| |t#38| |t#39| |t#40| + |t#41| |t#42| |t#43| |t#44| |t#45| |t#46| |t#47| |t#48| |t#49| |t#50|)) + +(SETQ NRTPARSE NIL) +(SETQ |$NRTflag| T) +(SETQ |$NRTaddForm| NIL) +(SETQ |$NRTdeltaList| NIL) +(SETQ |$NRTbase| 0) +(SETQ |$NRTdeltaLength| 0) +(SETQ |$NRTopt| NIL) ;; turns off buggy code +(SETQ |$Slot1DataBase| NIL) +(SETQ |$NRTmonitorIfTrue| NIL) + +(SETQ |$useConvertForCoercions| NIL) + +(MAKEPROP '|One| '|defaultType| |$Integer|) +(MAKEPROP '|Zero| '|defaultType| |$Integer|) + +;; Following were originally in EXPLORE BOOT + +(SETQ |$xdatabase| NIL) +(SETQ |$CatOfCatDatabase| NIL) +(SETQ |$DomOfCatDatabase| NIL) +(SETQ |$JoinOfDomDatabase| NIL) +(SETQ |$JoinOfCatDatabase| NIL) +(SETQ |$attributeDb| NIL) + +(SETQ |$abbreviateIfTrue| NIL) +(SETQ |$deltax| 0) +(SETQ |$deltay| 0) +(SETQ |$displayDomains| 'T) +(SETQ |$displayTowardAncestors| NIL) +(SETQ |$focus| NIL) +(SETQ |$focusAccessPath| NIL) +(SETQ |$minimumSeparation| 3) +(SETQ |$origMaxColumn| 80) +(SETQ |$origMaxRow| 20) +(SETQ |$origMinColumn| 1) +(SETQ |$origMinRow| 1) + +;; ---- start of initial settings for variables used in test.boot + +(SETQ |$testOutputLineFlag| NIL) ;; referenced by charyTop, prnd + ;; to stash lines +(SETQ |$testOutputLineStack| NIL) ;; saves lines to be printed + ;; (needed to convert lines for use + ;; in hypertex) +(SETQ |$runTestFlag| NIL) ;; referenced by maPrin to stash + ;; output by recordAndPrint to not + ;; print type/time +(SETQ |$mkTestFlag| NIL) ;; referenced by READLN to stash input + ;; by maPrin to stash output + ;; by recordAndPrint to write i/o + ;; onto $testStream +(SETQ |$mkTestInputStack| NIL) ;; saves input for $testStream + ;; (see READLN) +(SETQ |$mkTestOutputStack| NIL) ;; saves output for $testStream + ;; (see maPrin) + +;; ---- end of initial settings for variables used in test.boot + + +;; Next are initial values for fluid variables in G-BOOT BOOT + +(SETQ |$inDefLET| NIL) +(SETQ |$inDefIS| NIL) +(SETQ |$letGenVarCounter| 1) +(SETQ |$isGenVarCounter| 1) + +;; Next 2 lines originally from CLAM BOOT + +;; this node is used in looking up values +(SETQ |$hashNode| (LIST NIL)) + +(SETQ ERRORINSTREAM (DEFIOSTREAM + '((DEVICE . CONSOLE) (MODE . INPUT) (QUAL . T)) 133 1)) + +(SETQ ERROROUTSTREAM + (DEFIOSTREAM '((DEVICE . CONSOLE)(MODE . OUTPUT)) 80 0) ) + +(SETQ |$algebraOutputStream| + (DEFIOSTREAM '((DEVICE . CONSOLE)(MODE . OUTPUT)) 255 0) ) + +;; By default, don't generate info files with old compiler. +(setq |$profileCompiler| nil) + +(setq credits '( +"An alphabetical listing of contributors to AXIOM (to October, 2006):" +"Cyril Alberga Roy Adler Christian Aistleitner" +"Richard Anderson George Andrews" +"Henry Baker Stephen Balzac Yurij Baransky" +"David R. Barton Gerald Baumgartner Gilbert Baumslag" +"Fred Blair Vladimir Bondarenko Mark Botch" +"Alexandre Bouyer Peter A. Broadbery Martin Brock" +"Manuel Bronstein Florian Bundschuh Luanne Burns" +"William Burge" +"Quentin Carpent Robert Caviness Bruce Char" +"Cheekai Chin David V. Chudnovsky Gregory V. Chudnovsky" +"Josh Cohen Christophe Conil Don Coppersmith" +"George Corliss Robert Corless Gary Cornell" +"Meino Cramer Claire Di Crescenzo" +"Timothy Daly Sr. Timothy Daly Jr. James H. Davenport" +"Jean Della Dora Gabriel Dos Reis Michael Dewar" +"Claire DiCrescendo Sam Dooley Lionel Ducos" +"Martin Dunstan Brian Dupee Dominique Duval" +"Robert Edwards Heow Eide-Goodman Lars Erickson" +"Richard Fateman Bertfried Fauser Stuart Feldman" +"Brian Ford Albrecht Fortenbacher George Frances" +"Constantine Frangos Timothy Freeman Korrinn Fu" +"Marc Gaetano Rudiger Gebauer Kathy Gerber" +"Patricia Gianni Holger Gollan Teresa Gomez-Diaz" +"Laureano Gonzalez-Vega Stephen Gortler Johannes Grabmeier" +"Matt Grayson James Griesmer Vladimir Grinberg" +"Oswald Gschnitzer Jocelyn Guidry" +"Steve Hague Vilya Harvey Satoshi Hamaguchi" +"Martin Hassner Waldek Hebisch Ralf Hemmecke" +"Henderson Antoine Hersen" +"Pietro Iglio" +"Richard Jenks" +"Kai Kaminski Grant Keady Tony Kennedy" +"Paul Kosinski Klaus Kusche Bernhard Kutzler" +"Larry Lambe Frederic Lehobey Michel Levaud" +"Howard Levy Rudiger Loos Michael Lucks" +"Richard Luczak" +"Camm Maguire Bob McElrath Michael McGettrick" +"Ian Meikle David Mentre Victor S. Miller" +"Gerard Milmeister Mohammed Mobarak H. Michael Moeller" +"Michael Monagan Marc Moreno-Maza Scott Morrison" +"Mark Murray" +"William Naylor C. Andrew Neff John Nelder" +"Godfrey Nolan Arthur Norman Jinzhong Niu" +"Michael O'Connor Kostas Oikonomou" +"Julian A. Padget Bill Page Susan Pelzel" +"Michel Petitot Didier Pinchon Jose Alfredo Portes" +"Claude Quitte" +"Norman Ramsey Michael Richardson Renaud Rioboo" +"Jean Rivlin Nicolas Robidoux Simon Robinson" +"Michael Rothstein Martin Rubey" +"Philip Santas Alfred Scheerhorn William Schelter" +"Gerhard Schneider Martin Schoenert Marshall Schor" +"Frithjof Schulze Fritz Schwarz Nick Simicich" +"William Sit Elena Smirnova Jonathan Steinbach" +"Christine Sundaresan Robert Sutor Moss E. Sweedler" +"Eugene Surowitz" +"James Thatcher Balbir Thomas Mike Thomas" +"Dylan Thurston Barry Trager Themos T. Tsikas" +"Gregory Vanuxem" +"Bernhard Wall Stephen Watt Jaap Weel" +"Juergen Weiss M. Weller Mark Wegman" +"James Wen Thorsten Werther Michael Wester" +"John M. Wiley Berhard Will Clifton J. Williamson" +"Stephen Wilson Shmuel Winograd Robert Wisbauer" +"Sandra Wityak Waldemar Wiwianka Knut Wolf" +"Clifford Yapp David Yun" +"Richard Zippel Evelyn Zoernack Bruno Zuercher" +"Dan Zwillinger" +)) + diff --git a/src/interp/setq.lisp.pamphlet b/src/interp/setq.lisp.pamphlet deleted file mode 100644 index 6e8e580a..00000000 --- a/src/interp/setq.lisp.pamphlet +++ /dev/null @@ -1,495 +0,0 @@ -%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/setq.lisp} Pamphlet} -\author{Timothy Daly} - -\begin{document} - -\maketitle -\begin{abstract} -\end{abstract} - -\tableofcontents -\eject - -\section{License} - -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -(setq copyrights '( - "Copyright The Numerical Algorithms Group Limited 1991-94." - "All rights reserved" - "Certain derivative-work portions Copyright (C) 1998 by Leslie Lamport." - "Portions (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984." - "All rights reserved")) - -(in-package "BOOT") - -(SETQ |/MAJOR-VERSION| 7) -(SETQ /RELEASE 0) - -(defconstant |$cclSystem| -#+:CCL 't -#-:CCL nil -) - -;; These two variables are referred to in setvars.boot. -#+:kcl (setq input-libraries nil) -#+:kcl (setq output-library nil) - -;; For the browser, used for building local databases when a user compiles -;; their own code. -(SETQ |$newConstructorList| nil) -(SETQ |$newConlist| nil) -(SETQ |$createLocalLibDb| 't) - - -;; These were originally in SPAD LISP - -(SETQ $BOOT NIL) -(setq |$interpOnly| nil) -(SETQ |$testingSystem| NIL) -(SETQ |$publicSystem| NIL) -(SETQ |$newcompMode| NIL) -(SETQ |$newComp| NIL) -(SETQ |$newCompCompare| NIL) -(SETQ |$permitWhere| NIL) -(SETQ |$newSystem| T) -(SETQ |$compileDontDefineFunctions| 'T) -(SETQ |$compileOnlyCertainItems| NIL) -(SETQ |$devaluateList| NIL) -(SETQ |$doNotCompressHashTableIfTrue| NIL) -(SETQ |$mutableChecking| NIL) ; used in DEFINE BOOT -(SETQ |$mutableDomains| NIL) ; checked in DEFINE BOOT -(SETQ |$functionLocations| NIL) -(SETQ |$functorLocalParameters| NIL) ; used in compSymbol -(SETQ /RELEASE '"UNKNOWN") -(SETQ |$insideCategoryPackageIfTrue| NIL) -(SETQ |$insideCompileBodyIfTrue| NIL) -(SETQ |$globalExposureGroupAlist| NIL) -(SETQ |$localExposureDataDefault| - (VECTOR (LIST '|basic| '|categories| '|naglink| '|anna| ) NIL NIL)) -(SETQ |$localExposureData| - (VECTOR (LIST '|basic| '|categories| '|naglink| '|anna| ) NIL NIL)) -(SETQ |$compilingInputFile| NIL) -(SETQ |$minivectorNames| NIL) -(setq |$ReadingFile| NIL) -(setq |$NonNullStream| "NonNullStream") -(setq |$NullStream| "NullStream") -(setq |$domPvar| nil) -(defvar $dalymode nil "if true then leading paren implies lisp cmd") -(setq |$Newline| #\Newline) - - -(SETQ STAKCOLUMN -1) -(SETQ ECHOMETA NIL) -(SETQ |$checkParseIfTrue| 'NIL) -(SETQ |$oldParserExpandAbbrs| NIL) -(SETQ |S:SPADKEY| NIL) ;" this is augmented by MAKESPADOP" -(SETQ |/EDIT,FT| 'SPAD) -(SETQ |/EDIT,FM| 'A) -(SETQ /EDITFILE NIL) -(SETQ INITCOLUMN 0) -(SETQ |$functionTable| NIL) -(SETQ |$spaddefs| NIL) -(SETQ |$xeditIsConsole| NIL) -(SETQ |$echoInputLines| NIL) ;; This is in SETVART also -(SETQ |$Slot1DataBase| (MAKE-HASHTABLE 'ID)) ;; See NRUNTIME BOOT -(SETQ |$pfKeysForBrowse| NIL) -(SETQ MARG 0) - ;" Margin for testing by ?OP" -(SETQ LCTRUE '|true|) -(SETQ |$displayParserOutput| 'T) - -(SETQ |$insideReadRulesIfTrue| NIL) -(SETQ |$consistencyCheck| 'T) -(SETQ |$useUndo| NIL) -(SETQ |$ruleSetsInitialized| NIL) - -;; tell the system not to use the new parser -(SETQ |$useNewParser| NIL) - -(SETQ |$htPrecedenceTable| NIL) - -(SETQ |$NRTmakeCompactDirect| NIL) -(SETQ |$NRTquick| NIL) -(SETQ |$NRTmakeShortDirect| NIL) -(SETQ |$newWorld| NIL) -(SETQ |$returnNowhereFromGoGet| NIL) - -(SETQ |$insideCanCoerceFrom| NIL) - -(SETQ |$useCoerceOrCroak| T) - -(SETQ |$abbreviateJoin| NIL) - -(SETQ |$InterpreterMacroAlist| - '((|%i| . (|complex| 0 1)) - (|%e| . (|exp| 1)) - (|%pi| . (|pi|)) - (|SF| . (|DoubleFloat|)) - (|%infinity| . (|infinity|)) - (|%plusInfinity| . (|plusInfinity|)) - (|%minusInfinity| . (|minusInfinity|)))) - -;; variables controlling companion pages (see copage.boot) -(SETQ |$HTCompanionWindowID| nil) -(SETQ |$HTPreviousDomain| nil) -(SETQ |$HTOperationError| nil) - -;; Common lisp control variables -;;(setq *load-verbose* nil) -(setq *print-array* nil) -(setq *print-pretty* nil) -(setq *print-circle* nil) - -(SETQ |S:SPADTOK| 'SPADSYSTOK) -(SETQ APLMODE NIL) -(SETQ RLGENSYMFG NIL) -(SETQ RLGENSYMLST NIL) -(SETQ XTOKENREADER 'SPADTOK) -(SETQ |$delimiterTokenList| - '(| | |)| |(| |{| |}| |[| |]| ENDOFLINECHR EOI EOL |END_LINE|)) -(SETQ |$generalTokenIfTrue| NIL) -(SETQ OPASSOC NIL) -(SETQ SPADSYSKEY '(EOI EOL)) - -;; These are for the output routines in OUT BOOT - -(SETQ $LINELENGTH 77) -(SETQ $MARGIN 3) -(SETQ *TALLPAR NIL) -(SETQ ALLSTAR NIL) -(SETQ BLANK " ") -(SETQ COLON ":") -(SETQ COMMA ",") -(SETQ DASH "-") -(SETQ DOLLAR "$") -(SETQ EQSIGN "=") -(SETQ LPAR "(") -(SETQ MATBORCH "*") -(SETQ PERIOD ".") -(SETQ PLUSS "+") -(SETQ RPAR ")") -(SETQ SLASH "/") -(SETQ STAR "*") -(SETQ UNDERBAR "_") -(SETQ |$fortranArrayStartingIndex| 0) - -;; These were originally in INIT LISP - -(SETQ |$dependeeClosureAlist| NIL) -(SETQ |$userModemaps| NIL) -(SETQ |$functorForm| NIL) - -(SETQ |$InitialCommandSynonymAlist| '( - (|?| . "what commands") - (|ap| . "what things") - (|apr| . "what things") - (|apropos| . "what things") - (|cache| . "set functions cache") - (|cl| . "clear") - (|cls| . "zsystemdevelopment )cls") - (|cms| . "system") - (|co| . "compiler") - (|d| . "display") - (|dep| . "display dependents") - (|dependents| . "display dependents") - (|e| . "edit") - (|expose| . "set expose add constructor") - (|fc| . "zsystemdevelopment )c") - (|fd| . "zsystemdevelopment )d") - (|fdt| . "zsystemdevelopment )dt") - (|fct| . "zsystemdevelopment )ct") - (|fctl| . "zsystemdevelopment )ctl") - (|fe| . "zsystemdevelopment )e") - (|fec| . "zsystemdevelopment )ec") - (|fect| . "zsystemdevelopment )ect") - (|fns| . "exec spadfn") - (|fortran| . "set output fortran") - (|h| . "help") - (|hd| . "system hypertex &") - (|kclam| . "boot clearClams ( )") - (|killcaches| . "boot clearConstructorAndLisplibCaches ( )") - (|patch| . "zsystemdevelopment )patch") - (|pause| . "zsystemdevelopment )pause") - (|prompt| . "set message prompt") - (|recurrence| . "set functions recurrence") - (|restore| . "history )restore") - (|save| . "history )save") - (|startGraphics| . "system $AXIOM/lib/viewman &") - (|startNAGLink| . "system $AXIOM/lib/nagman &") - (|stopGraphics| . "lisp (|sockSendSignal| 2 15)") - (|stopNAGLink| . "lisp (|sockSendSignal| 8 15)") - (|time| . "set message time") - (|type| . "set message type") - (|unexpose| . "set expose drop constructor") - (|up| . "zsystemdevelopment )update") - (|version| . "lisp *yearweek*") - (|w| . "what") - (|wc| . "what categories") - (|wd| . "what domains") - (|who| . "lisp (pprint credits)") - (|wp| . "what packages") - (|ws| . "what synonyms") -)) - -(SETQ |$CommandSynonymAlist| (COPY |$InitialCommandSynonymAlist|)) - -(SETQ |$existingFiles| (MAKE-HASHTABLE 'UEQUAL)) - -(SETQ |$instantRecord| (MAKE-HASHTABLE 'ID)) -(SETQ |$immediateDataSymbol| '|--immediateData--|) - -(SETQ |$useIntegerSubdomain| 'T) -(SETQ |$useNewFloat| 'T) - -;; the following symbol holds the canonical "failed" value -(SETQ |$failed| "failed") - -(SETQ |$constructorDataTable| NIL) - -(SETQ |$univariateDomains| '( - |UnivariatePolynomial| - |UnivariateTaylorSeries| - |UnivariateLaurentSeries| - |UnivariatePuiseuxSeries| - )) -(SETQ |$multivariateDomains| '( - |MultivariatePolynomial| - |DistributedMultivariatePolynomial| - |HomogeneousDistributedMultivariatePolynomial| - |GeneralDistributedMultivariatePolynomial| - )) - -(SETQ |$DomainsWithoutLisplibs| '( - CAPSULE |Union| |Record| |SubDomain| |Mapping| |Enumeration| |Domain| |Mode|)) - -(SETQ |$tracedMapSignatures| ()) -(SETQ |$highlightAllowed| 'T) - ;" used in BRIGHTPRINT and is a )set variable" - -(SETQ |$printStorageIfTrue| NIL) ;; storage info disabled in common lisp - -(SETQ |$AnonymousFunction| '(|AnonymousFunction|)) -(SETQ |$Any| '(|Any|)) - -(SETQ |$OutputForm| '(|OutputForm|)) - -(SETQ |$ComplexInteger| (LIST '|Complex| |$Integer|)) -(SETQ |$QuotientField| '|Fraction|) -(SETQ |$FunctionalExpression| '|Expression|) -(SETQ |$defaultFunctionTargets| '(())) - -;; New Names -(SETQ |$SingleInteger| '(|SingleInteger|)) - -(SETQ $NE (LIST (LIST NIL))) -(SETQ |$suffix| NIL) -(SETQ |$coerceIntByMapCounter| 0) -(SETQ |$prefix| NIL) -(SETQ |$formalArgList| ()) -(SETQ |$TriangleVariableList| - '(|t#1| |t#2| |t#3| |t#4| |t#5| |t#6| |t#7| |t#8| |t#9| |t#10| - |t#11| |t#12| |t#13| |t#14| |t#15| |t#16| |t#17| |t#18| |t#19| |t#20| - |t#21| |t#22| |t#23| |t#24| |t#25| |t#26| |t#27| |t#28| |t#29| |t#30| - |t#31| |t#32| |t#33| |t#34| |t#35| |t#36| |t#37| |t#38| |t#39| |t#40| - |t#41| |t#42| |t#43| |t#44| |t#45| |t#46| |t#47| |t#48| |t#49| |t#50|)) - -(SETQ NRTPARSE NIL) -(SETQ |$NRTflag| T) -(SETQ |$NRTaddForm| NIL) -(SETQ |$NRTdeltaList| NIL) -(SETQ |$NRTbase| 0) -(SETQ |$NRTdeltaLength| 0) -(SETQ |$NRTopt| NIL) ;; turns off buggy code -(SETQ |$Slot1DataBase| NIL) -(SETQ |$NRTmonitorIfTrue| NIL) - -(SETQ |$useConvertForCoercions| NIL) - -(MAKEPROP '|One| '|defaultType| |$Integer|) -(MAKEPROP '|Zero| '|defaultType| |$Integer|) - -;; Following were originally in EXPLORE BOOT - -(SETQ |$xdatabase| NIL) -(SETQ |$CatOfCatDatabase| NIL) -(SETQ |$DomOfCatDatabase| NIL) -(SETQ |$JoinOfDomDatabase| NIL) -(SETQ |$JoinOfCatDatabase| NIL) -(SETQ |$attributeDb| NIL) - -(SETQ |$abbreviateIfTrue| NIL) -(SETQ |$deltax| 0) -(SETQ |$deltay| 0) -(SETQ |$displayDomains| 'T) -(SETQ |$displayTowardAncestors| NIL) -(SETQ |$focus| NIL) -(SETQ |$focusAccessPath| NIL) -(SETQ |$minimumSeparation| 3) -(SETQ |$origMaxColumn| 80) -(SETQ |$origMaxRow| 20) -(SETQ |$origMinColumn| 1) -(SETQ |$origMinRow| 1) - -;; ---- start of initial settings for variables used in test.boot - -(SETQ |$testOutputLineFlag| NIL) ;; referenced by charyTop, prnd - ;; to stash lines -(SETQ |$testOutputLineStack| NIL) ;; saves lines to be printed - ;; (needed to convert lines for use - ;; in hypertex) -(SETQ |$runTestFlag| NIL) ;; referenced by maPrin to stash - ;; output by recordAndPrint to not - ;; print type/time -(SETQ |$mkTestFlag| NIL) ;; referenced by READLN to stash input - ;; by maPrin to stash output - ;; by recordAndPrint to write i/o - ;; onto $testStream -(SETQ |$mkTestInputStack| NIL) ;; saves input for $testStream - ;; (see READLN) -(SETQ |$mkTestOutputStack| NIL) ;; saves output for $testStream - ;; (see maPrin) - -;; ---- end of initial settings for variables used in test.boot - - -;; Next are initial values for fluid variables in G-BOOT BOOT - -(SETQ |$inDefLET| NIL) -(SETQ |$inDefIS| NIL) -(SETQ |$letGenVarCounter| 1) -(SETQ |$isGenVarCounter| 1) - -;; Next 2 lines originally from CLAM BOOT - -;; this node is used in looking up values -(SETQ |$hashNode| (LIST NIL)) - -(SETQ ERRORINSTREAM (DEFIOSTREAM - '((DEVICE . CONSOLE) (MODE . INPUT) (QUAL . T)) 133 1)) - -(SETQ ERROROUTSTREAM - (DEFIOSTREAM '((DEVICE . CONSOLE)(MODE . OUTPUT)) 80 0) ) - -(SETQ |$algebraOutputStream| - (DEFIOSTREAM '((DEVICE . CONSOLE)(MODE . OUTPUT)) 255 0) ) - -;; By default, don't generate info files with old compiler. -(setq |$profileCompiler| nil) - -(setq credits '( -"An alphabetical listing of contributors to AXIOM (to October, 2006):" -"Cyril Alberga Roy Adler Christian Aistleitner" -"Richard Anderson George Andrews" -"Henry Baker Stephen Balzac Yurij Baransky" -"David R. Barton Gerald Baumgartner Gilbert Baumslag" -"Fred Blair Vladimir Bondarenko Mark Botch" -"Alexandre Bouyer Peter A. Broadbery Martin Brock" -"Manuel Bronstein Florian Bundschuh Luanne Burns" -"William Burge" -"Quentin Carpent Robert Caviness Bruce Char" -"Cheekai Chin David V. Chudnovsky Gregory V. Chudnovsky" -"Josh Cohen Christophe Conil Don Coppersmith" -"George Corliss Robert Corless Gary Cornell" -"Meino Cramer Claire Di Crescenzo" -"Timothy Daly Sr. Timothy Daly Jr. James H. Davenport" -"Jean Della Dora Gabriel Dos Reis Michael Dewar" -"Claire DiCrescendo Sam Dooley Lionel Ducos" -"Martin Dunstan Brian Dupee Dominique Duval" -"Robert Edwards Heow Eide-Goodman Lars Erickson" -"Richard Fateman Bertfried Fauser Stuart Feldman" -"Brian Ford Albrecht Fortenbacher George Frances" -"Constantine Frangos Timothy Freeman Korrinn Fu" -"Marc Gaetano Rudiger Gebauer Kathy Gerber" -"Patricia Gianni Holger Gollan Teresa Gomez-Diaz" -"Laureano Gonzalez-Vega Stephen Gortler Johannes Grabmeier" -"Matt Grayson James Griesmer Vladimir Grinberg" -"Oswald Gschnitzer Jocelyn Guidry" -"Steve Hague Vilya Harvey Satoshi Hamaguchi" -"Martin Hassner Waldek Hebisch Ralf Hemmecke" -"Henderson Antoine Hersen" -"Pietro Iglio" -"Richard Jenks" -"Kai Kaminski Grant Keady Tony Kennedy" -"Paul Kosinski Klaus Kusche Bernhard Kutzler" -"Larry Lambe Frederic Lehobey Michel Levaud" -"Howard Levy Rudiger Loos Michael Lucks" -"Richard Luczak" -"Camm Maguire Bob McElrath Michael McGettrick" -"Ian Meikle David Mentre Victor S. Miller" -"Gerard Milmeister Mohammed Mobarak H. Michael Moeller" -"Michael Monagan Marc Moreno-Maza Scott Morrison" -"Mark Murray" -"William Naylor C. Andrew Neff John Nelder" -"Godfrey Nolan Arthur Norman Jinzhong Niu" -"Michael O'Connor Kostas Oikonomou" -"Julian A. Padget Bill Page Susan Pelzel" -"Michel Petitot Didier Pinchon Jose Alfredo Portes" -"Claude Quitte" -"Norman Ramsey Michael Richardson Renaud Rioboo" -"Jean Rivlin Nicolas Robidoux Simon Robinson" -"Michael Rothstein Martin Rubey" -"Philip Santas Alfred Scheerhorn William Schelter" -"Gerhard Schneider Martin Schoenert Marshall Schor" -"Frithjof Schulze Fritz Schwarz Nick Simicich" -"William Sit Elena Smirnova Jonathan Steinbach" -"Christine Sundaresan Robert Sutor Moss E. Sweedler" -"Eugene Surowitz" -"James Thatcher Balbir Thomas Mike Thomas" -"Dylan Thurston Barry Trager Themos T. Tsikas" -"Gregory Vanuxem" -"Bernhard Wall Stephen Watt Jaap Weel" -"Juergen Weiss M. Weller Mark Wegman" -"James Wen Thorsten Werther Michael Wester" -"John M. Wiley Berhard Will Clifton J. Williamson" -"Stephen Wilson Shmuel Winograd Robert Wisbauer" -"Sandra Wityak Waldemar Wiwianka Knut Wolf" -"Clifford Yapp David Yun" -"Richard Zippel Evelyn Zoernack Bruno Zuercher" -"Dan Zwillinger" -)) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/sfsfun-l.lisp b/src/interp/sfsfun-l.lisp new file mode 100644 index 00000000..b969fb53 --- /dev/null +++ b/src/interp/sfsfun-l.lisp @@ -0,0 +1,71 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + +(in-package "BOOT") + +;; +;; Lisp part of the Scratchpad special function interface. +;; SMW Feb 91 +;; + +;; #-:CCL +;; (defun |float| (x) (|float| x)) + +;; Conversion between spad and lisp complex representations +(defun s-to-c (c) (complex (car c) (cdr c))) +(defun c-to-s (c) (cons (realpart c) (imagpart c))) +(defun c-to-r (c) + (let ((r (realpart c)) (i (imagpart c))) + (if (or (zerop i) (< (abs i) (* 1.0E-10 (abs r)))) + r + (|error| "Result is not real.")) )) + +;; Wrappers for functions in the special function package +(defun rlngamma (x) (|lnrgamma| x) ) +(defun clngamma (z) (c-to-s (|lncgamma| (s-to-c z)) )) + +;; #-:CCL +(defun rgamma (x) (|rgamma| x)) +(defun cgamma (z) (c-to-s (|cgamma| (s-to-c z)) )) + +(defun rpsi (n x) (|rPsi| n x) ) +(defun cpsi (n z) (c-to-s (|cPsi| n (s-to-c z)) )) + +(defun rbesselj (n x) (c-to-r (|BesselJ| n x)) )) +(defun cbesselj (v z) (c-to-s (|BesselJ| (s-to-c v) (s-to-c z)) )) + +(defun rbesseli (n x) (c-to-r (|BesselI| n x)) )) +(defun cbesseli (v z) (c-to-s (|BesselI| (s-to-c v) (s-to-c z)) )) + +(defun chyper0f1 (a z) (c-to-s (|chebf01| (s-to-c a) (s-to-c z)) )) diff --git a/src/interp/sfsfun-l.lisp.pamphlet b/src/interp/sfsfun-l.lisp.pamphlet deleted file mode 100644 index c7c992e0..00000000 --- a/src/interp/sfsfun-l.lisp.pamphlet +++ /dev/null @@ -1,91 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp sfsfun-l.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -(in-package "BOOT") - -;; -;; Lisp part of the Scratchpad special function interface. -;; SMW Feb 91 -;; - -;; #-:CCL -;; (defun |float| (x) (|float| x)) - -;; Conversion between spad and lisp complex representations -(defun s-to-c (c) (complex (car c) (cdr c))) -(defun c-to-s (c) (cons (realpart c) (imagpart c))) -(defun c-to-r (c) - (let ((r (realpart c)) (i (imagpart c))) - (if (or (zerop i) (< (abs i) (* 1.0E-10 (abs r)))) - r - (|error| "Result is not real.")) )) - -;; Wrappers for functions in the special function package -(defun rlngamma (x) (|lnrgamma| x) ) -(defun clngamma (z) (c-to-s (|lncgamma| (s-to-c z)) )) - -;; #-:CCL -(defun rgamma (x) (|rgamma| x)) -(defun cgamma (z) (c-to-s (|cgamma| (s-to-c z)) )) - -(defun rpsi (n x) (|rPsi| n x) ) -(defun cpsi (n z) (c-to-s (|cPsi| n (s-to-c z)) )) - -(defun rbesselj (n x) (c-to-r (|BesselJ| n x)) )) -(defun cbesselj (v z) (c-to-s (|BesselJ| (s-to-c v) (s-to-c z)) )) - -(defun rbesseli (n x) (c-to-r (|BesselI| n x)) )) -(defun cbesseli (v z) (c-to-s (|BesselI| (s-to-c v) (s-to-c z)) )) - -(defun chyper0f1 (a z) (c-to-s (|chebf01| (s-to-c a) (s-to-c z)) )) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/sockio.lisp b/src/interp/sockio.lisp new file mode 100644 index 00000000..66b8aebc --- /dev/null +++ b/src/interp/sockio.lisp @@ -0,0 +1,243 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + +;; load C socket functions + +(in-package "BOOT") + +#+(and :Lucid (not :ibm/370)) +(progn + (system:define-foreign-function :c 'open_server :fixnum) + (system:define-foreign-function :c 'sock_get_int :fixnum) + (system:define-foreign-function :c 'sock_send_int :fixnum) + (system:define-foreign-function :c 'sock_get_string_buf :fixnum) + (system:define-foreign-function :c 'sock_send_string_len :fixnum) + (system:define-foreign-function :c 'sock_get_float :single) + (system:define-foreign-function :c 'sock_send_float :fixnum) + (system:define-foreign-function :c 'sock_send_wakeup :fixnum) + (system:define-foreign-function :c 'server_switch :fixnum) + (system:define-foreign-function :c 'flush_stdout :fixnum) + (system:define-foreign-function :c 'sock_send_signal :fixnum) + (system:define-foreign-function :c 'print_line :fixnum) + (system:define-foreign-function :c 'plus_infininty :single) + (system:define-foreign-function :c 'minus_infinity :single) + (system:define-foreign-function :c 'NANQ :single) +) + +#+KCL +(progn + (clines "extern double plus_infinity(), minus_infinity(), NANQ();") + (clines "extern double sock_get_float();") +;; GCL may pass strings by value. 'sock_get_string_buf' should fill +;; string with data read from connection, therefore needs address of +;; actual string buffer. We use 'sock_get_string_buf_wrapper' to +;; resolve the problem + (clines "int sock_get_string_buf_wrapper(int i, object x, int j)" + "{ if (type_of(x)!=t_string) FEwrong_type_argument(sLstring,x);" + " if (x->st.st_fillpst.st_self, j); }") + (defentry open_server (string) (int "open_server")) + (defentry sock_get_int (int) (int "sock_get_int")) + (defentry sock_send_int (int int) (int "sock_send_int")) + (defentry sock_get_string_buf (int object int) + (int "sock_get_string_buf_wrapper")) + (defentry sock_send_string_len (int string int) (int "sock_send_string_len")) + (defentry sock_get_float (int) (double "sock_get_float")) + (defentry sock_send_float (int double) (int "sock_send_float")) + (defentry sock_send_wakeup (int int) (int "sock_send_wakeup")) + (defentry server_switch () (int "server_switch")) + (defentry flush_stdout () (int "flush_stdout")) + (defentry sock_send_signal (int int) (int "sock_send_signal")) + (defentry print_line (string) (int "print_line")) + (defentry plus_infinity () (double "plus_infinity")) + (defentry minus_infinity () (double "minus_infinity")) + (defentry NANQ () (double "NANQ")) + ) + +(defun open-server (name) +#+(and :lucid :ibm/370) -2 +#-(and :lucid :ibm/370) + (open_server name)) +(defun sock-get-int (type) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_get_int type)) +(defun sock-send-int (type val) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_send_int type val)) +(defun sock-get-string (type buf buf-len) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_get_string_buf type buf buf-len)) +(defun sock-send-string (type str) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_send_string_len type str (length str))) +(defun sock-get-float (type) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_get_float type)) +(defun sock-send-float (type val) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_send_float type val)) +(defun sock-send-wakeup (type) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_send_wakeup type)) +(defun server-switch () +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (server_switch)) +(defun sock-send-signal (type signal) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_send_signal type signal)) +(defun print-line (str) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (print_line str)) +(defun |plusInfinity| () (plus_infinity)) +(defun |minusInfinity| () (minus_infinity)) + +;; Macros for use in Boot + +(defun |openServer| (name) + (open_server name)) +(defun |sockGetInt| (type) + (sock_get_int type)) +(defun |sockSendInt| (type val) + (sock_send_int type val)) +(defun |sockGetString| (type buf buf-len) + (sock_get_string_buf type buf buf-len)) +(defun |sockSendString| (type str) + (sock_send_string_len type str (length str))) +(defun |sockGetFloat| (type) + (sock_get_float type)) +(defun |sockSendFloat| (type val) + (sock_send_float type val)) +(defun |sockSendWakeup| (type) + (sock_send_wakeup type)) +(defun |serverSwitch| () + (server_switch)) +(defun |sockSendSignal| (type signal) + (sock_send_signal type signal)) +(defun |printLine| (str) + (print_line str)) + +;; Socket types. This list must be consistent with the one in com.h + +(defconstant SessionManager 1) +(defconstant ViewportServer 2) +(defconstant MenuServer 3) +(defconstant SessionIO 4) +(defconstant MessageServer 5) +(defconstant InterpWindow 6) +(defconstant KillSpad 7) +(defconstant DebugWindow 8) +(defconstant NAGLinkServer 8) +(defconstant Forker 9) + +;; same constants for use in BOOT +(defconstant |$SessionManager| SessionManager) +(defconstant |$ViewportServer| ViewportServer) +(defconstant |$MenuServer| MenuServer) +(defconstant |$SessionIO| SessionIO) +(defconstant |$MessageServer| MessageServer) +(defconstant |$InterpWindow| InterpWindow) +(defconstant |$KillSpad| KillSpad) +(defconstant |$DebugWindow| DebugWindow) +(defconstant |$NAGLinkServer| NAGLinkServer) +(defconstant |$Forker| Forker) + +;; Session Manager action requests + +(defconstant CreateFrame 1) +(defconstant SwitchFrames 2) +(defconstant EndOfOutput 3) +(defconstant CallInterp 4) +(defconstant EndSession 5) +(defconstant LispCommand 6) +(defconstant SpadCommand 7) +(defconstant SendXEventToHyperTeX 8) +(defconstant QuietSpadCommand 9) +(defconstant CloseClient 10) +(defconstant QueryClients 11) +(defconstant QuerySpad 12) +(defconstant NonSmanSession 13) +(defconstant KillLispSystem 14) + +(defconstant |$CreateFrame| CreateFrame) +(defconstant |$SwitchFrames| SwitchFrames) +(defconstant |$EndOfOutput| EndOfOutput) +(defconstant |$CallInterp| CallInterp) +(defconstant |$EndSession| EndSession) +(defconstant |$LispCommand| LispCommand) +(defconstant |$SpadCommand| SpadCommand) +(defconstant |$SendXEventToHyperTeX| SendXEventToHyperTeX) +(defconstant |$QuietSpadCommand| QuietSpadCommand) +(defconstant |$CloseClient| CloseClient) +(defconstant |$QueryClients| QueryClients) +(defconstant |$QuerySpad| QuerySpad) +(defconstant |$NonSmanSession| NonSmanSession) +(defconstant |$KillLispSystem| KillLispSystem) + +;; signal types (from /usr/include/sys/signal.h) +#+(and :Lucid (not :ibm/370)) +(progn + (defconstant SIGUSR1 16) ;; user defined signal 1 + (defconstant SIGUSR2 17) ;; user defined signal 2 + ) + +#+:RIOS +(progn + (defconstant SIGUSR1 30) ;; user defined signal 1 + (defconstant SIGUSR2 31) ;; user defined signal 2 + ) + +#+:IBMPS2 +(progn + (defconstant SIGUSR1 30) ;; user defined signal 1 + (defconstant SIGUSR2 31) ;; user defined signal 2 + ) + +(setq |$NaNvalue| (NANQ)) +#-:ccl + (setq |$plusInfinity| (* 1.1 MOST-POSITIVE-LONG-FLOAT)) +#+:ccl + (setq |$plusInfinity| MOST-POSITIVE-LONG-FLOAT) +(setq |$minusInfinity| (- |$plusInfinity|)) + diff --git a/src/interp/sockio.lisp.pamphlet b/src/interp/sockio.lisp.pamphlet deleted file mode 100644 index 2a585267..00000000 --- a/src/interp/sockio.lisp.pamphlet +++ /dev/null @@ -1,263 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp sockio.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -;; load C socket functions - -(in-package "BOOT") - -#+(and :Lucid (not :ibm/370)) -(progn - (system:define-foreign-function :c 'open_server :fixnum) - (system:define-foreign-function :c 'sock_get_int :fixnum) - (system:define-foreign-function :c 'sock_send_int :fixnum) - (system:define-foreign-function :c 'sock_get_string_buf :fixnum) - (system:define-foreign-function :c 'sock_send_string_len :fixnum) - (system:define-foreign-function :c 'sock_get_float :single) - (system:define-foreign-function :c 'sock_send_float :fixnum) - (system:define-foreign-function :c 'sock_send_wakeup :fixnum) - (system:define-foreign-function :c 'server_switch :fixnum) - (system:define-foreign-function :c 'flush_stdout :fixnum) - (system:define-foreign-function :c 'sock_send_signal :fixnum) - (system:define-foreign-function :c 'print_line :fixnum) - (system:define-foreign-function :c 'plus_infininty :single) - (system:define-foreign-function :c 'minus_infinity :single) - (system:define-foreign-function :c 'NANQ :single) -) - -#+KCL -(progn - (clines "extern double plus_infinity(), minus_infinity(), NANQ();") - (clines "extern double sock_get_float();") -;; GCL may pass strings by value. 'sock_get_string_buf' should fill -;; string with data read from connection, therefore needs address of -;; actual string buffer. We use 'sock_get_string_buf_wrapper' to -;; resolve the problem - (clines "int sock_get_string_buf_wrapper(int i, object x, int j)" - "{ if (type_of(x)!=t_string) FEwrong_type_argument(sLstring,x);" - " if (x->st.st_fillpst.st_self, j); }") - (defentry open_server (string) (int "open_server")) - (defentry sock_get_int (int) (int "sock_get_int")) - (defentry sock_send_int (int int) (int "sock_send_int")) - (defentry sock_get_string_buf (int object int) - (int "sock_get_string_buf_wrapper")) - (defentry sock_send_string_len (int string int) (int "sock_send_string_len")) - (defentry sock_get_float (int) (double "sock_get_float")) - (defentry sock_send_float (int double) (int "sock_send_float")) - (defentry sock_send_wakeup (int int) (int "sock_send_wakeup")) - (defentry server_switch () (int "server_switch")) - (defentry flush_stdout () (int "flush_stdout")) - (defentry sock_send_signal (int int) (int "sock_send_signal")) - (defentry print_line (string) (int "print_line")) - (defentry plus_infinity () (double "plus_infinity")) - (defentry minus_infinity () (double "minus_infinity")) - (defentry NANQ () (double "NANQ")) - ) - -(defun open-server (name) -#+(and :lucid :ibm/370) -2 -#-(and :lucid :ibm/370) - (open_server name)) -(defun sock-get-int (type) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_get_int type)) -(defun sock-send-int (type val) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_send_int type val)) -(defun sock-get-string (type buf buf-len) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_get_string_buf type buf buf-len)) -(defun sock-send-string (type str) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_send_string_len type str (length str))) -(defun sock-get-float (type) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_get_float type)) -(defun sock-send-float (type val) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_send_float type val)) -(defun sock-send-wakeup (type) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_send_wakeup type)) -(defun server-switch () -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (server_switch)) -(defun sock-send-signal (type signal) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_send_signal type signal)) -(defun print-line (str) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (print_line str)) -(defun |plusInfinity| () (plus_infinity)) -(defun |minusInfinity| () (minus_infinity)) - -;; Macros for use in Boot - -(defun |openServer| (name) - (open_server name)) -(defun |sockGetInt| (type) - (sock_get_int type)) -(defun |sockSendInt| (type val) - (sock_send_int type val)) -(defun |sockGetString| (type buf buf-len) - (sock_get_string_buf type buf buf-len)) -(defun |sockSendString| (type str) - (sock_send_string_len type str (length str))) -(defun |sockGetFloat| (type) - (sock_get_float type)) -(defun |sockSendFloat| (type val) - (sock_send_float type val)) -(defun |sockSendWakeup| (type) - (sock_send_wakeup type)) -(defun |serverSwitch| () - (server_switch)) -(defun |sockSendSignal| (type signal) - (sock_send_signal type signal)) -(defun |printLine| (str) - (print_line str)) - -;; Socket types. This list must be consistent with the one in com.h - -(defconstant SessionManager 1) -(defconstant ViewportServer 2) -(defconstant MenuServer 3) -(defconstant SessionIO 4) -(defconstant MessageServer 5) -(defconstant InterpWindow 6) -(defconstant KillSpad 7) -(defconstant DebugWindow 8) -(defconstant NAGLinkServer 8) -(defconstant Forker 9) - -;; same constants for use in BOOT -(defconstant |$SessionManager| SessionManager) -(defconstant |$ViewportServer| ViewportServer) -(defconstant |$MenuServer| MenuServer) -(defconstant |$SessionIO| SessionIO) -(defconstant |$MessageServer| MessageServer) -(defconstant |$InterpWindow| InterpWindow) -(defconstant |$KillSpad| KillSpad) -(defconstant |$DebugWindow| DebugWindow) -(defconstant |$NAGLinkServer| NAGLinkServer) -(defconstant |$Forker| Forker) - -;; Session Manager action requests - -(defconstant CreateFrame 1) -(defconstant SwitchFrames 2) -(defconstant EndOfOutput 3) -(defconstant CallInterp 4) -(defconstant EndSession 5) -(defconstant LispCommand 6) -(defconstant SpadCommand 7) -(defconstant SendXEventToHyperTeX 8) -(defconstant QuietSpadCommand 9) -(defconstant CloseClient 10) -(defconstant QueryClients 11) -(defconstant QuerySpad 12) -(defconstant NonSmanSession 13) -(defconstant KillLispSystem 14) - -(defconstant |$CreateFrame| CreateFrame) -(defconstant |$SwitchFrames| SwitchFrames) -(defconstant |$EndOfOutput| EndOfOutput) -(defconstant |$CallInterp| CallInterp) -(defconstant |$EndSession| EndSession) -(defconstant |$LispCommand| LispCommand) -(defconstant |$SpadCommand| SpadCommand) -(defconstant |$SendXEventToHyperTeX| SendXEventToHyperTeX) -(defconstant |$QuietSpadCommand| QuietSpadCommand) -(defconstant |$CloseClient| CloseClient) -(defconstant |$QueryClients| QueryClients) -(defconstant |$QuerySpad| QuerySpad) -(defconstant |$NonSmanSession| NonSmanSession) -(defconstant |$KillLispSystem| KillLispSystem) - -;; signal types (from /usr/include/sys/signal.h) -#+(and :Lucid (not :ibm/370)) -(progn - (defconstant SIGUSR1 16) ;; user defined signal 1 - (defconstant SIGUSR2 17) ;; user defined signal 2 - ) - -#+:RIOS -(progn - (defconstant SIGUSR1 30) ;; user defined signal 1 - (defconstant SIGUSR2 31) ;; user defined signal 2 - ) - -#+:IBMPS2 -(progn - (defconstant SIGUSR1 30) ;; user defined signal 1 - (defconstant SIGUSR2 31) ;; user defined signal 2 - ) - -(setq |$NaNvalue| (NANQ)) -#-:ccl - (setq |$plusInfinity| (* 1.1 MOST-POSITIVE-LONG-FLOAT)) -#+:ccl - (setq |$plusInfinity| MOST-POSITIVE-LONG-FLOAT) -(setq |$minusInfinity| (- |$plusInfinity|)) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp new file mode 100644 index 00000000..b1735557 --- /dev/null +++ b/src/interp/spad.lisp @@ -0,0 +1,580 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + +; NAME: Scratchpad Package +; PURPOSE: This is an initialization and system-building file for Scratchpad. + +(IMPORT-MODULE "bootlex") +(in-package "BOOT") + +;;; Common Block + +(defvar |$preserveSystemLisplib| t "if nil finalizeLisplib does MA REP") +(defvar |$incrementalLisplibFlag| nil "checked in compDefineLisplib") +(defvar |$reportInstantiations| nil) +(defvar |$reportEachInstantiation| nil) +(defvar |$reportCounts| nil) +(defvar |$CategoryDefaults| nil) +(defvar |$compForModeIfTrue| nil "checked in compSymbol") +(defvar |$functorForm| nil "checked in addModemap0") +(defvar |$formalArgList| nil "checked in compSymbol") +(defvar |$newComp| nil "use new compiler") +(defvar |$newCompCompare| nil "compare new compiler with old") +(defvar |$compileOnlyCertainItems| nil "list of functions to compile") +(defvar |$newCompAtTopLevel| nil "if t uses new compiler") +(defvar |$doNotCompileJustPrint| nil "switch for compile") +(defvar |$PrintCompilerMessageIfTrue| t) +(defvar |$Rep| '|$Rep| "should be bound to gensym? checked in coerce") +;; the following initialization of $ must not be a defvar +;; since that make $ special +(setq $ '$) ;; used in def of Ring which is Algebra($) +(defvar |$scanIfTrue| nil "if t continue compiling after errors") +(defvar |$Representation| nil "checked in compNoStacking") +(defvar |$definition| nil "checked in DomainSubstitutionFunction") +(defvar |$Attributes| nil "global attribute list used in JoinInner") +(defvar |$env| nil "checked in isDomainValuedVariable") +(defvar |$e| nil "checked in isDomainValuedVariable") +(defvar |$getPutTrace| nil) +(defvar |$specialCaseKeyList| nil "checked in optCall") +(defvar |$formulaFormat| nil "if true produce script formula output") +(defvar |$texFormat| nil "if true produce tex output") +(defvar |$fortranFormat| nil "if true produce fortran output") +(defvar |$algebraFormat| t "produce 2-d algebra output") +(defvar |$kernelWarn| NIL "") +(defvar |$kernelProtect| NIL "") +(defvar |$HiFiAccess| nil "if true maintain history file") +(defvar |$mapReturnTypes| nil) +(defvar /TRACENAMES NIL) + +(defvar INPUTSTREAM t "bogus initialization for now") + +(defvar |boot-NewKEY| NIL) + +(DEFVAR _ '&) +(defvar /EDIT-FM 'A1) +(defvar /EDIT-FT 'SPAD) +(defvar /RELEASE '"UNKNOWN") +(defvar /rp '/RP) +(defvar APLMODE NIL) +(defvar error-print) +(defvar ind) +(defvar INITCOLUMN 0) +(defvar JUNKTOKLIST '(FOR IN AS INTO OF TO)) +(defvar LCTRUE '|true|) +(defvar m-chrbuffer) +(defvar m-chrindex) +(defvar MARG 0 "Margin for testing by ?OP") +(defvar NewFlag) +(defvar ParseMode) +(defvar RLGENSYMFG NIL) +(defvar RLGENSYMLST NIL) +(defvar S-SPADTOK 'SPADSYSTOK) +(defvar sortpred) +(defvar SPADSYSKEY '(EOI EOL)) +(defvar STAKCOLUMN -1) +(setq XTOKENREADER 'SPADTOK) +(defvar xtrans '|boot-new|) +(defvar |$IOAlist| '((|%i| . (|gauss| 0 1)))) +(defvar |InteractiveMode|) +(defvar |NewFLAG| t) +(defvar |uc| 'UC) + +(DEFUN INTEGER-BIT (N I) (LOGBITP I N)) + +(DEFUN /TRANSPAD (X) + (PROG (proplist) + (setq proplist (LIST '(FLUID . |true|) + (CONS '|special| + (COPY-TREE |$InitialDomainsInScope|)))) + (SETQ |$InteractiveFrame| + (|addBinding| '|$DomainsInScope| proplist + (|addBinding| '|$Information| NIL + (COPY-TREE |$InitialModemapFrame|)))) + (RETURN (PROGN (S-PROCESS X) NIL)))) + + ;; NIL needed below since END\_UNIT is not generated by current parser + +(defun |traceComp| () + (SETQ |$compCount| 0) + (EMBED '|comp| + '(LAMBDA (X Y Z) + (PROG (U) + (SETQ |$compCount| (1+ |$compCount|)) + (SETQ |yesOrNo| (if (SETQ U (|comp| X Y Z)) + (if (EQUAL (SECOND U) Y) '|yes| (SECOND U)) + ('T '|no|))) + (|sayBrightly| (CONS (MAKE-FULL-CVEC |$compCount| " ") + (LIST X " --> " Y '|%b| |yesOrNo| '|%d|))) + (SETQ |$compCount| (1- |$compCount|)) + (RETURN U) ))) + (|comp| $x $m $f) + (UNEMBED '|comp|)) + +(defun READ-SPAD (FN FM TO) + (LET ((proplist + (LIST '(FLUID . |true|) + (CONS '|special| (COPY-TREE |$InitialDomainsInScope|))))) + (SETQ |$InteractiveFrame| + (|addBinding| '|$DomainsInScope| proplist + (|addBinding| '|$Information| NIL + (|makeInitialModemapFrame|)))) + (READ-SPAD0 FN 'SPAD FM TO))) + +(defun READ-INPUT (FN FM TO) (READ-SPAD0 FN 'INPUT FM TO)) + +(defun READ-SPAD0 (FN FT FM TO) + (let (($newspad t)) (READ-SPAD1 FN FT FM TO))) + +(defun READ-SPAD-1 () (|New,ENTRY,1|)) + +(defun UNCONS (X) + (COND ((ATOM X) X) + ((EQCAR X 'CONS) (CONS (SECOND X) (UNCONS (THIRD X)))) + (T (ERROR "UNCONS")))) + +(defun OPTIMIZE\&PRINT (X) (PRETTYPRINT (/MDEF X))) + +(defun SPAD-PRINTTIME (A B) + (let (c msg) + (setq C (+ A B)) + (setq MSG (STRCONC "(" (STRINGIMAGE A) " + " (STRINGIMAGE B) + " = " (STRINGIMAGE C) " MS.)")) + (PRINT (STRCONC (STRINGPAD "" (DIFFERENCE 80 (SIZE MSG))) MSG)))) + +(defun SPAD-MODETRAN (X) (D-TRAN X)) + +(defun SPAD-EVAL (X) + (COND ((ATOM X) (EVAL X)) + ((CONS (FIRST X) (MAPCAR #'SPAD-EVAL (CDR X)))))) + +;************************************************************************ +; SYSTEM COMMANDS +;************************************************************************ + +(defun CLEARDATABASE () (OBEY "ERASE MODEMAP DATABASE")) + +(defun erase (FN FT) + (OBEY (STRCONC "ERASE " (STRINGIMAGE FN) " " (STRINGIMAGE FT)))) + +(defun READLISP (UPPER_CASE_FG) + (let (v expr val ) + (setq EXPR (READ-FROM-STRING + (IF UPPER_CASE_FG (string-upcase (line-buffer CURRENT-LINE)) + (line-buffer CURRENT-LINE)) + t nil :start (Line-CURRENT-INDEX CURRENT-LINE))) + (VMPRINT EXPR) + (setq VAL ((LAMBDA (|$InteractiveMode|) (EVAL EXPR)) NIL)) + (FORMAT t "~&VALUE = ~S" VAL) + (TERSYSCOMMAND))) + +(defun TERSYSCOMMAND () + (FRESH-LINE) + (SETQ CHR 'ENDOFLINECHR) + (SETQ TOK 'END_UNIT) + (|spadThrow|)) + +(defun /READ (L Q) +; (SETQ /EDIT-FN (OR (KAR L) /EDIT-FN)) +; (SETQ /EDIT-FT (OR (KAR (KDR L)) 'INPUT)) +; (SETQ /EDIT-FM (OR (KAR (KDR (KDR L))) '*)) +; (SETQ /EDITFILE (LIST /EDIT-FN /EDIT-FT /EDIT-FM)) + (SETQ /EDITFILE L) + (COND + (Q (/RQ)) + ('T (/RF)) ) + (FLAG |boot-NewKEY| 'KEY) + (|terminateSystemCommand|) + (|spadPrompt|)) + +(defun /EDIT (L) + (SETQ /EDITFILE L) + (/EF) + (|terminateSystemCommand|) + (|spadPrompt|)) + +(defun /COMPINTERP (L OPTS) + (SETQ /EDITFILE (/MKINFILENAM L)) + (COND ((EQUAL OPTS "rf") (/RF)) + ((EQUAL OPTS "rq") (/RQ)) + ('T (/RQ-LIB))) + (|terminateSystemCommand|) + (|spadPrompt|)) + +(defun CPSAY (X) (let (n) (if (EQ 0 (setq N (OBEY X))) NIL (PRINT N)))) + +(defun /FLAG (L) + (MAKEPROP (FIRST L) 'FLAGS (LET ((X (UNION (CDR L)))) (GET (FIRST L) 'FLAGS))) + (SAY (FIRST L) " has flags: " X) + (TERSYSCOMMAND)) + +(defun |fin| () + (SETQ *EOF* 'T) + (THROW 'SPAD_READER NIL)) + + +(defun STRINGREST (X) (if (EQ (SIZE X) 1) (make-string 0) (SUBSTRING X 1 NIL))) + +(defun STREAM2UC (STRM) + (LET ((X (ELT (LASTATOM STRM) 1))) (SETELT X 0 (LC2UC (ELT X 0))))) + +(defun NEWNAMTRANS (X) + (COND + ((IDENTP X) (COND ( (GET X 'NEWNAM) (GET X 'NEWNAM)) ('T X))) + ((STRINGP X) X) + ((*VECP X) (MAPVWOC X (FUNCTION NEWNAMTRANS))) + ((ATOM X) X) + ((EQCAR X 'QUOTE)) + (T (CONS (NEWNAMTRANS (FIRST X)) (NEWNAMTRANS (CDR X)))))) + +(defun GP2COND (L) + (COND ((NOT L) (ERROR "GP2COND")) + ((NOT (CDR L)) + (COND ((EQCAR (FIRST L) 'COLON) + (CONS (SECOND L) (LIST (LIST T 'FAIL)))) + (T (LIST (LIST T (FIRST L)))) )) + ((EQCAR (FIRST L) 'COLON) (CONS (CDAR L) (GP2COND (CDR L)))) + (T (ERROR "GP2COND")))) + +(FLAG JUNKTOKLIST 'KEY) + +(defmacro |report| (L) + (SUBST (SECOND L) 'x + '(COND ($reportFlag (sayBrightly x)) ((QUOTE T) NIL)))) + +(defmacro |DomainSubstitutionMacro| (&rest L) + (|DomainSubstitutionFunction| (first L) (second L))) + +(defun |sort| (seq spadfn) + (sort (copy-seq seq) (function (lambda (x y) (SPADCALL X Y SPADFN))))) + +#-Lucid +(defun QUOTIENT2 (X Y) (values (TRUNCATE X Y))) + +#+Lucid +(defun QUOTIENT2 (X Y) ; following to force error check in division by zero + (values (if (zerop y) (truncate 1 Y) (TRUNCATE X Y)))) + +#-Lucid +(define-function 'REMAINDER2 #'REM) + +#+Lucid +(defun REMAINDER2 (X Y) + (if (zerop y) (REM 1 Y) (REM X Y))) + +#-Lucid +(defun DIVIDE2 (X Y) (multiple-value-call #'cons (TRUNCATE X Y))) + +#+Lucid +(defun DIVIDE2 (X Y) + (if (zerop y) (truncate 1 Y) + (multiple-value-call #'cons (TRUNCATE X Y)))) + +(defmacro APPEND2 (x y) `(append ,x ,y)) + +(defmacro |float| (x &optional (y 0.0d0)) `(float ,x ,y)) + +(defun |makeSF| (mantissa exponent) + (|float| (/ mantissa (expt 2 (- exponent))))) + +(define-function 'list1 #'list) +(define-function '|not| #'NOT) + +(defun |random| () (random (expt 2 26))) +(defun \,plus (x y) (+ x y)) +(defun \,times (x y) (* x y)) +(defun \,difference (x y) (- x y)) +(defun \,max (x y) (max x y)) +(defun \,min (x y) (min x y)) +;; This is used in the domain Boolean (BOOLEAN.NRLIB/code.lsp) +(defun |BooleanEquality| (x y) (if x y (null y))) + +(defun S-PROCESS (X) + (let ((|$Index| 0) + (*print-pretty* t) + ($MACROASSOC ()) + ($NEWSPAD T) + (|$compUniquelyIfTrue| nil) + |$currentFunction| + |$topOp| + (|$semanticErrorStack| ()) + (|$warningStack| ()) + (|$returnMode| |$EmptyMode|) + (|$leaveLevelStack| ()) + $TOP_LEVEL |$insideFunctorIfTrue| |$insideExpressionIfTrue| + |$insideCoerceInteractiveHardIfTrue| |$insideWhereIfTrue| + |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| |$form| + (|$e| |$EmptyEnvironment|) + (|$genSDVar| 0) + (|$VariableCount| 0) + (|$previousTime| (TEMPUS-FUGIT))) + (prog ((CURSTRM CUROUTSTREAM) |$s| |$x| |$m| u) + (declare (special CURSTRM |$s| |$x| |$m| CUROUTSTREAM)) + (SETQ |$exitModeStack| ()) + (SETQ |$postStack| nil) + (SETQ |$TraceFlag| T) + (if (NOT X) (RETURN NIL)) + (setq X (if $BOOT (DEF-RENAME (|new2OldLisp| X)) + (|parseTransform| (|postTransform| X)))) + ;; (if |$TranslateOnly| (RETURN (SETQ |$Translation| X))) + (when |$postStack| (|displayPreCompilationErrors|) (RETURN NIL)) + (COND (|$PrintOnly| + (format t "~S =====>~%" |$currentLine|) + (RETURN (PRETTYPRINT X)))) + (if (NOT $BOOT) + (if |$InteractiveMode| + (|processInteractive| X NIL) + (if (setq U (|compTopLevel| X |$EmptyMode| + |$InteractiveFrame|)) + (SETQ |$InteractiveFrame| (third U)))) + (DEF-PROCESS X)) + (if |$semanticErrorStack| (|displaySemanticErrors|)) + (TERPRI)))) + +(MAKEPROP 'END_UNIT 'KEY T) + +(defun |process| (x) + (COND ((NOT (EQ TOK 'END_UNIT)) + (SETQ DEBUGMODE 'NO) + (SPAD_SYNTAX_ERROR) + (if |$InteractiveMode| (|spadThrow|)) + (S-PROCESS x)))) + +(defun |evalSharpOne| (x \#1) (declare (special \#1)) (EVAL x)) + +(setq *PROMPT* 'LISP) + +(defun |New,ENTRY,1| () + (let (ZZ str N RLGENSYMFG RLGENSYMLST |NewFLAG| XCAPE *PROMPT* + SINGLELINEMODE OK ISID NBLNK COUNT CHR ULCASEFG ($LINESTACK 'BEGIN_UNIT) + $TOKSTACK COMMENTCHR TOK LINE BACK INPUTSTREAM XTRANS + XTOKENREADER STACK STACKX TRAPFLAG) + (SETQ XTRANS '|boot-New| + XTOKENREADER 'NewSYSTOK + SYNTAX_ERROR 'SPAD_SYNTAX_ERROR) + (FLAG |boot-NewKEY| 'KEY) + (SETQ *PROMPT* 'Scratchpad-II) + (PROMPT) + (SETQ XCAPE '_) + (SETQ COMMENTCHR 'IGNORE) + (SETQ COLUMN 0) + (SETQ SINGLINEMODE T) ; SEE NewSYSTOK + (SETQ NewFLAG T) + (SETQ ULCASEFG T) + (setq STR (|New,ENTRY,2| '|PARSE-NewEXPR| '|process| curinstream)) + (if (/= 0 (setq N (NOTE STR))) + (progn (SETQ CURINSTREAM (POINTW N CURINSTREAM))) + ) + '|END_OF_New|)) + +(defun |New,ENTRY,2| (RULE FN INPUTSTREAM) (declare (special INPUTSTREAM)) + (let (zz) + (INITIALIZE) + (SETQ $previousTime (TEMPUS-FUGIT)) + (setq ZZ (CONVERSATION '|PARSE-NewExpr| '|process|)) + (REMFLAG |boot-NewKEY| 'KEY) + INPUTSTREAM)) + +(defun INITIALIZE () (init-boot/spad-reader) (initialize-preparse INPUTSTREAM)) + +(setq *prompt* 'new) + +(defmacro try (X) + `(LET ((|$autoLine|)) + (declare (special |$autoLine|)) + (|tryToFit| (|saveState|) ,X))) + +(mapcar #'(lambda (X) (MAKEPROP (CAR X) 'format (CADR X))) + '((COMMENT |formatCOMMENT|) + (SEQ |formatSEQ|) + (DEF |formatDEF|) + (LET |formatLET|) + (\: |formatColon|) + (ELT |formatELT|) + (SEGMENT |formatSEGMENT|) + (COND |formatCOND|) + (SCOND |formatSCOND|) + (QUOTE |formatQUOTE|) + (CONS |formatCONS|) + (|where| |formatWHERE|) + (APPEND |formatAPPEND|) + (REPEAT |formatREPEAT|) + (COLLECT |formatCOLLECT|) + (REDUCE |formatREDUCE|))) + +(defmacro |incTimeSum| (a b) + (if (not |$InteractiveTimingStatsIfTrue|) a + (let ((key b) (oldkey (gensym)) (val (gensym))) + `(prog (,oldkey ,val) + (setq ,oldkey (|incrementTimeSum| ,key)) + (setq ,val ,a) + (|incrementTimeSum| ,oldkey) + (return ,val))))) + +(defun GLESSEQP (X Y) (NOT (GGREATERP X Y))) + +(defun LEXLESSEQP (X Y) (NOT (LEXGREATERP X Y))) + +(defun SETELTFIRST (A B C) (declare (ignore b)) (RPLACA A C)) + +(defun SETELTREST (A B C) (declare (ignore b)) (RPLACD A C)) + +(DEFUN ASSOCIATER (FN LST) + (COND ((NULL LST) NIL) + ((NULL (CDR LST)) (CAR LST)) + ((LIST FN (CAR LST) (ASSOCIATER FN (CDR LST)))))) + +(defun ISLOCALOP-1 (IND) + "Curindex points at character after '.'" + (prog (selector buf termtok (NEWCHR (NEXTCHARACTER))) + (if (TERMINATOR NEWCHR) (RETURN NIL)) + (setq SELECTOR + (do ((x nil)) + (nil) + (if (terminator newchr) + (reverse x) + (push (setq newchr (nextcharacter)) x)))) + (if (EQUAL NEWCHR '\.) (RETURN (ISLOCALOP-1 IND))) + (setq BUF (GETSTR (LENGTH SELECTOR))) + (mapc #'(lambda (x) (suffix x buf)) selector) + (setq buf (copy-seq selector)) + (setq TERMTOK (INTERN BUF)) + (if (NOT (GET TERMTOK 'GENERIC)) (RETURN NIL)) + (if (OR (GET TERMTOK '|Led|) (GET TERMTOK '|Nud|)) + (GET TERMTOK IND)) + (return TERMTOK))) +; **** X. Random tables + +(defvar MATBORCH "*") +(defvar $MARGIN 3) +(defvar $LINELENGTH 71) +(defvar TEMPGENSYMLIST '(|s| |r| |q| |p|)) +(defvar ALPHLIST '(|a| |b| |c| |d| |e| |f| |g|)) +(defvar LITTLEIN " in ") +(defvar INITALPHLIST ALPHLIST) +(defvar INITXPARLST '(|i| |j| |k| |l| |m| |n| |p| |q|)) +(defvar PORDLST (COPY-tree INITXPARLST)) +(defvar INITPARLST '(|x| |y| |z| |u| |v| |w| |r| |s| |t|)) +(defvar LITTLEA '|a|) +(defvar LITTLEI '|i|) +(defvar *TALLPAR NIL) +(defvar ALLSTAR NIL) +(defvar BLANK " ") +(defvar PLUSS "+") +(defvar PERIOD ".") +(defvar SLASH "/") +(defvar COMMA ",") +(defvar LPAR "(") +(defvar RPAR ")") +(defvar EQSIGN "=") +(defvar DASH "-") +(defvar STAR "*") +(defvar DOLLAR "$") +(defvar COLON ":") + +(FLAG TEMPGENSYMLIST 'IS-GENSYM) + +(MAKEPROP 'COND '|Nud| '(|if| |if| 130 0)) +(MAKEPROP 'CONS '|Led| '(CONS CONS 1000 1000)) +(MAKEPROP 'APPEND '|Led| '(APPEND APPEND 1000 1000)) +(MAKEPROP 'TAG '|Led| '(TAG TAG 122 121)) +(MAKEPROP 'EQUATNUM '|Nud| '(|dummy| |dummy| 0 0)) +(MAKEPROP 'EQUATNUM '|Led| '(|dummy| |dummy| 10000 0)) +(MAKEPROP 'LET '|Led| '(:= LET 125 124)) +(MAKEPROP 'RARROW '|Led| '(== DEF 122 121)) +(MAKEPROP 'SEGMENT '|Led| '(\.\. SEGMENT 401 699 (|boot-Seg|))) + +;; NAME: DECIMAL-LENGTH +;; PURPOSE: Computes number of decimal digits in print representation of x +;; This should made as efficient as possible. + +(DEFUN DECIMAL-LENGTH (X) + (LET* ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X)))) + (X (TRUNCATE (ABS X) (EXPT 10 (1- K))))) + (IF (LESSP X 10) K (1+ K)))) + +;(DEFUN DECIMAL-LENGTH2 (X) +; (LET ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X))))) +; (IF (< (ABS X) (EXPT 10 K)) K (1+ K)))) + + +;; function to create byte and half-word vectors in new runtime system 8/90 + +#-:CCL +(defun |makeByteWordVec| (initialvalue) + (let ((n (cond ((null initialvalue) 7) ('t (reduce #'max initialvalue))))) + (make-array (length initialvalue) + :element-type (list 'mod (1+ n)) + :initial-contents initialvalue))) + +#+:CCL +(defun |makeByteWordVec| (initialvalue) + (list-to-vector initialvalue)) + +#-:CCL +(defun |makeByteWordVec2| (maxelement initialvalue) + (let ((n (cond ((null initialvalue) 7) ('t maxelement)))) + (make-array (length initialvalue) + :element-type (list 'mod (1+ n)) + :initial-contents initialvalue))) + +#+:CCL +(defun |makeByteWordVec2| (maxelement initialvalue) + (list-to-vector initialvalue)) + +(defun |knownEqualPred| (dom) + (let ((fun (|compiledLookup| '= '((|Boolean|) $ $) dom))) + (if fun (get (bpiname (car fun)) '|SPADreplace|) + nil))) + +(defun |hashable| (dom) + (memq (|knownEqualPred| dom) + #-Lucid '(EQ EQL EQUAL) + #+Lucid '(EQ EQL EQUAL EQUALP) + )) + +;; simpler interpface to RDEFIOSTREAM +(defun RDEFINSTREAM (&rest fn) + ;; following line prevents rdefiostream from adding a default filetype + (if (null (rest fn)) (setq fn (list (pathname (car fn))))) + (rdefiostream (list (cons 'FILE fn) '(mode . INPUT)))) + +(defun RDEFOUTSTREAM (&rest fn) + ;; following line prevents rdefiostream from adding a default filetype + (if (null (rest fn)) (setq fn (list (pathname (car fn))))) + (rdefiostream (list (cons 'FILE fn) '(mode . OUTPUT)))) + +(defmacro |spadConstant| (dollar n) + `(spadcall (svref ,dollar (the fixnum ,n)))) + + diff --git a/src/interp/spad.lisp.pamphlet b/src/interp/spad.lisp.pamphlet deleted file mode 100644 index da3cd6a4..00000000 --- a/src/interp/spad.lisp.pamphlet +++ /dev/null @@ -1,608 +0,0 @@ -%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. - -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/spad.lisp} Pamphlet} -\author{Timothy Daly} - -\begin{document} -\maketitle - -\begin{abstract} -\end{abstract} - -\tableofcontents -\eject - -\section{License} - -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ - -<<*>>= -<> - -; NAME: Scratchpad Package -; PURPOSE: This is an initialization and system-building file for Scratchpad. - -(IMPORT-MODULE "bootlex") -(in-package "BOOT") - -;;; Common Block - -(defvar |$preserveSystemLisplib| t "if nil finalizeLisplib does MA REP") -(defvar |$incrementalLisplibFlag| nil "checked in compDefineLisplib") -(defvar |$reportInstantiations| nil) -(defvar |$reportEachInstantiation| nil) -(defvar |$reportCounts| nil) -(defvar |$CategoryDefaults| nil) -(defvar |$compForModeIfTrue| nil "checked in compSymbol") -(defvar |$functorForm| nil "checked in addModemap0") -(defvar |$formalArgList| nil "checked in compSymbol") -(defvar |$newComp| nil "use new compiler") -(defvar |$newCompCompare| nil "compare new compiler with old") -(defvar |$compileOnlyCertainItems| nil "list of functions to compile") -(defvar |$newCompAtTopLevel| nil "if t uses new compiler") -(defvar |$doNotCompileJustPrint| nil "switch for compile") -(defvar |$PrintCompilerMessageIfTrue| t) -(defvar |$Rep| '|$Rep| "should be bound to gensym? checked in coerce") -;; the following initialization of $ must not be a defvar -;; since that make $ special -(setq $ '$) ;; used in def of Ring which is Algebra($) -(defvar |$scanIfTrue| nil "if t continue compiling after errors") -(defvar |$Representation| nil "checked in compNoStacking") -(defvar |$definition| nil "checked in DomainSubstitutionFunction") -(defvar |$Attributes| nil "global attribute list used in JoinInner") -(defvar |$env| nil "checked in isDomainValuedVariable") -(defvar |$e| nil "checked in isDomainValuedVariable") -(defvar |$getPutTrace| nil) -(defvar |$specialCaseKeyList| nil "checked in optCall") -(defvar |$formulaFormat| nil "if true produce script formula output") -(defvar |$texFormat| nil "if true produce tex output") -(defvar |$fortranFormat| nil "if true produce fortran output") -(defvar |$algebraFormat| t "produce 2-d algebra output") -(defvar |$kernelWarn| NIL "") -(defvar |$kernelProtect| NIL "") -(defvar |$HiFiAccess| nil "if true maintain history file") -(defvar |$mapReturnTypes| nil) -(defvar /TRACENAMES NIL) - -(defvar INPUTSTREAM t "bogus initialization for now") - -(defvar |boot-NewKEY| NIL) - -(DEFVAR _ '&) -(defvar /EDIT-FM 'A1) -(defvar /EDIT-FT 'SPAD) -(defvar /RELEASE '"UNKNOWN") -(defvar /rp '/RP) -(defvar APLMODE NIL) -(defvar error-print) -(defvar ind) -(defvar INITCOLUMN 0) -(defvar JUNKTOKLIST '(FOR IN AS INTO OF TO)) -(defvar LCTRUE '|true|) -(defvar m-chrbuffer) -(defvar m-chrindex) -(defvar MARG 0 "Margin for testing by ?OP") -(defvar NewFlag) -(defvar ParseMode) -(defvar RLGENSYMFG NIL) -(defvar RLGENSYMLST NIL) -(defvar S-SPADTOK 'SPADSYSTOK) -(defvar sortpred) -(defvar SPADSYSKEY '(EOI EOL)) -(defvar STAKCOLUMN -1) -(setq XTOKENREADER 'SPADTOK) -(defvar xtrans '|boot-new|) -(defvar |$IOAlist| '((|%i| . (|gauss| 0 1)))) -(defvar |InteractiveMode|) -(defvar |NewFLAG| t) -(defvar |uc| 'UC) - -(DEFUN INTEGER-BIT (N I) (LOGBITP I N)) - -(DEFUN /TRANSPAD (X) - (PROG (proplist) - (setq proplist (LIST '(FLUID . |true|) - (CONS '|special| - (COPY-TREE |$InitialDomainsInScope|)))) - (SETQ |$InteractiveFrame| - (|addBinding| '|$DomainsInScope| proplist - (|addBinding| '|$Information| NIL - (COPY-TREE |$InitialModemapFrame|)))) - (RETURN (PROGN (S-PROCESS X) NIL)))) - - ;; NIL needed below since END\_UNIT is not generated by current parser - -(defun |traceComp| () - (SETQ |$compCount| 0) - (EMBED '|comp| - '(LAMBDA (X Y Z) - (PROG (U) - (SETQ |$compCount| (1+ |$compCount|)) - (SETQ |yesOrNo| (if (SETQ U (|comp| X Y Z)) - (if (EQUAL (SECOND U) Y) '|yes| (SECOND U)) - ('T '|no|))) - (|sayBrightly| (CONS (MAKE-FULL-CVEC |$compCount| " ") - (LIST X " --> " Y '|%b| |yesOrNo| '|%d|))) - (SETQ |$compCount| (1- |$compCount|)) - (RETURN U) ))) - (|comp| $x $m $f) - (UNEMBED '|comp|)) - -(defun READ-SPAD (FN FM TO) - (LET ((proplist - (LIST '(FLUID . |true|) - (CONS '|special| (COPY-TREE |$InitialDomainsInScope|))))) - (SETQ |$InteractiveFrame| - (|addBinding| '|$DomainsInScope| proplist - (|addBinding| '|$Information| NIL - (|makeInitialModemapFrame|)))) - (READ-SPAD0 FN 'SPAD FM TO))) - -(defun READ-INPUT (FN FM TO) (READ-SPAD0 FN 'INPUT FM TO)) - -(defun READ-SPAD0 (FN FT FM TO) - (let (($newspad t)) (READ-SPAD1 FN FT FM TO))) - -(defun READ-SPAD-1 () (|New,ENTRY,1|)) - -(defun UNCONS (X) - (COND ((ATOM X) X) - ((EQCAR X 'CONS) (CONS (SECOND X) (UNCONS (THIRD X)))) - (T (ERROR "UNCONS")))) - -(defun OPTIMIZE\&PRINT (X) (PRETTYPRINT (/MDEF X))) - -(defun SPAD-PRINTTIME (A B) - (let (c msg) - (setq C (+ A B)) - (setq MSG (STRCONC "(" (STRINGIMAGE A) " + " (STRINGIMAGE B) - " = " (STRINGIMAGE C) " MS.)")) - (PRINT (STRCONC (STRINGPAD "" (DIFFERENCE 80 (SIZE MSG))) MSG)))) - -(defun SPAD-MODETRAN (X) (D-TRAN X)) - -(defun SPAD-EVAL (X) - (COND ((ATOM X) (EVAL X)) - ((CONS (FIRST X) (MAPCAR #'SPAD-EVAL (CDR X)))))) - -;************************************************************************ -; SYSTEM COMMANDS -;************************************************************************ - -(defun CLEARDATABASE () (OBEY "ERASE MODEMAP DATABASE")) - -(defun erase (FN FT) - (OBEY (STRCONC "ERASE " (STRINGIMAGE FN) " " (STRINGIMAGE FT)))) - -(defun READLISP (UPPER_CASE_FG) - (let (v expr val ) - (setq EXPR (READ-FROM-STRING - (IF UPPER_CASE_FG (string-upcase (line-buffer CURRENT-LINE)) - (line-buffer CURRENT-LINE)) - t nil :start (Line-CURRENT-INDEX CURRENT-LINE))) - (VMPRINT EXPR) - (setq VAL ((LAMBDA (|$InteractiveMode|) (EVAL EXPR)) NIL)) - (FORMAT t "~&VALUE = ~S" VAL) - (TERSYSCOMMAND))) - -(defun TERSYSCOMMAND () - (FRESH-LINE) - (SETQ CHR 'ENDOFLINECHR) - (SETQ TOK 'END_UNIT) - (|spadThrow|)) - -(defun /READ (L Q) -; (SETQ /EDIT-FN (OR (KAR L) /EDIT-FN)) -; (SETQ /EDIT-FT (OR (KAR (KDR L)) 'INPUT)) -; (SETQ /EDIT-FM (OR (KAR (KDR (KDR L))) '*)) -; (SETQ /EDITFILE (LIST /EDIT-FN /EDIT-FT /EDIT-FM)) - (SETQ /EDITFILE L) - (COND - (Q (/RQ)) - ('T (/RF)) ) - (FLAG |boot-NewKEY| 'KEY) - (|terminateSystemCommand|) - (|spadPrompt|)) - -(defun /EDIT (L) - (SETQ /EDITFILE L) - (/EF) - (|terminateSystemCommand|) - (|spadPrompt|)) - -(defun /COMPINTERP (L OPTS) - (SETQ /EDITFILE (/MKINFILENAM L)) - (COND ((EQUAL OPTS "rf") (/RF)) - ((EQUAL OPTS "rq") (/RQ)) - ('T (/RQ-LIB))) - (|terminateSystemCommand|) - (|spadPrompt|)) - -(defun CPSAY (X) (let (n) (if (EQ 0 (setq N (OBEY X))) NIL (PRINT N)))) - -(defun /FLAG (L) - (MAKEPROP (FIRST L) 'FLAGS (LET ((X (UNION (CDR L)))) (GET (FIRST L) 'FLAGS))) - (SAY (FIRST L) " has flags: " X) - (TERSYSCOMMAND)) - -(defun |fin| () - (SETQ *EOF* 'T) - (THROW 'SPAD_READER NIL)) - - -(defun STRINGREST (X) (if (EQ (SIZE X) 1) (make-string 0) (SUBSTRING X 1 NIL))) - -(defun STREAM2UC (STRM) - (LET ((X (ELT (LASTATOM STRM) 1))) (SETELT X 0 (LC2UC (ELT X 0))))) - -(defun NEWNAMTRANS (X) - (COND - ((IDENTP X) (COND ( (GET X 'NEWNAM) (GET X 'NEWNAM)) ('T X))) - ((STRINGP X) X) - ((*VECP X) (MAPVWOC X (FUNCTION NEWNAMTRANS))) - ((ATOM X) X) - ((EQCAR X 'QUOTE)) - (T (CONS (NEWNAMTRANS (FIRST X)) (NEWNAMTRANS (CDR X)))))) - -(defun GP2COND (L) - (COND ((NOT L) (ERROR "GP2COND")) - ((NOT (CDR L)) - (COND ((EQCAR (FIRST L) 'COLON) - (CONS (SECOND L) (LIST (LIST T 'FAIL)))) - (T (LIST (LIST T (FIRST L)))) )) - ((EQCAR (FIRST L) 'COLON) (CONS (CDAR L) (GP2COND (CDR L)))) - (T (ERROR "GP2COND")))) - -(FLAG JUNKTOKLIST 'KEY) - -(defmacro |report| (L) - (SUBST (SECOND L) 'x - '(COND ($reportFlag (sayBrightly x)) ((QUOTE T) NIL)))) - -(defmacro |DomainSubstitutionMacro| (&rest L) - (|DomainSubstitutionFunction| (first L) (second L))) - -(defun |sort| (seq spadfn) - (sort (copy-seq seq) (function (lambda (x y) (SPADCALL X Y SPADFN))))) - -#-Lucid -(defun QUOTIENT2 (X Y) (values (TRUNCATE X Y))) - -#+Lucid -(defun QUOTIENT2 (X Y) ; following to force error check in division by zero - (values (if (zerop y) (truncate 1 Y) (TRUNCATE X Y)))) - -#-Lucid -(define-function 'REMAINDER2 #'REM) - -#+Lucid -(defun REMAINDER2 (X Y) - (if (zerop y) (REM 1 Y) (REM X Y))) - -#-Lucid -(defun DIVIDE2 (X Y) (multiple-value-call #'cons (TRUNCATE X Y))) - -#+Lucid -(defun DIVIDE2 (X Y) - (if (zerop y) (truncate 1 Y) - (multiple-value-call #'cons (TRUNCATE X Y)))) - -(defmacro APPEND2 (x y) `(append ,x ,y)) - -(defmacro |float| (x &optional (y 0.0d0)) `(float ,x ,y)) - -(defun |makeSF| (mantissa exponent) - (|float| (/ mantissa (expt 2 (- exponent))))) - -(define-function 'list1 #'list) -(define-function '|not| #'NOT) - -(defun |random| () (random (expt 2 26))) -(defun \,plus (x y) (+ x y)) -(defun \,times (x y) (* x y)) -(defun \,difference (x y) (- x y)) -(defun \,max (x y) (max x y)) -(defun \,min (x y) (min x y)) -;; This is used in the domain Boolean (BOOLEAN.NRLIB/code.lsp) -(defun |BooleanEquality| (x y) (if x y (null y))) - -(defun S-PROCESS (X) - (let ((|$Index| 0) - (*print-pretty* t) - ($MACROASSOC ()) - ($NEWSPAD T) - (|$compUniquelyIfTrue| nil) - |$currentFunction| - |$topOp| - (|$semanticErrorStack| ()) - (|$warningStack| ()) - (|$returnMode| |$EmptyMode|) - (|$leaveLevelStack| ()) - $TOP_LEVEL |$insideFunctorIfTrue| |$insideExpressionIfTrue| - |$insideCoerceInteractiveHardIfTrue| |$insideWhereIfTrue| - |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| |$form| - (|$e| |$EmptyEnvironment|) - (|$genSDVar| 0) - (|$VariableCount| 0) - (|$previousTime| (TEMPUS-FUGIT))) - (prog ((CURSTRM CUROUTSTREAM) |$s| |$x| |$m| u) - (declare (special CURSTRM |$s| |$x| |$m| CUROUTSTREAM)) - (SETQ |$exitModeStack| ()) - (SETQ |$postStack| nil) - (SETQ |$TraceFlag| T) - (if (NOT X) (RETURN NIL)) - (setq X (if $BOOT (DEF-RENAME (|new2OldLisp| X)) - (|parseTransform| (|postTransform| X)))) - ;; (if |$TranslateOnly| (RETURN (SETQ |$Translation| X))) - (when |$postStack| (|displayPreCompilationErrors|) (RETURN NIL)) - (COND (|$PrintOnly| - (format t "~S =====>~%" |$currentLine|) - (RETURN (PRETTYPRINT X)))) - (if (NOT $BOOT) - (if |$InteractiveMode| - (|processInteractive| X NIL) - (if (setq U (|compTopLevel| X |$EmptyMode| - |$InteractiveFrame|)) - (SETQ |$InteractiveFrame| (third U)))) - (DEF-PROCESS X)) - (if |$semanticErrorStack| (|displaySemanticErrors|)) - (TERPRI)))) - -(MAKEPROP 'END_UNIT 'KEY T) - -(defun |process| (x) - (COND ((NOT (EQ TOK 'END_UNIT)) - (SETQ DEBUGMODE 'NO) - (SPAD_SYNTAX_ERROR) - (if |$InteractiveMode| (|spadThrow|)) - (S-PROCESS x)))) - -(defun |evalSharpOne| (x \#1) (declare (special \#1)) (EVAL x)) - -(setq *PROMPT* 'LISP) - -(defun |New,ENTRY,1| () - (let (ZZ str N RLGENSYMFG RLGENSYMLST |NewFLAG| XCAPE *PROMPT* - SINGLELINEMODE OK ISID NBLNK COUNT CHR ULCASEFG ($LINESTACK 'BEGIN_UNIT) - $TOKSTACK COMMENTCHR TOK LINE BACK INPUTSTREAM XTRANS - XTOKENREADER STACK STACKX TRAPFLAG) - (SETQ XTRANS '|boot-New| - XTOKENREADER 'NewSYSTOK - SYNTAX_ERROR 'SPAD_SYNTAX_ERROR) - (FLAG |boot-NewKEY| 'KEY) - (SETQ *PROMPT* 'Scratchpad-II) - (PROMPT) - (SETQ XCAPE '_) - (SETQ COMMENTCHR 'IGNORE) - (SETQ COLUMN 0) - (SETQ SINGLINEMODE T) ; SEE NewSYSTOK - (SETQ NewFLAG T) - (SETQ ULCASEFG T) - (setq STR (|New,ENTRY,2| '|PARSE-NewEXPR| '|process| curinstream)) - (if (/= 0 (setq N (NOTE STR))) - (progn (SETQ CURINSTREAM (POINTW N CURINSTREAM))) - ) - '|END_OF_New|)) - -(defun |New,ENTRY,2| (RULE FN INPUTSTREAM) (declare (special INPUTSTREAM)) - (let (zz) - (INITIALIZE) - (SETQ $previousTime (TEMPUS-FUGIT)) - (setq ZZ (CONVERSATION '|PARSE-NewExpr| '|process|)) - (REMFLAG |boot-NewKEY| 'KEY) - INPUTSTREAM)) - -(defun INITIALIZE () (init-boot/spad-reader) (initialize-preparse INPUTSTREAM)) - -(setq *prompt* 'new) - -(defmacro try (X) - `(LET ((|$autoLine|)) - (declare (special |$autoLine|)) - (|tryToFit| (|saveState|) ,X))) - -(mapcar #'(lambda (X) (MAKEPROP (CAR X) 'format (CADR X))) - '((COMMENT |formatCOMMENT|) - (SEQ |formatSEQ|) - (DEF |formatDEF|) - (LET |formatLET|) - (\: |formatColon|) - (ELT |formatELT|) - (SEGMENT |formatSEGMENT|) - (COND |formatCOND|) - (SCOND |formatSCOND|) - (QUOTE |formatQUOTE|) - (CONS |formatCONS|) - (|where| |formatWHERE|) - (APPEND |formatAPPEND|) - (REPEAT |formatREPEAT|) - (COLLECT |formatCOLLECT|) - (REDUCE |formatREDUCE|))) - -(defmacro |incTimeSum| (a b) - (if (not |$InteractiveTimingStatsIfTrue|) a - (let ((key b) (oldkey (gensym)) (val (gensym))) - `(prog (,oldkey ,val) - (setq ,oldkey (|incrementTimeSum| ,key)) - (setq ,val ,a) - (|incrementTimeSum| ,oldkey) - (return ,val))))) - -(defun GLESSEQP (X Y) (NOT (GGREATERP X Y))) - -(defun LEXLESSEQP (X Y) (NOT (LEXGREATERP X Y))) - -(defun SETELTFIRST (A B C) (declare (ignore b)) (RPLACA A C)) - -(defun SETELTREST (A B C) (declare (ignore b)) (RPLACD A C)) - -(DEFUN ASSOCIATER (FN LST) - (COND ((NULL LST) NIL) - ((NULL (CDR LST)) (CAR LST)) - ((LIST FN (CAR LST) (ASSOCIATER FN (CDR LST)))))) - -(defun ISLOCALOP-1 (IND) - "Curindex points at character after '.'" - (prog (selector buf termtok (NEWCHR (NEXTCHARACTER))) - (if (TERMINATOR NEWCHR) (RETURN NIL)) - (setq SELECTOR - (do ((x nil)) - (nil) - (if (terminator newchr) - (reverse x) - (push (setq newchr (nextcharacter)) x)))) - (if (EQUAL NEWCHR '\.) (RETURN (ISLOCALOP-1 IND))) - (setq BUF (GETSTR (LENGTH SELECTOR))) - (mapc #'(lambda (x) (suffix x buf)) selector) - (setq buf (copy-seq selector)) - (setq TERMTOK (INTERN BUF)) - (if (NOT (GET TERMTOK 'GENERIC)) (RETURN NIL)) - (if (OR (GET TERMTOK '|Led|) (GET TERMTOK '|Nud|)) - (GET TERMTOK IND)) - (return TERMTOK))) -; **** X. Random tables - -(defvar MATBORCH "*") -(defvar $MARGIN 3) -(defvar $LINELENGTH 71) -(defvar TEMPGENSYMLIST '(|s| |r| |q| |p|)) -(defvar ALPHLIST '(|a| |b| |c| |d| |e| |f| |g|)) -(defvar LITTLEIN " in ") -(defvar INITALPHLIST ALPHLIST) -(defvar INITXPARLST '(|i| |j| |k| |l| |m| |n| |p| |q|)) -(defvar PORDLST (COPY-tree INITXPARLST)) -(defvar INITPARLST '(|x| |y| |z| |u| |v| |w| |r| |s| |t|)) -(defvar LITTLEA '|a|) -(defvar LITTLEI '|i|) -(defvar *TALLPAR NIL) -(defvar ALLSTAR NIL) -(defvar BLANK " ") -(defvar PLUSS "+") -(defvar PERIOD ".") -(defvar SLASH "/") -(defvar COMMA ",") -(defvar LPAR "(") -(defvar RPAR ")") -(defvar EQSIGN "=") -(defvar DASH "-") -(defvar STAR "*") -(defvar DOLLAR "$") -(defvar COLON ":") - -(FLAG TEMPGENSYMLIST 'IS-GENSYM) - -(MAKEPROP 'COND '|Nud| '(|if| |if| 130 0)) -(MAKEPROP 'CONS '|Led| '(CONS CONS 1000 1000)) -(MAKEPROP 'APPEND '|Led| '(APPEND APPEND 1000 1000)) -(MAKEPROP 'TAG '|Led| '(TAG TAG 122 121)) -(MAKEPROP 'EQUATNUM '|Nud| '(|dummy| |dummy| 0 0)) -(MAKEPROP 'EQUATNUM '|Led| '(|dummy| |dummy| 10000 0)) -(MAKEPROP 'LET '|Led| '(:= LET 125 124)) -(MAKEPROP 'RARROW '|Led| '(== DEF 122 121)) -(MAKEPROP 'SEGMENT '|Led| '(\.\. SEGMENT 401 699 (|boot-Seg|))) - -;; NAME: DECIMAL-LENGTH -;; PURPOSE: Computes number of decimal digits in print representation of x -;; This should made as efficient as possible. - -(DEFUN DECIMAL-LENGTH (X) - (LET* ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X)))) - (X (TRUNCATE (ABS X) (EXPT 10 (1- K))))) - (IF (LESSP X 10) K (1+ K)))) - -;(DEFUN DECIMAL-LENGTH2 (X) -; (LET ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X))))) -; (IF (< (ABS X) (EXPT 10 K)) K (1+ K)))) - - -;; function to create byte and half-word vectors in new runtime system 8/90 - -#-:CCL -(defun |makeByteWordVec| (initialvalue) - (let ((n (cond ((null initialvalue) 7) ('t (reduce #'max initialvalue))))) - (make-array (length initialvalue) - :element-type (list 'mod (1+ n)) - :initial-contents initialvalue))) - -#+:CCL -(defun |makeByteWordVec| (initialvalue) - (list-to-vector initialvalue)) - -#-:CCL -(defun |makeByteWordVec2| (maxelement initialvalue) - (let ((n (cond ((null initialvalue) 7) ('t maxelement)))) - (make-array (length initialvalue) - :element-type (list 'mod (1+ n)) - :initial-contents initialvalue))) - -#+:CCL -(defun |makeByteWordVec2| (maxelement initialvalue) - (list-to-vector initialvalue)) - -(defun |knownEqualPred| (dom) - (let ((fun (|compiledLookup| '= '((|Boolean|) $ $) dom))) - (if fun (get (bpiname (car fun)) '|SPADreplace|) - nil))) - -(defun |hashable| (dom) - (memq (|knownEqualPred| dom) - #-Lucid '(EQ EQL EQUAL) - #+Lucid '(EQ EQL EQUAL EQUALP) - )) - -;; simpler interpface to RDEFIOSTREAM -(defun RDEFINSTREAM (&rest fn) - ;; following line prevents rdefiostream from adding a default filetype - (if (null (rest fn)) (setq fn (list (pathname (car fn))))) - (rdefiostream (list (cons 'FILE fn) '(mode . INPUT)))) - -(defun RDEFOUTSTREAM (&rest fn) - ;; following line prevents rdefiostream from adding a default filetype - (if (null (rest fn)) (setq fn (list (pathname (car fn))))) - (rdefiostream (list (cons 'FILE fn) '(mode . OUTPUT)))) - -(defmacro |spadConstant| (dollar n) - `(spadcall (svref ,dollar (the fixnum ,n)))) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/spaderror.lisp b/src/interp/spaderror.lisp new file mode 100644 index 00000000..9d0ec3d3 --- /dev/null +++ b/src/interp/spaderror.lisp @@ -0,0 +1,115 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + + +;; this files contains basic routines for error handling +(in-package "BOOT") + +(defun error-format (message args) + (let ((|$BreakMode| '|break|)) + (declare (special |$BreakMode|)) + (if (stringp message) (apply #'format nil message args) nil))) + +;;(defmacro |trappedSpadEval| (form) form) ;;nop for now + +#+:akcl +(setq |$quitTag| system::*quit-tag*) +#+:akcl +(defun |resetStackLimits| () (system:reset-stack-limits)) +#-:akcl +(setq |$quitTag| (gensym)) +#-:akcl +(defun |resetStackLimits| () nil) + +;; failed union branch -- value returned for numeric failure +(setq |$numericFailure| (cons 1 "failed")) + +(defvar |$oldBreakMode|) + +;; following macro evaluates form returning Union(type-of form, "failed") + +(defmacro |trapNumericErrors| (form) + `(let ((|$oldBreakMode| |$BreakMode|) + (|$BreakMode| '|trapNumerics|) + (val)) + (setq val (catch '|trapNumerics| ,form)) + (if (eq val |$numericFailure|) val + (cons 0 val)))) + +;;;;;; considering this version for kcl +;;(defmacro |trapNumericErrors| (form) +;; `(let ((val)) +;; (setq val (errorset ,form)) +;; (if (NULL val) |$numericFailure| (cons 0 (car val))))) + +;; the following form embeds around the akcl error handler +#+:akcl +(eval-when + (load eval) + (unembed 'system:universal-error-handler) + (embed 'system:universal-error-handler + '(lambda (type correctable? op + continue-string error-string &rest args) + (block + nil + (setq |$NeedToSignalSessionManager| T) + (if (and (boundp '|$inLispVM|) (boundp '|$BreakMode|)) + (cond ((eq |$BreakMode| '|validate|) + (|systemError| (error-format error-string args))) + ((and (eq |$BreakMode| '|trapNumerics|) + (eq type :ERROR)) + (setq |$BreakMode| nil) (throw '|trapNumerics| |$numericFailure|)) + ((and (eq |$BreakMode| '|trapNumerics|) + (boundp '|$oldBreakMode|) + (setq |$BreakMode| |$oldBreakMode|) + nil)) ;; resets error handler + ((and (null |$inLispVM|) + (memq |$BreakMode| '(|nobreak| |query| |resume|))) + (let ((|$inLispVM| T)) ;; turn off handler + (return + (|systemError| (error-format error-string args))))) + ((eq |$BreakMode| '|letPrint2|) + (setq |$BreakMode| nil) + (throw '|letPrint2| nil)))) + (apply system:universal-error-handler type correctable? op + continue-string error-string args ))))) + + + + + + + + + + diff --git a/src/interp/spaderror.lisp.pamphlet b/src/interp/spaderror.lisp.pamphlet deleted file mode 100644 index 618a94e4..00000000 --- a/src/interp/spaderror.lisp.pamphlet +++ /dev/null @@ -1,141 +0,0 @@ -%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/spaderroor.lisp} Pamphlet} -\author{Timothy Daly} - -\begin{document} -\maketitle - -\begin{abstract} -\end{abstract} - -\tableofcontents -\eject - -\section{License} - -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -;; this files contains basic routines for error handling -(in-package "BOOT") - -(defun error-format (message args) - (let ((|$BreakMode| '|break|)) - (declare (special |$BreakMode|)) - (if (stringp message) (apply #'format nil message args) nil))) - -;;(defmacro |trappedSpadEval| (form) form) ;;nop for now - -#+:akcl -(setq |$quitTag| system::*quit-tag*) -#+:akcl -(defun |resetStackLimits| () (system:reset-stack-limits)) -#-:akcl -(setq |$quitTag| (gensym)) -#-:akcl -(defun |resetStackLimits| () nil) - -;; failed union branch -- value returned for numeric failure -(setq |$numericFailure| (cons 1 "failed")) - -(defvar |$oldBreakMode|) - -;; following macro evaluates form returning Union(type-of form, "failed") - -(defmacro |trapNumericErrors| (form) - `(let ((|$oldBreakMode| |$BreakMode|) - (|$BreakMode| '|trapNumerics|) - (val)) - (setq val (catch '|trapNumerics| ,form)) - (if (eq val |$numericFailure|) val - (cons 0 val)))) - -;;;;;; considering this version for kcl -;;(defmacro |trapNumericErrors| (form) -;; `(let ((val)) -;; (setq val (errorset ,form)) -;; (if (NULL val) |$numericFailure| (cons 0 (car val))))) - -;; the following form embeds around the akcl error handler -#+:akcl -(eval-when - (load eval) - (unembed 'system:universal-error-handler) - (embed 'system:universal-error-handler - '(lambda (type correctable? op - continue-string error-string &rest args) - (block - nil - (setq |$NeedToSignalSessionManager| T) - (if (and (boundp '|$inLispVM|) (boundp '|$BreakMode|)) - (cond ((eq |$BreakMode| '|validate|) - (|systemError| (error-format error-string args))) - ((and (eq |$BreakMode| '|trapNumerics|) - (eq type :ERROR)) - (setq |$BreakMode| nil) (throw '|trapNumerics| |$numericFailure|)) - ((and (eq |$BreakMode| '|trapNumerics|) - (boundp '|$oldBreakMode|) - (setq |$BreakMode| |$oldBreakMode|) - nil)) ;; resets error handler - ((and (null |$inLispVM|) - (memq |$BreakMode| '(|nobreak| |query| |resume|))) - (let ((|$inLispVM| T)) ;; turn off handler - (return - (|systemError| (error-format error-string args))))) - ((eq |$BreakMode| '|letPrint2|) - (setq |$BreakMode| nil) - (throw '|letPrint2| nil)))) - (apply system:universal-error-handler type correctable? op - continue-string error-string args ))))) - - - - - - - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/union.lisp b/src/interp/union.lisp index 108d5f07..6698e36d 100644 --- a/src/interp/union.lisp +++ b/src/interp/union.lisp @@ -1,5 +1,7 @@ ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are diff --git a/src/interp/unlisp.lisp b/src/interp/unlisp.lisp new file mode 100644 index 00000000..01e722de --- /dev/null +++ b/src/interp/unlisp.lisp @@ -0,0 +1,1106 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + +;; Uncommon 1.6 +;; This package is a Boot interface for Common Lisp. +;; SMW 1989, 1990 + +;; Operating system interface + +;; The only non-common lisp functions used in this file are in this section. +;; The following functions are provided: + +;; OsRunProgram program &rest args +;; Run the named program with given arguments. +;; All I/O is to the current places. +;; Value returned is implementation-dependent. + +;; OsRunProgramToStream program &rest args +;; Run the named program with given arguments. +;; Input and error output to the current places. +;; Value returned is a stream of the program's standard output. + +;; OsEnvVarCharacter +;; The character which indicates OS environment variables in a string. +;; On Unix this is "$". + +;; OsEnvGet name +;; name is a string or a symbol +;; The string associated with the given name is returned. +;; This is from the environment on Unix. On CMS globalvars could be used. + +;; OsProcessNumber +;; Returns a unique number associated with the current session. +;; On Unix this is the process id. +;; The same workspace started a second time must give a different result. + + + +(IMPORT-MODULE "sys-macros") +(in-package "BOOT") + +(defun |OsRunProgram| (program &rest args) + #+(and :Lucid (not :ibm/370)) (lucid-os-run-program program args) + #+:CmuLisp (cmulisp-os-run-program program args) + #+:KCL (kcl-os-run-program program args) + #-(or (and :Lucid (not :ibm/370)) :CmuLisp :KCL) nil ) + +(defun |OsRunProgramToStream| (program &rest args) + #+(and :Lcid (not ibm/370)) + (lucid-os-run-program-to-stream program args) + #+:CmuLisp (cmulisp-os-run-program-to-stream program args) + #+:KCL (kcl-os-run-program-to-stream program args) + #-(or (and :Lucid (not :ibm/370)) :CmuLisp :KCL) + (make-string-output-stream "") ) + +;Unix: +(defvar |OsEnvVarCharacter| #\$) + +(defun |OsEnvGet| (sym) + #+(and :Lucid (not :ibm/370)) (lucid-os-env-get sym) + #+:CmuLisp (cmulisp-os-env-get sym) + #+:KCL (kcl-os-env-get sym) + #-(or (and :Lucid (not :ibm/370)) :CmuLisp :KCL) "" ) + +(defun |OsProcessNumber| () + #+(and :Lucid (not :ibm/370)) (lucid-os-process-number) + #+:CmuLisp (cmulisp-os-process-number) + #+:KCL (kcl-os-process-number) + #-(or (and :Lucid (not :ibm/370)) :CmuLisp :KCL) 42 ) + +;;; +;;; Lucid-only implementations +;;; + +#+(and :Lucid (not :ibm/370)) (progn +(defun lucid-os-run-program (program args) + (system:run-aix-program program :arguments args)) + +(defun lucid-os-run-program-to-stream (program args) + (system:run-aix-program program + :wait nil + :output :stream + :arguments args)) + +(defun lucid-os-env-get (sym) + (c-to-lisp-string (getenv (string sym))) ) + +(defun lucid-os-process-number () + (getpid)) + +(system:define-foreign-function :c 'getenv :pointer) +(system:define-foreign-function :c 'sprintf :pointer) +(system:define-foreign-function :c 'strlen :fixnum) +(system:define-foreign-function :c 'getpid :fixnum) + +(defun c-to-lisp-string (ptr) + (let (str len) + (setq len (strlen ptr)) + (setq str (make-array (list len) :element-type 'character)) + (sprintf str "%s" ptr) ; Cannot use strcpy because it stops in a \0. + str )) +) + +;;; +;;; Cmulisp-only implementations +;;; + +#+:CmuLisp (progn +(defun cmulisp-os-run-program (program args) + (extensions:run-program program args + :input 't ; use current standard input -- default is /dev/null + :output 't ; use current standard output + :error 't )) ; use current standard error + +(defun cmulisp-os-run-program-to-stream (program args) + (second (multiple-value-list + (extensions:run-program program args + :wait nil ; don't wait + :input 't ; use current standard input + :output :stream ; slurp the output of the process + :error 't )) )) ; use current standard error + +(defun cmulisp-os-env-get (sym) + (let ((key (intern (string sym) (find-package "KEYWORD")))) + (cdr (assoc key *environment-list* :test #'eq)) )) + +(defun cmulisp-os-process-number () + (Aix::Unix-getpid) ) +) + +;;; +;;; KCL-only implementations +;;; + +#+:KCL (progn +(defun kcl-os-run-program (program args) + (system (format nil "~{~a ~}" (cons program args))) ) + +(defun kcl-os-run-program-to-stream (program args) + (system (format nil "~{~a ~}" (cons program args))) ) + +(defun kcl-os-env-get (sym) + (system:getenv (string sym)) ) + +(defun kcl-os-process-number () + 77 ) + +;(defentry |getpid| () (int "getpid")) +) + +;;;; +;;;; Time +;;;; + +(defun |TimeStampString| () + (multiple-value-bind (sec min hr mody mo yr wkdy daylight zone) + (get-decoded-time) + (declare (ignore wkdy daylight zone)) + (format nil "~2,'0d/~2,'0d/~2,'0d ~2,'0d:~2,'0d:~2,'0d" + yr mo mody hr min sec) )) + +;;;; +;;;; File system interface +;;;; + +;;(defun |FileExists?| (path) +;; (probe-file path) ) +;; +;;(defun |FileRemove| (path) +;; (delete-file path) ) +;; +;;(defun |FileRename| (oldpath newpath) +;; (rename-file oldpath newpath) ) +;; +;;(defun |FileAbsolutePath| (path) +;; (truename path) ) +;; +;;(defun |FileDate| (path) +;; (file-write-date path) ) +;; +;;(defun |TextFileOpenIn| (path) +;; (open path +;; :element-type 'character +;; :direction :input )) +;; +;;(defun |TextFileOpenOut| (path) +;; (open path +;; :element-type 'character +;; :direction :output +;; :if-exists :supersede +;; :if-does-not-exist :create )) +;; +;;(defun |TextFileOpenIO| (path) +;; (open path +;; :element-type 'character +;; :direction :io +;; :if-exists :overwrite ; open at beginning +;; :if-does-not-exist :create )) +;; +;;(defun |TextFileOpenAppend| (path) +;; (open path +;; :element-type 'character +;; :direction :output +;; :if-exists :append +;; :if-does-not-exist :create )) +;; +;; +;;(defun |ByteFileOpenIn| (path) +;; (open path +;; :element-type 'unsigned-byte +;; :direction :input )) +;; +;;(defun |ByteFileOpenOut| (path) +;; (open path +;; :element-type 'unsigned-byte +;; :direction :output +;; :if-exists :supersede +;; :if-does-not-exist :create )) +;; +;;(defun |ByteFileOpenIO| (path) +;; (open path +;; :element-type 'unsigned-byte +;; :direction :io +;; :if-exists :overwrite ; open at beginning +;; :if-does-not-exist :create )) +;; +;;(defun |ByteFileOpenAppend| (path) +;; (open path +;; :element-type 'unsigned-byte +;; :direction :output +;; :if-exists :append +;; :if-does-not-exist :create )) +;; +;;(defun |ReadFileLineAt| (path pos) +;; (with-open-file (stream path :direction :input) +;; (file-position stream pos) +;; (read-line stream) )) +;; +;;(defun |UserHomeDirectory| () +;; (pathname-directory (user-homedir-pathname)) ) +;; +;;(defun |DirectoryFiles| (path) +;; (directory path) ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Lisp Interface +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun |LispReadFromString| (str &optional (startpos 0)) + (prog (ob nextpos) + (multiple-value-setq + (ob nextpos) + (read-from-string str nil nil :start startpos) ) + (return (list ob nextpos)) )) + +(defun |LispEval| (expr) + (eval expr) ) + +;;; expr must be a defun, defmacro, etc. +(defun |LispCompile| (expr) + (eval expr) + (compile (second expr)) ) + +(defun |LispLoadFileQuietly| (object) + (load object :verbose nil :print nil)) + +(defun |LispCompileFile| (fname) + (compile-file fname) ) + +(defun |LispLoadFile| (fname) + (load fname) ) + +(defun |LispKeyword| (str) + (intern str 'keyword) ) + +;;; +;;; Control +;;; + + +(defmacro |funcall| (&rest args) + (cons 'funcall args) ) + +(defmacro |Catch| (tag expr) + `(catch ,tag ,expr) ) + +(defmacro |Throw| (tag expr) + `(Throw ,tag ,expr) ) + +(defmacro |UnwindProtect| (a b) + `(unwind-protect ,a ,b) ) + +;;; This macro catches as much as it can. +;;; Systems with a catchall should use it. +;;; It is legitimate to not catch anything, if there is no system support. +;;; +;;; If the result was caught, then tagvar is set to the desination tag +;;; and the thown value is returned. Otherwise, tagvar is set to nil +;;; and the first result of the expression is returned. + +#+:Lucid +(defmacro |CatchAsCan| (tagvar expr) + `(let ((catch-result nil) + (expr-result nil) + (normal-exit (gensym))) + + (setq catch-result + (catch 'lucid::top-level + (setq expr-result ,expr) + normal-exit)) + (cond + ((eq catch-result normal-exit) + (setq ,tagvar nil) + expr-result ) + ('t + (setq ,tagvar 'lucid::top-level) + catch-result )) )) + +#-:Lucid +(defmacro |CatchAsCan| (tagvar expr) + `(progn + (setq tagvar nil) + ,expr )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; General +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmacro |Eq| (a b) + `(eq ,a ,b) ) + +(defvar |Nil| nil) + +(defun |DeepCopy| (x) + (copy-tree x) ) + +(defun |SortInPlace| (l pred) + (sort l pred) ) + +(defun |Sort| (l pred) + (sort (copy-tree l) pred) ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Streams +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defun |Prompt| (line &optional (readfn nil)) + (format *query-io* "~a" line) + (when readfn (apply readfn (list *query-io*))) ) + +(defun |PlainError| (&rest args) + (let ((fmt (plain-print-format-string args))) + (error fmt args) )) + +(defun |PrettyPrint| (expr &optional (outstream *standard-output*)) + (write expr :stream outstream :level nil :length nil :pretty 't :escape 't) + (finish-output outstream) ) + +(defun |PlainPrint| (&rest args) + (let ((fmt (plain-print-format-string args))) + (format *standard-output* fmt args) )) + +(defun |PlainPrintOn| (stream &rest args) + (let ((fmt (plain-print-format-string args))) + (format stream fmt args) )) + +(defun plain-print-format-string (l) + (format nil "~~~d{~~a~~}~~%" (length l)) ) + + +;;; Lucid 1.01 bug: Must flush output after each write or else +;;; strange errors arise from invalid buffer reuse. + +(defmacro |WriteByte| (byte &rest outstream) + `(write-byte ,byte ,@outstream) ) + +(defmacro |WriteChar| (char &rest outstream) + `(write-char ,char ,@outstream) ) + +;; Write a string -- no new line. +(defun |WriteString| (string &optional (outstream *standard-output*)) + (format outstream "~a" string) + (finish-output outstream) ) + +;; Write a string then start a new line. +(defun |WriteLine| (string &optional (outstream *standard-output*)) + (write-line string outstream) + (finish-output outstream) ) + +(defun |ByteFileWriteLine| (string outstream) + (let ((n (length string))) + (do ((i 0 (+ i 1))) + ((= i n)) + (write-byte (char-code (char string i)) outstream) )) + (write-byte (char-code #\Newline) outstream) + (finish-output outstream) ) + + +(defmacro |ReadByte| (instream) + `(read-byte ,instream nil nil) ) + +(defmacro |ReadChar| (&rest instream) + (if instream + `(read-char ,@instream nil nil) + '(read-char *standard-input* nil nil) )) + +(defun |ReadLine| (&optional (instream *standard-input*)) + (read-line instream nil nil) ) + +(defun |ByteFileReadLine| (instream) + (do ((buf (make-array '(80) + :element-type 'character + :fill-pointer 0 + :adjustable 't )) + (b (read-byte instream nil nil) (read-byte instream nil nil)) + (c) ) + + ((or (null b) (char= (setq c (code-char b)) #\Newline)) buf) + + (vector-push-extend c buf) )) + +;;; Reads no more than the rest of the current line into the string argument. +;;; The #\Newline is not included in the string. +;;; +;;; The result is an integer, 'T or nil. +;;; Nil the stream was already exhausted. +;;; T the string was filled before the end of line was reached. +;;; k the end of line was reached and k characters were copied. +;;; +;;; If the argument "flags" is passed a cons cell, it is updated +;;; to contain (Eof . Eol). +;;; Eof indicates whether the end of file was detected. +;;; Eol indicates whether the line was terminated by a #\newline. + +(defun |ReadLineIntoString| (string &optional (instream *standard-input*) + (flags nil) ) + + (when (consp flags) (rplaca flags nil) (rplacd flags nil)) + + (let ((n (length string)) + (i 0) + (c (read-char instream nil nil)) ) + + (loop + (cond + ((null c) + (when (consp flags) (rplaca flags 't)) + (return (if (= i 0) nil i)) ) + ((char= c #\Newline) + (when (consp flags) (rplacd flags 't)) + (return i) ) + ((= i n) + (unread-char c instream) + (return 't) )) + + (setf (char string i) c) + (setq i (+ i 1)) + (setq c (read-char instream nil nil)) ))) + + +;;; Similar to ReadLineIntoString but reads from a ByteFile. +(defun |ByteFileReadLineIntoString| (string instream &optional (flags nil)) + + (when (consp flags) (rplaca flags nil) (rplacd flags nil)) + + (let ((n (length string)) + (i 0) + (b nil) + (c nil) ) + + (loop + (when (= i n) (return 't) ) + (setq b (read-byte instream nil nil)) + (when (null b) + (when (consp flags) (rplaca flags 't)) + (return i) ) + + (setq c (code-char b)) + (when (char= c #\Newline) + (when (consp flags) (rplacd flags 't)) + (return i) ) + + (setf (char string i) c) + (setq i (+ i 1)) ))) + +(defun |ReadBytesIntoVector| + (vector &optional (instream *standard-input*) (flags nil) ) + + (when (consp flags) (rplaca flags nil) (rplacd flags nil)) + + (let ((n (length vector)) + (i 0) + (b nil) ) + + (loop + (when (= i n) (return 't)) + (setq b (read-byte instream nil nil)) + (when (null b) + (when (consp flags) (rplaca flags 't)) + (return i) ) + + (setf (aref vector i) b) + (setq i (+ i 1)) ))) + + +(defun |InputStream?| (stream) + (input-stream-p stream) ) + +(defun |OutputStream?| (stream) + (output-stream-p stream) ) + +;;; Whether the position is a record number or character number is +;;; implementation specific. In Common Lisp it is a character number. + +(defun |StreamGetPosition| (stream) + (file-position stream) ) + +(defun |StreamSetPosition| (stream pos) + (file-position stream pos)) + +(defun |StreamSize| (stream) + (file-length stream)) + +(defmacro |WithOpenStream| (var stream-form body) + `(with-open-stream (,var ,stream-form) ,body) ) + +;;; Copy up to n characters or eof. +;;; Return number of characters actually copied +(defun |StreamCopyChars| (instream outstream n) + (do ((i 0 (+ i 1)) + (c (read-char instream nil nil) (read-char instream nil nil)) ) + ((or (null c) (= i n)) (finish-output outstream) i) + + (write-char c outstream) )) + +(defun |StreamCopyBytes| (instream outstream n) + (do ((i 0 (+ i 1)) + (b (read-byte instream nil nil) (read-byte instream nil nil)) ) + ((or (null b) (= i n)) (finish-output outstream) i) + + (write-byte b outstream) )) + +(defun |StreamEnd?| (instream) + (null (peek-char nil instream nil nil)) ) + +(defun |StreamFlush| (&optional (outstream *standard-output*)) + (finish-output outstream) ) + +(defun |StreamClose| (stream) + (close stream) ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Types +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Functions for manipulating values of type Xxxx are prefixed with Xxxx. +;;; E.g., CsetUnion +;;; Values of type Xxxx are suffixed with Xxxx. +;;; E.g., AlphaCset +;;; The primary function for creating object of this type is named Xxxx. +;;; The type-testing predicate is Xxxx? + +;;; xx := Xxxx(args) +;;; val := XxxxGet(xx, key) or XxxxGet(xx, key, default) +;;; val := XxxxSet(xx, key, val) +;;; val := XxxxUnset(xx, key) +;;; +;;; xx := XxxxRemove(val, xx) XxxxRemoveQ +;;; truth := XxxxMember?(val, xx) XxxxMemberQ? +;;; xx := XxxxUnion(xx1, xx2) +;;; +;;; The suffix "Q" means the test involved is "EQ". "N" between the +;;; the type name and the function name proper means the function is +;;; non-copying (destructive). + +;;; +;;; Pathnames +;;; + +(defvar |TempFileDirectory| (pathname-directory "/tmp/")) +(defvar |LispFileType| "lisp") +(defvar |FaslFileType| "bbin") + +(defun |Pathname| (name &optional (type nil) (dir 'none)) + (if (equal dir 'none) + (make-pathname :name name :type type :defaults name) + (make-pathname :directory dir :name name :type type) )) + +(defun |ToPathname| (string) + (pathname string) ) + +;;; System-wide unique name on each call. +(defvar *new-pathname-counter* 1) + +(defun |NewPathname| (&optional (prefix "t")(type nil)(dir '(:relative))) + (let ((name + (format nil "~a~a-~a" + prefix (|OsProcessNumber|) *new-pathname-counter* ))) + (setq *new-pathname-counter* (+ *new-pathname-counter* 1)) + (make-pathname :directory dir :name name :type type) )) + +;;; System-wide unique name for the current session. +(defun |SessionPathname| (&optional (prefix "t")(type nil)(dir '(:relative))) + (let ((name (format nil "~a~a" prefix (|OsProcessNumber|)))) + (make-pathname :directory dir :name name :type type) )) + +(defun |PathnameDirectory| (path) + (pathname-directory path) ) + +(defun |PathnameName| (path) + (pathname-name path) ) + +(defun |PathnameType| (path) + (pathname-type path) ) + + +(defun |PathnameWithType| (path type) + (make-pathname :type type :defaults path) ) + +(defun |PathnameWithoutType| (path) + (make-pathname :type nil :defaults path) ) + + +(defun |PathnameWithDirectory| (path dir) + (make-pathname :directory dir :defaults path) ) + +(defun |PathnameWithoutDirectory| (path) + (make-pathname :directory nil :defaults path) ) + + +(defun |PathnameString| (path) + (namestring path) ) + +(defun |PathnameToUsualCase| (path) + (pathname (|StringLowerCase| (namestring path))) ) + + +;; Lucid 1.01 specific -- uses representation of directories. +(defun |PathnameAbsolute?| (path) + (let ((dir (pathname-directory path))) + (not (and (consp dir) (or + (eq (car dir) :current) + (eq (car dir) :relative) ))) )) + +;; Lucid 1.01 specific -- uses representation of directories. +(defun |PathnameWithinDirectory| (dir relpath) + (if (|PathnameAbsolute?| relpath) + (|PlainError| "The path " relpath " cannot be used within directory " dir) + (make-pathname + :directory (append dir (cdr (pathname-directory relpath))) + :defaults relpath ))) + +;; Unix specific -- uses unix file syntax. +(defun |PathnameDirectoryOfDirectoryPathname| (dirpath) + (pathname-directory + (concatenate 'string (namestring dirpath) "/junk.bar") )) + +;; Unix specific -- uses environment variables. +(defun |PathnameWithinOsEnvVar| (varname relpath) + (let ((envstr (|OsEnvGet| varname))) + (parse-namestring (concatenate 'string envstr "/" relpath)) )) + +;;; +;;; Symbols +;;; + + +;;!! Worry about packages a later day. +;;!! For now, the responsibility of setting *package* is on the caller. +(defun |MakeSymbol| (str) + (let ((a (intern str))) a) ) ; Return only 1 value + +(defmacro |Symbol?| (ob) + `(and ,ob (symbolp ,ob)) ) + +(defmacro |SymbolString| (sym) + `(string ,sym) ) + +;;; +;;; Bits +;;; +(defmacro |Bit| (x) + (cond + ((eq x 1) 1) + ((eq x 0) 0) + (x 1) + (t 0))) + +(defun |Bit?| (x) + (or (eql x 1) (eql x 0)) ) + +(defvar |TrueBit| 1) +(defvar |FalseBit| 0) + +(defmacro |BitOn?| (b) `(eq ,b 1)) + +(defmacro |BitOr| (x y) + `(bit-ior ,x ,y) ) + +;;; +;;; General Sequences +;;; +;; ELT and SETELT work on these. + +;; Removed because it clashed with size in vmlisp.lisp +;; (defun SIZE (x) ;; #x in boot generates (SIZE x) +;; (length x)) + +;;; +;;; Vectors +;;; +(defun |FullVector| (size &optional (init nil)) + (make-array + (list size) + :element-type 't + :initial-element init )) + +(defun |Vector?| (x) + (vectorp x) ) + +;;; +;;; Bit Vectors +;;; + +;; Common Lisp simple bit vectors + +(defun |FullBvec| (size &optional (init 0)) + (make-array + (list size) + :element-type 'bit + :initial-element init )) + +;;; +;;; Characters +;;; + +;;(defun |char| (x) +;; (char (string x) 0) ) + +(defmacro |Char| (x) + `(char (string ,x) 0) ) + +(defmacro |Char?| (c) + `(characterp ,c) ) + ;; (or (characterp a) + ;; (and (symbolp a) (= (length (symbol-name a)) 1)))) + + +(defmacro |CharCode| (c) + `(char-code ,c) ) + +(defmacro |CharGreater?| (c1 c2) + `(char> ,c1 ,c2) ) + +(defun |CharDigit?| (x) + (or + (and (characterp x) (digit-char-p x)) + (and (stringp x) (= (length x) 1) (digit-char-p (char x 0))) + (and (symbolp x) (|CharDigit?| (string x))) )) + +(defvar |SpaceChar| #\Space) +(defvar |NewlineChar| #\Newline) + +;;; +;;; Character Sets +;;; + +(defun |Cset| (str) + (let + ((cset (make-array + (list char-code-limit) + :element-type 'bit + :initial-element 0 )) + (len (length str)) ) + + (do ((i 0 (+ 1 i))) + ((= i len)) + (setf (sbit cset (char-code (char str i))) 1) ) + cset )) + +(defun |CsetMember?| (c cset) + (eql 1 (sbit cset (char-code c))) ) + +(defun |CsetUnion| (cset1 cset2) + (bit-ior cset1 cset2) ) + +(defun |CsetComplement| (cset) + (bit-not cset) ) + +(defun |CsetString| (cset) + (let + ((chars '()) + (len (length cset))) + (do ((i 0 (+ 1 i))) + ((= i len)) + (if (eql 1 (sbit cset i)) (push (string (code-char i)) chars)) ) + (apply #'concatenate (cons 'string (nreverse chars))) )) + +(defvar |NumericCset| (|Cset| "0123456789") ) +(defvar |LowerCaseCset| (|Cset| "abcdefghijklmnopqrstuvwxyz") ) +(defvar |UpperCaseCset| (|Cset| "ABCDEFGHIJKLMNOPQRSTUVWXYZ") ) +(defvar |AlphaCset| (|CsetUnion| |LowerCaseCset| |UpperCaseCset|)) +(defvar |AlphaNumericCset| (|CsetUnion| |AlphaCset| |NumericCset|) ) +(defvar |WhiteSpaceCset| + (|Cset| (coerce + (list #\Space #\Newline #\Tab #\Page #\Linefeed #\Return #\Backspace) + 'string )) ) + +;;; +;;; Character Strings +;;; + +;; Common Lisp simple strings +;; ELT and SETELT work on these. + + +(defun |FullString| (size &optional (init #\Space)) + (make-array + (list size) + :element-type 'character + :initial-element init )) + +(defun |ToString| (ob) + (string ob) ) + +(defun |StringImage| (ob) + (format nil "~a" ob) ) + +(defun |String?| (ob) + (stringp ob) ) + +(defmacro |StringGetCode| (str ix) + `(char-code (char ,str ,ix)) ) + +(defun |StringConcat| (&rest l) + (progn + (setq l (mapcar #'string l)) + (apply #'concatenate 'string l) )) + +(defun |StringFromTo| (string from to) + (subseq string from (+ to 1)) ) + +(defun |StringFromToEnd| (string from) + (subseq string from) ) + +(defun |StringFromLong| (string from len) + (subseq string from (+ from len)) ) + +(defun |StringPrefix?| (pref string) + (let ((mm (mismatch pref string))) + (or (not mm) (eql mm (length pref))) )) + +(defun |StringUpperCase| (l) + (cond ((stringp l) (string-upcase l)) + ((symbolp l) (intern (string-upcase (symbol-name l)))) + ((characterp l) (char-upcase l)) + ((atom l) l) + (t (mapcar #'|StringUpperCase| l)) )) + +(defun |StringLowerCase| (l) + (cond ((stringp l) (string-downcase l)) + ((symbolp l) (intern (string-downcase (symbol-name l)))) + ((characterp l) (char-downcase L)) + ((atom l) l) + (t (mapcar #'|StringLowerCase| l)) )) + +(defun |StringGreater?| (s1 s2) + (string> s1 s2) ) + +(defun |StringToInteger| (s) + (read-from-string s) ) + +(defun |StringToFloat| (s) + (read-from-string s) ) + +(defun |StringLength| (s) + (length s) ) + +;;; +;;; Numbers +;;; + + + +(defmacro |Number?| (x) `(numberp ,x)) +(defmacro |Integer?| (x) `(integerp ,x)) +(defmacro |Float?| (x) `(floatp ,x)) + +(defmacro |Odd?| (n) `(oddp ,n)) +(defmacro |Remainder|(a b) `(rem ,a ,b)) + +(defmacro |DoublePrecision| (x) `(coerce ,x 'double-precision)) + +(defmacro |Abs| (x) `(abs ,x)) +(defmacro |Min| (x &rest yz) `(min ,x ,@yz)) +(defmacro |Max| (x &rest yz) `(max ,x ,@yz)) + +(defmacro |Exp| (x) `(exp ,x)) +(defmacro |Ln| (x) `(log ,x)) +(defmacro |Log10| (x) `(log ,x 10)) +(defmacro |Sin| (x) `(sin ,x)) +(defmacro |Cos| (x) `(cos ,x)) +(defmacro |Tan| (x) `(tan ,x)) +(defmacro |Cotan| (x) `(/ 1.0 (tan ,x))) +(defmacro |Arctan|(x) `(atan ,x)) + +;;; +;;; Pairs +;;; + +(defmacro |Pair?| (x) `(consp ,x)) + +(defmacro |car| (x) `(car ,x)) +(defmacro |cdr| (x) `(cdr ,x)) + +(defmacro |caar| (x) `(caar ,x)) +(defmacro |cadr| (x) `(cadr ,x)) +(defmacro |cdar| (x) `(cdar ,x)) +(defmacro |cddr| (x) `(cddr ,x)) + +(defmacro |caaar| (x) `(caaar ,x)) +(defmacro |caadr| (x) `(caadr ,x)) +(defmacro |cadar| (x) `(cadar ,x)) +(defmacro |caddr| (x) `(caddr ,x)) +(defmacro |cdaar| (x) `(cdaar ,x)) +(defmacro |cdadr| (x) `(cdadr ,x)) +(defmacro |cddar| (x) `(cddar ,x)) +(defmacro |cdddr| (x) `(cdddr ,x)) + +(defmacro |FastCar| (x) `(car (the cons ,x))) +(defmacro |FastCdr| (x) `(cdr (the cons ,x))) + +(defmacro |FastCaar| (x) `(|FastCar| (|FastCar| ,x))) +(defmacro |FastCadr| (x) `(|FastCar| (|FastCdr| ,x))) +(defmacro |FastCdar| (x) `(|FastCdr| (|FastCar| ,x))) +(defmacro |FastCddr| (x) `(|FastCdr| (|FastCdr| ,x))) + +(defmacro |FastCaaar| (x) `(|FastCar| (|FastCaar| ,x))) +(defmacro |FastCaadr| (x) `(|FastCar| (|FastCadr| ,x))) +(defmacro |FastCadar| (x) `(|FastCar| (|FastCdar| ,x))) +(defmacro |FastCaddr| (x) `(|FastCar| (|FastCddr| ,x))) +(defmacro |FastCdaar| (x) `(|FastCdr| (|FastCaar| ,x))) +(defmacro |FastCdadr| (x) `(|FastCdr| (|FastCadr| ,x))) +(defmacro |FastCddar| (x) `(|FastCdr| (|FastCdar| ,x))) +(defmacro |FastCdddr| (x) `(|FastCdr| (|FastCddr| ,x))) + +(defmacro |IfCar| (x) `(if (consp ,x) (car ,x))) +(defmacro |IfCdr| (x) `(if (consp ,x) (cdr ,x))) + +(defmacro |EqCar| (l a) `(eq (car ,l) ,a)) +(defmacro |EqCdr| (l d) `(eq (cdr ,l) ,d)) + +;;; +;;; Lists +;;; + + +(defun |ListNReverse| (l) + (nreverse l) ) + +(defun |ListIsLength?| (l n) + (if l (= n 0) (|ListIsLength?| (cdr l) (1- n))) ) + +;;--------------------> NEW DEFINITION (override in vmlisp.lisp.pamphlet) +(defun |ListMemberQ?| (ob l) + (member ob l :test #'eq) ) + +(defun |ListRemoveQ| (ob l) + (remove ob l :test #'eq :count 1) ) + +(defun |ListNRemoveQ| (ob l) + (delete ob l :test #'eq :count 1) ) + +(defun |ListRemoveDuplicatesQ| (l) + (remove-duplicates l :test #'eq) ) + +(defun |ListUnion| (l1 l2) + (union l1 l2 :test #'equal) ) + +(defun |ListUnionQ| (l1 l2) + (union l1 l2 :test #'eq) ) + +(defun |ListIntersection| (l1 l2) + (intersection l1 l2 :test #'equal) ) + +(defun |ListIntersectionQ| (l1 l2) + (intersection l1 l2 :test #'eq) ) + +(defun |ListAdjoin| (ob l) + (adjoin ob l :test #'equal) ) + +(defun |ListAdjoinQ| (ob l) + (adjoin ob l :test #'eq) ) + +;;; +;;; Association lists +;;; + + +(defun |AlistAssoc| (key l) + (assoc key l :test #'equal) ) + +;;--------------------> NEW DEFINITION (override in vmlisp.lisp.pamphlet) +(defun |AlistAssocQ| (key l) + (assoc key l :test #'eq) ) + +(defun |AlistRemove| (key l) + (let ((pr (assoc key l :test #'equal))) + (if pr + (remove pr l :test #'equal) + l) )) + +(defun |AlistRemoveQ| (key l) + (let ((pr (assoc key l :test #'eq))) + (if pr + (remove pr l :test #'eq) + l) )) + +(defun |AlistAdjoinQ| (pr l) + (cons pr (|AlistRemoveQ| (car pr) l)) ) + +(defun |AlistUnionQ| (l1 l2) + (union l1 l2 :test #'eq :key #'car) ) + +;;; +;;; Tables +;;; + +;;(defmacro |EqTable| () +;; `(make-hash-table :test #'eq) ) +;;(defmacro |EqualTable| () +;; `(make-hash-table :test #'equal) ) +;;(defmacro |StringTable| () +;; `(make-hash-table :test #'equal) ) +;; following is not used and causes CCL problems +;;(defmacro |SymbolTable| () +;; `(make-hash-table :test #'eq) ) + + +(defmacro |Table?| (ob) + `(hash-table-p ,ob) ) + +(defmacro |TableCount| (tab) + `(hash-table-count ,tab) ) + +(defmacro |TableGet| (tab key &rest default) + `(gethash ,key ,tab ,@default) ) + +(defmacro |TableSet| (tab key val) + `(setf (gethash ,key ,tab) ,val) ) + +(defun |TableUnset| (tab key) + (let ((val (gethash key tab))) + (remhash key tab) + val )) + +(defun |TableKeys| (tab) + (let ((key-list nil)) + (maphash + #'(lambda (key val) (declare (ignore val)) + (setq key-list (cons key key-list)) ) + tab ) + key-list )) + +;; CCL supplies a slightly more efficient version of logs to base 10, which +;; is useful in the WIDTH function. MCD. +#+:KCL (defun log10 (u) (log u 10)) diff --git a/src/interp/unlisp.lisp.pamphlet b/src/interp/unlisp.lisp.pamphlet deleted file mode 100644 index 6123b927..00000000 --- a/src/interp/unlisp.lisp.pamphlet +++ /dev/null @@ -1,1134 +0,0 @@ -%% Oh Emacs, this is a -*- Lisp -*- file, despite appearance. -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/unlisp.lisp} Pamphlet} -\author{Stephen M. Watt, Timothy Daly} - -\begin{document} -\maketitle - -\begin{abstract} -\end{abstract} - -\tableofcontents -\eject - -\begin{verbatim} -Uncommon 1.6 -This package is a Boot interface for Common Lisp. -SMW 1989, 1990 - -Operating system interface - -The only non-common lisp functions used in this file are in this section. -The following functions are provided: - - OsRunProgram program &rest args - Run the named program with given arguments. - All I/O is to the current places. - Value returned is implementation-dependent. - - OsRunProgramToStream program &rest args - Run the named program with given arguments. - Input and error output to the current places. - Value returned is a stream of the program's standard output. - - OsEnvVarCharacter - The character which indicates OS environment variables in a string. - On Unix this is "$". - - OsEnvGet name - name is a string or a symbol - The string associated with the given name is returned. - This is from the environment on Unix. On CMS globalvars could be used. - - OsProcessNumber - Returns a unique number associated with the current session. - On Unix this is the process id. - The same workspace started a second time must give a different result. - -\end{verbatim} - -\section{License} - -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -(IMPORT-MODULE "sys-macros") -(in-package "BOOT") - -(defun |OsRunProgram| (program &rest args) - #+(and :Lucid (not :ibm/370)) (lucid-os-run-program program args) - #+:CmuLisp (cmulisp-os-run-program program args) - #+:KCL (kcl-os-run-program program args) - #-(or (and :Lucid (not :ibm/370)) :CmuLisp :KCL) nil ) - -(defun |OsRunProgramToStream| (program &rest args) - #+(and :Lcid (not ibm/370)) - (lucid-os-run-program-to-stream program args) - #+:CmuLisp (cmulisp-os-run-program-to-stream program args) - #+:KCL (kcl-os-run-program-to-stream program args) - #-(or (and :Lucid (not :ibm/370)) :CmuLisp :KCL) - (make-string-output-stream "") ) - -;Unix: -(defvar |OsEnvVarCharacter| #\$) - -(defun |OsEnvGet| (sym) - #+(and :Lucid (not :ibm/370)) (lucid-os-env-get sym) - #+:CmuLisp (cmulisp-os-env-get sym) - #+:KCL (kcl-os-env-get sym) - #-(or (and :Lucid (not :ibm/370)) :CmuLisp :KCL) "" ) - -(defun |OsProcessNumber| () - #+(and :Lucid (not :ibm/370)) (lucid-os-process-number) - #+:CmuLisp (cmulisp-os-process-number) - #+:KCL (kcl-os-process-number) - #-(or (and :Lucid (not :ibm/370)) :CmuLisp :KCL) 42 ) - -;;; -;;; Lucid-only implementations -;;; - -#+(and :Lucid (not :ibm/370)) (progn -(defun lucid-os-run-program (program args) - (system:run-aix-program program :arguments args)) - -(defun lucid-os-run-program-to-stream (program args) - (system:run-aix-program program - :wait nil - :output :stream - :arguments args)) - -(defun lucid-os-env-get (sym) - (c-to-lisp-string (getenv (string sym))) ) - -(defun lucid-os-process-number () - (getpid)) - -(system:define-foreign-function :c 'getenv :pointer) -(system:define-foreign-function :c 'sprintf :pointer) -(system:define-foreign-function :c 'strlen :fixnum) -(system:define-foreign-function :c 'getpid :fixnum) - -(defun c-to-lisp-string (ptr) - (let (str len) - (setq len (strlen ptr)) - (setq str (make-array (list len) :element-type 'character)) - (sprintf str "%s" ptr) ; Cannot use strcpy because it stops in a \0. - str )) -) - -;;; -;;; Cmulisp-only implementations -;;; - -#+:CmuLisp (progn -(defun cmulisp-os-run-program (program args) - (extensions:run-program program args - :input 't ; use current standard input -- default is /dev/null - :output 't ; use current standard output - :error 't )) ; use current standard error - -(defun cmulisp-os-run-program-to-stream (program args) - (second (multiple-value-list - (extensions:run-program program args - :wait nil ; don't wait - :input 't ; use current standard input - :output :stream ; slurp the output of the process - :error 't )) )) ; use current standard error - -(defun cmulisp-os-env-get (sym) - (let ((key (intern (string sym) (find-package "KEYWORD")))) - (cdr (assoc key *environment-list* :test #'eq)) )) - -(defun cmulisp-os-process-number () - (Aix::Unix-getpid) ) -) - -;;; -;;; KCL-only implementations -;;; - -#+:KCL (progn -(defun kcl-os-run-program (program args) - (system (format nil "~{~a ~}" (cons program args))) ) - -(defun kcl-os-run-program-to-stream (program args) - (system (format nil "~{~a ~}" (cons program args))) ) - -(defun kcl-os-env-get (sym) - (system:getenv (string sym)) ) - -(defun kcl-os-process-number () - 77 ) - -;(defentry |getpid| () (int "getpid")) -) - -;;;; -;;;; Time -;;;; - -(defun |TimeStampString| () - (multiple-value-bind (sec min hr mody mo yr wkdy daylight zone) - (get-decoded-time) - (declare (ignore wkdy daylight zone)) - (format nil "~2,'0d/~2,'0d/~2,'0d ~2,'0d:~2,'0d:~2,'0d" - yr mo mody hr min sec) )) - -;;;; -;;;; File system interface -;;;; - -;;(defun |FileExists?| (path) -;; (probe-file path) ) -;; -;;(defun |FileRemove| (path) -;; (delete-file path) ) -;; -;;(defun |FileRename| (oldpath newpath) -;; (rename-file oldpath newpath) ) -;; -;;(defun |FileAbsolutePath| (path) -;; (truename path) ) -;; -;;(defun |FileDate| (path) -;; (file-write-date path) ) -;; -;;(defun |TextFileOpenIn| (path) -;; (open path -;; :element-type 'character -;; :direction :input )) -;; -;;(defun |TextFileOpenOut| (path) -;; (open path -;; :element-type 'character -;; :direction :output -;; :if-exists :supersede -;; :if-does-not-exist :create )) -;; -;;(defun |TextFileOpenIO| (path) -;; (open path -;; :element-type 'character -;; :direction :io -;; :if-exists :overwrite ; open at beginning -;; :if-does-not-exist :create )) -;; -;;(defun |TextFileOpenAppend| (path) -;; (open path -;; :element-type 'character -;; :direction :output -;; :if-exists :append -;; :if-does-not-exist :create )) -;; -;; -;;(defun |ByteFileOpenIn| (path) -;; (open path -;; :element-type 'unsigned-byte -;; :direction :input )) -;; -;;(defun |ByteFileOpenOut| (path) -;; (open path -;; :element-type 'unsigned-byte -;; :direction :output -;; :if-exists :supersede -;; :if-does-not-exist :create )) -;; -;;(defun |ByteFileOpenIO| (path) -;; (open path -;; :element-type 'unsigned-byte -;; :direction :io -;; :if-exists :overwrite ; open at beginning -;; :if-does-not-exist :create )) -;; -;;(defun |ByteFileOpenAppend| (path) -;; (open path -;; :element-type 'unsigned-byte -;; :direction :output -;; :if-exists :append -;; :if-does-not-exist :create )) -;; -;;(defun |ReadFileLineAt| (path pos) -;; (with-open-file (stream path :direction :input) -;; (file-position stream pos) -;; (read-line stream) )) -;; -;;(defun |UserHomeDirectory| () -;; (pathname-directory (user-homedir-pathname)) ) -;; -;;(defun |DirectoryFiles| (path) -;; (directory path) ) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; -;;;; Lisp Interface -;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun |LispReadFromString| (str &optional (startpos 0)) - (prog (ob nextpos) - (multiple-value-setq - (ob nextpos) - (read-from-string str nil nil :start startpos) ) - (return (list ob nextpos)) )) - -(defun |LispEval| (expr) - (eval expr) ) - -;;; expr must be a defun, defmacro, etc. -(defun |LispCompile| (expr) - (eval expr) - (compile (second expr)) ) - -(defun |LispLoadFileQuietly| (object) - (load object :verbose nil :print nil)) - -(defun |LispCompileFile| (fname) - (compile-file fname) ) - -(defun |LispLoadFile| (fname) - (load fname) ) - -(defun |LispKeyword| (str) - (intern str 'keyword) ) - -;;; -;;; Control -;;; - - -(defmacro |funcall| (&rest args) - (cons 'funcall args) ) - -(defmacro |Catch| (tag expr) - `(catch ,tag ,expr) ) - -(defmacro |Throw| (tag expr) - `(Throw ,tag ,expr) ) - -(defmacro |UnwindProtect| (a b) - `(unwind-protect ,a ,b) ) - -;;; This macro catches as much as it can. -;;; Systems with a catchall should use it. -;;; It is legitimate to not catch anything, if there is no system support. -;;; -;;; If the result was caught, then tagvar is set to the desination tag -;;; and the thown value is returned. Otherwise, tagvar is set to nil -;;; and the first result of the expression is returned. - -#+:Lucid -(defmacro |CatchAsCan| (tagvar expr) - `(let ((catch-result nil) - (expr-result nil) - (normal-exit (gensym))) - - (setq catch-result - (catch 'lucid::top-level - (setq expr-result ,expr) - normal-exit)) - (cond - ((eq catch-result normal-exit) - (setq ,tagvar nil) - expr-result ) - ('t - (setq ,tagvar 'lucid::top-level) - catch-result )) )) - -#-:Lucid -(defmacro |CatchAsCan| (tagvar expr) - `(progn - (setq tagvar nil) - ,expr )) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; General -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmacro |Eq| (a b) - `(eq ,a ,b) ) - -(defvar |Nil| nil) - -(defun |DeepCopy| (x) - (copy-tree x) ) - -(defun |SortInPlace| (l pred) - (sort l pred) ) - -(defun |Sort| (l pred) - (sort (copy-tree l) pred) ) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Streams -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defun |Prompt| (line &optional (readfn nil)) - (format *query-io* "~a" line) - (when readfn (apply readfn (list *query-io*))) ) - -(defun |PlainError| (&rest args) - (let ((fmt (plain-print-format-string args))) - (error fmt args) )) - -(defun |PrettyPrint| (expr &optional (outstream *standard-output*)) - (write expr :stream outstream :level nil :length nil :pretty 't :escape 't) - (finish-output outstream) ) - -(defun |PlainPrint| (&rest args) - (let ((fmt (plain-print-format-string args))) - (format *standard-output* fmt args) )) - -(defun |PlainPrintOn| (stream &rest args) - (let ((fmt (plain-print-format-string args))) - (format stream fmt args) )) - -(defun plain-print-format-string (l) - (format nil "~~~d{~~a~~}~~%" (length l)) ) - - -;;; Lucid 1.01 bug: Must flush output after each write or else -;;; strange errors arise from invalid buffer reuse. - -(defmacro |WriteByte| (byte &rest outstream) - `(write-byte ,byte ,@outstream) ) - -(defmacro |WriteChar| (char &rest outstream) - `(write-char ,char ,@outstream) ) - -;; Write a string -- no new line. -(defun |WriteString| (string &optional (outstream *standard-output*)) - (format outstream "~a" string) - (finish-output outstream) ) - -;; Write a string then start a new line. -(defun |WriteLine| (string &optional (outstream *standard-output*)) - (write-line string outstream) - (finish-output outstream) ) - -(defun |ByteFileWriteLine| (string outstream) - (let ((n (length string))) - (do ((i 0 (+ i 1))) - ((= i n)) - (write-byte (char-code (char string i)) outstream) )) - (write-byte (char-code #\Newline) outstream) - (finish-output outstream) ) - - -(defmacro |ReadByte| (instream) - `(read-byte ,instream nil nil) ) - -(defmacro |ReadChar| (&rest instream) - (if instream - `(read-char ,@instream nil nil) - '(read-char *standard-input* nil nil) )) - -(defun |ReadLine| (&optional (instream *standard-input*)) - (read-line instream nil nil) ) - -(defun |ByteFileReadLine| (instream) - (do ((buf (make-array '(80) - :element-type 'character - :fill-pointer 0 - :adjustable 't )) - (b (read-byte instream nil nil) (read-byte instream nil nil)) - (c) ) - - ((or (null b) (char= (setq c (code-char b)) #\Newline)) buf) - - (vector-push-extend c buf) )) - -;;; Reads no more than the rest of the current line into the string argument. -;;; The #\Newline is not included in the string. -;;; -;;; The result is an integer, 'T or nil. -;;; Nil the stream was already exhausted. -;;; T the string was filled before the end of line was reached. -;;; k the end of line was reached and k characters were copied. -;;; -;;; If the argument "flags" is passed a cons cell, it is updated -;;; to contain (Eof . Eol). -;;; Eof indicates whether the end of file was detected. -;;; Eol indicates whether the line was terminated by a #\newline. - -(defun |ReadLineIntoString| (string &optional (instream *standard-input*) - (flags nil) ) - - (when (consp flags) (rplaca flags nil) (rplacd flags nil)) - - (let ((n (length string)) - (i 0) - (c (read-char instream nil nil)) ) - - (loop - (cond - ((null c) - (when (consp flags) (rplaca flags 't)) - (return (if (= i 0) nil i)) ) - ((char= c #\Newline) - (when (consp flags) (rplacd flags 't)) - (return i) ) - ((= i n) - (unread-char c instream) - (return 't) )) - - (setf (char string i) c) - (setq i (+ i 1)) - (setq c (read-char instream nil nil)) ))) - - -;;; Similar to ReadLineIntoString but reads from a ByteFile. -(defun |ByteFileReadLineIntoString| (string instream &optional (flags nil)) - - (when (consp flags) (rplaca flags nil) (rplacd flags nil)) - - (let ((n (length string)) - (i 0) - (b nil) - (c nil) ) - - (loop - (when (= i n) (return 't) ) - (setq b (read-byte instream nil nil)) - (when (null b) - (when (consp flags) (rplaca flags 't)) - (return i) ) - - (setq c (code-char b)) - (when (char= c #\Newline) - (when (consp flags) (rplacd flags 't)) - (return i) ) - - (setf (char string i) c) - (setq i (+ i 1)) ))) - -(defun |ReadBytesIntoVector| - (vector &optional (instream *standard-input*) (flags nil) ) - - (when (consp flags) (rplaca flags nil) (rplacd flags nil)) - - (let ((n (length vector)) - (i 0) - (b nil) ) - - (loop - (when (= i n) (return 't)) - (setq b (read-byte instream nil nil)) - (when (null b) - (when (consp flags) (rplaca flags 't)) - (return i) ) - - (setf (aref vector i) b) - (setq i (+ i 1)) ))) - - -(defun |InputStream?| (stream) - (input-stream-p stream) ) - -(defun |OutputStream?| (stream) - (output-stream-p stream) ) - -;;; Whether the position is a record number or character number is -;;; implementation specific. In Common Lisp it is a character number. - -(defun |StreamGetPosition| (stream) - (file-position stream) ) - -(defun |StreamSetPosition| (stream pos) - (file-position stream pos)) - -(defun |StreamSize| (stream) - (file-length stream)) - -(defmacro |WithOpenStream| (var stream-form body) - `(with-open-stream (,var ,stream-form) ,body) ) - -;;; Copy up to n characters or eof. -;;; Return number of characters actually copied -(defun |StreamCopyChars| (instream outstream n) - (do ((i 0 (+ i 1)) - (c (read-char instream nil nil) (read-char instream nil nil)) ) - ((or (null c) (= i n)) (finish-output outstream) i) - - (write-char c outstream) )) - -(defun |StreamCopyBytes| (instream outstream n) - (do ((i 0 (+ i 1)) - (b (read-byte instream nil nil) (read-byte instream nil nil)) ) - ((or (null b) (= i n)) (finish-output outstream) i) - - (write-byte b outstream) )) - -(defun |StreamEnd?| (instream) - (null (peek-char nil instream nil nil)) ) - -(defun |StreamFlush| (&optional (outstream *standard-output*)) - (finish-output outstream) ) - -(defun |StreamClose| (stream) - (close stream) ) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; -;;;; Types -;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Functions for manipulating values of type Xxxx are prefixed with Xxxx. -;;; E.g., CsetUnion -;;; Values of type Xxxx are suffixed with Xxxx. -;;; E.g., AlphaCset -;;; The primary function for creating object of this type is named Xxxx. -;;; The type-testing predicate is Xxxx? - -;;; xx := Xxxx(args) -;;; val := XxxxGet(xx, key) or XxxxGet(xx, key, default) -;;; val := XxxxSet(xx, key, val) -;;; val := XxxxUnset(xx, key) -;;; -;;; xx := XxxxRemove(val, xx) XxxxRemoveQ -;;; truth := XxxxMember?(val, xx) XxxxMemberQ? -;;; xx := XxxxUnion(xx1, xx2) -;;; -;;; The suffix "Q" means the test involved is "EQ". "N" between the -;;; the type name and the function name proper means the function is -;;; non-copying (destructive). - -;;; -;;; Pathnames -;;; - -(defvar |TempFileDirectory| (pathname-directory "/tmp/")) -(defvar |LispFileType| "lisp") -(defvar |FaslFileType| "bbin") - -(defun |Pathname| (name &optional (type nil) (dir 'none)) - (if (equal dir 'none) - (make-pathname :name name :type type :defaults name) - (make-pathname :directory dir :name name :type type) )) - -(defun |ToPathname| (string) - (pathname string) ) - -;;; System-wide unique name on each call. -(defvar *new-pathname-counter* 1) - -(defun |NewPathname| (&optional (prefix "t")(type nil)(dir '(:relative))) - (let ((name - (format nil "~a~a-~a" - prefix (|OsProcessNumber|) *new-pathname-counter* ))) - (setq *new-pathname-counter* (+ *new-pathname-counter* 1)) - (make-pathname :directory dir :name name :type type) )) - -;;; System-wide unique name for the current session. -(defun |SessionPathname| (&optional (prefix "t")(type nil)(dir '(:relative))) - (let ((name (format nil "~a~a" prefix (|OsProcessNumber|)))) - (make-pathname :directory dir :name name :type type) )) - -(defun |PathnameDirectory| (path) - (pathname-directory path) ) - -(defun |PathnameName| (path) - (pathname-name path) ) - -(defun |PathnameType| (path) - (pathname-type path) ) - - -(defun |PathnameWithType| (path type) - (make-pathname :type type :defaults path) ) - -(defun |PathnameWithoutType| (path) - (make-pathname :type nil :defaults path) ) - - -(defun |PathnameWithDirectory| (path dir) - (make-pathname :directory dir :defaults path) ) - -(defun |PathnameWithoutDirectory| (path) - (make-pathname :directory nil :defaults path) ) - - -(defun |PathnameString| (path) - (namestring path) ) - -(defun |PathnameToUsualCase| (path) - (pathname (|StringLowerCase| (namestring path))) ) - - -;; Lucid 1.01 specific -- uses representation of directories. -(defun |PathnameAbsolute?| (path) - (let ((dir (pathname-directory path))) - (not (and (consp dir) (or - (eq (car dir) :current) - (eq (car dir) :relative) ))) )) - -;; Lucid 1.01 specific -- uses representation of directories. -(defun |PathnameWithinDirectory| (dir relpath) - (if (|PathnameAbsolute?| relpath) - (|PlainError| "The path " relpath " cannot be used within directory " dir) - (make-pathname - :directory (append dir (cdr (pathname-directory relpath))) - :defaults relpath ))) - -;; Unix specific -- uses unix file syntax. -(defun |PathnameDirectoryOfDirectoryPathname| (dirpath) - (pathname-directory - (concatenate 'string (namestring dirpath) "/junk.bar") )) - -;; Unix specific -- uses environment variables. -(defun |PathnameWithinOsEnvVar| (varname relpath) - (let ((envstr (|OsEnvGet| varname))) - (parse-namestring (concatenate 'string envstr "/" relpath)) )) - -;;; -;;; Symbols -;;; - - -;;!! Worry about packages a later day. -;;!! For now, the responsibility of setting *package* is on the caller. -(defun |MakeSymbol| (str) - (let ((a (intern str))) a) ) ; Return only 1 value - -(defmacro |Symbol?| (ob) - `(and ,ob (symbolp ,ob)) ) - -(defmacro |SymbolString| (sym) - `(string ,sym) ) - -;;; -;;; Bits -;;; -(defmacro |Bit| (x) - (cond - ((eq x 1) 1) - ((eq x 0) 0) - (x 1) - (t 0))) - -(defun |Bit?| (x) - (or (eql x 1) (eql x 0)) ) - -(defvar |TrueBit| 1) -(defvar |FalseBit| 0) - -(defmacro |BitOn?| (b) `(eq ,b 1)) - -(defmacro |BitOr| (x y) - `(bit-ior ,x ,y) ) - -;;; -;;; General Sequences -;;; -;; ELT and SETELT work on these. - -;; Removed because it clashed with size in vmlisp.lisp -;; (defun SIZE (x) ;; #x in boot generates (SIZE x) -;; (length x)) - -;;; -;;; Vectors -;;; -(defun |FullVector| (size &optional (init nil)) - (make-array - (list size) - :element-type 't - :initial-element init )) - -(defun |Vector?| (x) - (vectorp x) ) - -;;; -;;; Bit Vectors -;;; - -;; Common Lisp simple bit vectors - -(defun |FullBvec| (size &optional (init 0)) - (make-array - (list size) - :element-type 'bit - :initial-element init )) - -;;; -;;; Characters -;;; - -;;(defun |char| (x) -;; (char (string x) 0) ) - -(defmacro |Char| (x) - `(char (string ,x) 0) ) - -(defmacro |Char?| (c) - `(characterp ,c) ) - ;; (or (characterp a) - ;; (and (symbolp a) (= (length (symbol-name a)) 1)))) - - -(defmacro |CharCode| (c) - `(char-code ,c) ) - -(defmacro |CharGreater?| (c1 c2) - `(char> ,c1 ,c2) ) - -(defun |CharDigit?| (x) - (or - (and (characterp x) (digit-char-p x)) - (and (stringp x) (= (length x) 1) (digit-char-p (char x 0))) - (and (symbolp x) (|CharDigit?| (string x))) )) - -(defvar |SpaceChar| #\Space) -(defvar |NewlineChar| #\Newline) - -;;; -;;; Character Sets -;;; - -(defun |Cset| (str) - (let - ((cset (make-array - (list char-code-limit) - :element-type 'bit - :initial-element 0 )) - (len (length str)) ) - - (do ((i 0 (+ 1 i))) - ((= i len)) - (setf (sbit cset (char-code (char str i))) 1) ) - cset )) - -(defun |CsetMember?| (c cset) - (eql 1 (sbit cset (char-code c))) ) - -(defun |CsetUnion| (cset1 cset2) - (bit-ior cset1 cset2) ) - -(defun |CsetComplement| (cset) - (bit-not cset) ) - -(defun |CsetString| (cset) - (let - ((chars '()) - (len (length cset))) - (do ((i 0 (+ 1 i))) - ((= i len)) - (if (eql 1 (sbit cset i)) (push (string (code-char i)) chars)) ) - (apply #'concatenate (cons 'string (nreverse chars))) )) - -(defvar |NumericCset| (|Cset| "0123456789") ) -(defvar |LowerCaseCset| (|Cset| "abcdefghijklmnopqrstuvwxyz") ) -(defvar |UpperCaseCset| (|Cset| "ABCDEFGHIJKLMNOPQRSTUVWXYZ") ) -(defvar |AlphaCset| (|CsetUnion| |LowerCaseCset| |UpperCaseCset|)) -(defvar |AlphaNumericCset| (|CsetUnion| |AlphaCset| |NumericCset|) ) -(defvar |WhiteSpaceCset| - (|Cset| (coerce - (list #\Space #\Newline #\Tab #\Page #\Linefeed #\Return #\Backspace) - 'string )) ) - -;;; -;;; Character Strings -;;; - -;; Common Lisp simple strings -;; ELT and SETELT work on these. - - -(defun |FullString| (size &optional (init #\Space)) - (make-array - (list size) - :element-type 'character - :initial-element init )) - -(defun |ToString| (ob) - (string ob) ) - -(defun |StringImage| (ob) - (format nil "~a" ob) ) - -(defun |String?| (ob) - (stringp ob) ) - -(defmacro |StringGetCode| (str ix) - `(char-code (char ,str ,ix)) ) - -(defun |StringConcat| (&rest l) - (progn - (setq l (mapcar #'string l)) - (apply #'concatenate 'string l) )) - -(defun |StringFromTo| (string from to) - (subseq string from (+ to 1)) ) - -(defun |StringFromToEnd| (string from) - (subseq string from) ) - -(defun |StringFromLong| (string from len) - (subseq string from (+ from len)) ) - -(defun |StringPrefix?| (pref string) - (let ((mm (mismatch pref string))) - (or (not mm) (eql mm (length pref))) )) - -(defun |StringUpperCase| (l) - (cond ((stringp l) (string-upcase l)) - ((symbolp l) (intern (string-upcase (symbol-name l)))) - ((characterp l) (char-upcase l)) - ((atom l) l) - (t (mapcar #'|StringUpperCase| l)) )) - -(defun |StringLowerCase| (l) - (cond ((stringp l) (string-downcase l)) - ((symbolp l) (intern (string-downcase (symbol-name l)))) - ((characterp l) (char-downcase L)) - ((atom l) l) - (t (mapcar #'|StringLowerCase| l)) )) - -(defun |StringGreater?| (s1 s2) - (string> s1 s2) ) - -(defun |StringToInteger| (s) - (read-from-string s) ) - -(defun |StringToFloat| (s) - (read-from-string s) ) - -(defun |StringLength| (s) - (length s) ) - -;;; -;;; Numbers -;;; - - - -(defmacro |Number?| (x) `(numberp ,x)) -(defmacro |Integer?| (x) `(integerp ,x)) -(defmacro |Float?| (x) `(floatp ,x)) - -(defmacro |Odd?| (n) `(oddp ,n)) -(defmacro |Remainder|(a b) `(rem ,a ,b)) - -(defmacro |DoublePrecision| (x) `(coerce ,x 'double-precision)) - -(defmacro |Abs| (x) `(abs ,x)) -(defmacro |Min| (x &rest yz) `(min ,x ,@yz)) -(defmacro |Max| (x &rest yz) `(max ,x ,@yz)) - -(defmacro |Exp| (x) `(exp ,x)) -(defmacro |Ln| (x) `(log ,x)) -(defmacro |Log10| (x) `(log ,x 10)) -(defmacro |Sin| (x) `(sin ,x)) -(defmacro |Cos| (x) `(cos ,x)) -(defmacro |Tan| (x) `(tan ,x)) -(defmacro |Cotan| (x) `(/ 1.0 (tan ,x))) -(defmacro |Arctan|(x) `(atan ,x)) - -;;; -;;; Pairs -;;; - -(defmacro |Pair?| (x) `(consp ,x)) - -(defmacro |car| (x) `(car ,x)) -(defmacro |cdr| (x) `(cdr ,x)) - -(defmacro |caar| (x) `(caar ,x)) -(defmacro |cadr| (x) `(cadr ,x)) -(defmacro |cdar| (x) `(cdar ,x)) -(defmacro |cddr| (x) `(cddr ,x)) - -(defmacro |caaar| (x) `(caaar ,x)) -(defmacro |caadr| (x) `(caadr ,x)) -(defmacro |cadar| (x) `(cadar ,x)) -(defmacro |caddr| (x) `(caddr ,x)) -(defmacro |cdaar| (x) `(cdaar ,x)) -(defmacro |cdadr| (x) `(cdadr ,x)) -(defmacro |cddar| (x) `(cddar ,x)) -(defmacro |cdddr| (x) `(cdddr ,x)) - -(defmacro |FastCar| (x) `(car (the cons ,x))) -(defmacro |FastCdr| (x) `(cdr (the cons ,x))) - -(defmacro |FastCaar| (x) `(|FastCar| (|FastCar| ,x))) -(defmacro |FastCadr| (x) `(|FastCar| (|FastCdr| ,x))) -(defmacro |FastCdar| (x) `(|FastCdr| (|FastCar| ,x))) -(defmacro |FastCddr| (x) `(|FastCdr| (|FastCdr| ,x))) - -(defmacro |FastCaaar| (x) `(|FastCar| (|FastCaar| ,x))) -(defmacro |FastCaadr| (x) `(|FastCar| (|FastCadr| ,x))) -(defmacro |FastCadar| (x) `(|FastCar| (|FastCdar| ,x))) -(defmacro |FastCaddr| (x) `(|FastCar| (|FastCddr| ,x))) -(defmacro |FastCdaar| (x) `(|FastCdr| (|FastCaar| ,x))) -(defmacro |FastCdadr| (x) `(|FastCdr| (|FastCadr| ,x))) -(defmacro |FastCddar| (x) `(|FastCdr| (|FastCdar| ,x))) -(defmacro |FastCdddr| (x) `(|FastCdr| (|FastCddr| ,x))) - -(defmacro |IfCar| (x) `(if (consp ,x) (car ,x))) -(defmacro |IfCdr| (x) `(if (consp ,x) (cdr ,x))) - -(defmacro |EqCar| (l a) `(eq (car ,l) ,a)) -(defmacro |EqCdr| (l d) `(eq (cdr ,l) ,d)) - -;;; -;;; Lists -;;; - - -(defun |ListNReverse| (l) - (nreverse l) ) - -(defun |ListIsLength?| (l n) - (if l (= n 0) (|ListIsLength?| (cdr l) (1- n))) ) - -;;--------------------> NEW DEFINITION (override in vmlisp.lisp.pamphlet) -(defun |ListMemberQ?| (ob l) - (member ob l :test #'eq) ) - -(defun |ListRemoveQ| (ob l) - (remove ob l :test #'eq :count 1) ) - -(defun |ListNRemoveQ| (ob l) - (delete ob l :test #'eq :count 1) ) - -(defun |ListRemoveDuplicatesQ| (l) - (remove-duplicates l :test #'eq) ) - -(defun |ListUnion| (l1 l2) - (union l1 l2 :test #'equal) ) - -(defun |ListUnionQ| (l1 l2) - (union l1 l2 :test #'eq) ) - -(defun |ListIntersection| (l1 l2) - (intersection l1 l2 :test #'equal) ) - -(defun |ListIntersectionQ| (l1 l2) - (intersection l1 l2 :test #'eq) ) - -(defun |ListAdjoin| (ob l) - (adjoin ob l :test #'equal) ) - -(defun |ListAdjoinQ| (ob l) - (adjoin ob l :test #'eq) ) - -;;; -;;; Association lists -;;; - - -(defun |AlistAssoc| (key l) - (assoc key l :test #'equal) ) - -;;--------------------> NEW DEFINITION (override in vmlisp.lisp.pamphlet) -(defun |AlistAssocQ| (key l) - (assoc key l :test #'eq) ) - -(defun |AlistRemove| (key l) - (let ((pr (assoc key l :test #'equal))) - (if pr - (remove pr l :test #'equal) - l) )) - -(defun |AlistRemoveQ| (key l) - (let ((pr (assoc key l :test #'eq))) - (if pr - (remove pr l :test #'eq) - l) )) - -(defun |AlistAdjoinQ| (pr l) - (cons pr (|AlistRemoveQ| (car pr) l)) ) - -(defun |AlistUnionQ| (l1 l2) - (union l1 l2 :test #'eq :key #'car) ) - -;;; -;;; Tables -;;; - -;;(defmacro |EqTable| () -;; `(make-hash-table :test #'eq) ) -;;(defmacro |EqualTable| () -;; `(make-hash-table :test #'equal) ) -;;(defmacro |StringTable| () -;; `(make-hash-table :test #'equal) ) -;; following is not used and causes CCL problems -;;(defmacro |SymbolTable| () -;; `(make-hash-table :test #'eq) ) - - -(defmacro |Table?| (ob) - `(hash-table-p ,ob) ) - -(defmacro |TableCount| (tab) - `(hash-table-count ,tab) ) - -(defmacro |TableGet| (tab key &rest default) - `(gethash ,key ,tab ,@default) ) - -(defmacro |TableSet| (tab key val) - `(setf (gethash ,key ,tab) ,val) ) - -(defun |TableUnset| (tab key) - (let ((val (gethash key tab))) - (remhash key tab) - val )) - -(defun |TableKeys| (tab) - (let ((key-list nil)) - (maphash - #'(lambda (key val) (declare (ignore val)) - (setq key-list (cons key key-list)) ) - tab ) - key-list )) - -;; CCL supplies a slightly more efficient version of logs to base 10, which -;; is useful in the WIDTH function. MCD. -#+:KCL (defun log10 (u) (log u 10)) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/util.lisp b/src/interp/util.lisp new file mode 100644 index 00000000..730b1df5 --- /dev/null +++ b/src/interp/util.lisp @@ -0,0 +1,1118 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + +;; This file is a collection of utility functions that are useful +;; for system level work. A couple of the functions, `build-depsys' +;; and `build-interpsys' interface to the src/interp/Makefile. + +;; A second group of related functions allows us to rebuild portions +;; of the system from the command prompt. This varies from rebuilding +;; individual files to whole directories. The most complex functions +;; like `makespad' can rebuild the whole algebra tree. + +;; A third group of related functions are used to set up the +;; `autoload' mechanism. These enable whole subsystems to +;; be kept out of memory until they are used. + +;; A fourth group of related functions are used to construct and +;; search Emacs TAGS files. + +;; A fifth group of related functions are some translated boot +;; functions we need to define here so they work and are available +;; at load time. + + + +(IMPORT-MODULE "vmlisp") +(import-module "parsing") + +(in-package "BOOT") +(export '($directory-list $current-directory reroot + make-absolute-filename |$msgDatabaseName| |$defaultMsgDatabaseName|)) + +(defun our-write-date (file) (and #+kcl (probe-file file) + (file-write-date file))) + +(defun make-directory (direc) + (setq direc (namestring direc)) + (if (string= direc "") (|systemRootDirectory|) + (if (or (memq :unix *features*) + (memq 'unix *features*)) + (progn + (if (char/= (char direc 0) #\/) + (setq direc (concat (|systemRootDirectory|) "/" direc))) + (if (char/= (char direc (1- (length direc))) #\/) + (setq direc (concat direc "/"))) + direc) + (progn ;; Assume Windows conventions + (if (not (or (char= (char direc 0) #\/) + (char= (char direc 0) #\\) + (find #\: direc))) + (setq direc (concat (|systemRootDirectory|) "\\" direc))) + (if (not (or (char= (char direc (1- (length direc))) #\/) + (char= (char direc (1- (length direc))) #\\ ))) + (setq direc (concat direc "\\"))) + direc)))) + +(defun interp-make-directory (direc) + (setq direc (namestring direc)) + (if (string= direc "") $current-directory + (if (or (memq :unix *features*) + (memq 'unix *features*)) + (progn + (if (char/= (char $current-directory (1-(length $current-directory))) #\/) + (setq $current-directory (concat $current-directory "/"))) + (if (char/= (char direc 0) #\/) + (setq direc (concat $current-directory direc))) + (if (char/= (char direc (1- (length direc))) #\/) + (setq direc (concat direc "/"))) + direc) + (progn ;; Assume Windows conventions + (if (not (or (char= (char $current-directory (1- (length $current-directory))) #\/) + (char= (char $current-directory (1- (length $current-directory))) #\\ ))) + (setq $current-directory (concat $current-directory "\\"))) + (if (not (or (char= (char direc 0) #\/) + (char= (char direc 0) #\\) + (find #\: direc))) + (setq direc (concat $current-directory direc))) + (if (not (or (char= (char direc (1- (length direc))) #\/) + (char= (char direc (1- (length direc))) #\\ ))) + (setq direc (concat direc "\\"))) + direc)))) + +;; Various lisps use different ``extensions'' on the filename to indicate +;; that a file has been compiled. We set this variable correctly depending +;; on the system we are using. +(defvar *bin-path* + #+kcl "o" + #+lucid "bbin" + #+symbolics "bin" + #+cmulisp "fasl" + #+:ccl "not done this way at all") + +(defun load-directory (dir) + (let* ((direc (make-directory dir)) + (pattern (make-pathname :directory (pathname-directory direc) + :name :wild :type *bin-path*)) + (files (directory pattern))) + (mapcar #'load files))) + +(defun compspadfiles (filelist ;; should be a file containing files to compile + &optional (*default-pathname-defaults* + (pathname (concat (|systemRootDirectory|) + "nalgebra/")))) + (with-open-file (stream filelist) + (do ((fname (read-line stream nil nil) (read-line stream nil nil))) + ((null fname) 'done) + (setq fname (string-right-trim " *" fname)) + (when (not (equal (elt fname 0) #\*)) + (spad fname (concat (pathname-name fname) ".out")))))) + +(defun recompile-all-algebra-files (dir) ;; a desperation measure + (let* ((direc (make-directory dir)) + (pattern (make-pathname :directory (pathname-directory direc) + :name :wild :type "spad")) + (files (directory pattern)) + (*default-pathname-defaults* (pathname direc))) + (mapcar + #'(lambda (fname) (spad fname (concat (pathname-name fname) ".out"))) + files))) + +(defun fe (function file &optional (compflag nil) &aux (fn (pathname-name file))) + (let ((tbootfile (concat "/tmp/" fn ".boot")) + (tlispfile (concat "/tmp/" fn ".lisp"))) + (system::run-aix-program "fc" + :arguments (list (string function) + (namestring + (merge-pathnames file + (concat (|systemRootDirectory|) + "nboot/.boot")))) + :if-output-exists :supersede :output tbootfile) + (boot tbootfile tlispfile) + (if compflag (progn (compile-file tlispfile) + (load (make-pathname :type *bin-path* :defaults tlispfile))) + (load tlispfile)))) +(defun fc (function file) (fe function file t)) + +;; This function will compile any lisp code that has changed in a directory. +(defun recompile-directory (dir) + (let* ((direc (make-directory dir)) + (pattern (make-pathname :directory (pathname-directory direc) + :name :wild :type "lisp")) + (files (directory pattern))) + (mapcan #'recompile-file-if-necessary files))) + +;; This is a helper function that checks the time stamp between +;; the given file and its compiled binary. If the file has changed +;; since it was last compiled this function will recompile it. +(defun recompile-file-if-necessary (lfile) + (let* ((bfile (make-pathname :type *bin-path* :defaults lfile)) + (bdate (our-write-date bfile)) + (ldate (our-write-date lfile))) + (if (and bdate ldate (> bdate ldate)) nil + (progn + (format t "compiling ~a~%" lfile) + (compile-file lfile) + (list bfile))))) + +;; Force recompilation of all lisp files in a directory. +(defun recompile-all-files (dir) + (let* ((direc (make-directory dir)) + (pattern (make-pathname :directory (pathname-directory direc) + :name :wild :type "lisp")) + (files (directory pattern))) + (mapcar #'compile-file files))) + + +;; Recompile library lisp code if necessary. +(defun recompile-lib-directory (dir) + (let* ((direc (make-directory dir)) + (pattern (make-pathname :directory (pathname-directory direc) + :name :wild :type "NRLIB")) + (files (directory pattern))) + (mapcan #'recompile-NRLIB-if-necessary files))) + +(defun recompile-all-libs (dir) + (let* ((direc (make-directory dir)) + (pattern (make-pathname :directory (pathname-directory direc) + :name :wild :type "NRLIB")) + (files (directory pattern))) + (mapcar + #'(lambda (lib) (compile-lib-file (concat (namestring lib) "/code.lsp"))) + files))) + +;; Recompile a single library's lisp file if it is out of date. +;; The {\bf recompile-lib-file-if-necessary} is defined in nlib.lisp. +(defun recompile-NRLIB-if-necessary (lib) + (recompile-lib-file-if-necessary (concat (namestring lib) "/code.lsp")) + (lift-NRLIB-name (namestring lib))) + + +;; We used to use FOO.NRLIB/code.o files for algebra. However there +;; was no need for this additional level of indirection since the rest +;; of the information in an NRLIB is now kept in the daase files. Thus +;; we lift the FOO.NRLIB/code.o to FOO.o in the final system. +(defun lift-NRLIB-name (f) + (obey (concat "cp " f "/code.o " (subseq f 0 (position #\. f)) ".o")) + nil) + +;; Translate a directory of boot code to common lisp if the boot code +;; is newer. +(defun retranslate-directory (dir) + (let* ((direc (make-directory dir)) + (pattern (make-pathname :directory (pathname-directory direc) + :name :wild :type "boot")) + (files (directory pattern))) + (mapcan #'retranslate-file-if-necessary files))) + + +;; Retranslate a single boot file if it has been changed. +(defun retranslate-file-if-necessary (bootfile) + (let* ((lfile (make-pathname :type "lisp" :defaults bootfile)) + (ldate (our-write-date lfile)) + (binfile (make-pathname :type *bin-path* :defaults bootfile)) + (bindate (our-write-date binfile)) + (bootdate (our-write-date bootfile))) + (if (and ldate bootdate (> ldate bootdate)) nil + (if (and bindate bootdate (> bindate bootdate)) nil + (progn (format t "translating ~a~%" bootfile) + (boot bootfile lfile) (list bootfile)))))) + + +;; TAGS are useful for finding functions if you run Emacs. We have a +;; set of functions that construct TAGS files for Axiom. +(defun make-tags-file () +#+:gcl (system:chdir "/tmp") +#-:gcl (obey (concatenate 'string "cd " "/tmp")) + (obey (concat "etags " (make-absolute-filename "../../src/interp/*.lisp"))) + (spadtags-from-directory "../../src/interp" "boot") + (obey "cat /tmp/boot.TAGS >> /tmp/TAGS")) + +(defun spadtags-from-directory (dir type) + (let* ((direc (make-directory dir)) + (pattern (make-pathname :directory (pathname-directory direc) + :name :wild :type type)) + (files (directory pattern))) + (with-open-file + (tagstream (concatenate 'string "/tmp/" type ".TAGS") :direction :output + :if-exists :supersede :if-does-not-exist :create) + (dolist (file files (namestring tagstream)) + (print (list "processing:" file)) + (write-char #\page tagstream) + (terpri tagstream) + (write-string (namestring file) tagstream) + (write-char #\, tagstream) + (princ (spadtags-from-file file) tagstream) + (terpri tagstream) + (with-open-file (stream "/tmp/*TAGS") + (do ((line (read-line stream nil nil) + (read-line stream nil nil))) + ((null line) nil) + (write-line line tagstream))))))) + +(defun spadtags-from-file (spadfile) + (with-open-file (tagstream "/tmp/*TAGS" :direction :output + :if-exists :supersede :if-does-not-exist :create) + (with-open-file (stream spadfile) + (do ((char-count 0 (file-position stream)) + (line (read-line stream nil nil) (read-line stream nil nil)) + (line-count 1 (1+ line-count))) + ((null line) (file-length tagstream)) + (if (/= (length line) 0) + (let ((firstchar (elt line 0)) (end nil) + (len (length line))) + (cond ((member firstchar '(#\space #\{ #\} #\tab ) + :test #'char= ) "skip") + ((string= line ")abb" :end1 (min 4 len)) + (setq end (position #\space line :from-end t + :test-not #'eql) + end (and end (position #\space line :from-end t + :end end))) + (write-tag-line line tagstream end + line-count char-count)) + ((char= firstchar #\)) "skip") + ((and (> len 1) (string= line "--" :end1 2)) "skip") + ((and (> len 1) (string= line "++" :end1 2)) "skip") + ((search "==>" line) "skip") + ((and (setq end (position #\space line) + end (or (position #\( line :end end) end) + end (or (position #\: line :end end) end) + end (or (position #\[ line :end end) end)) + (equal end 0)) "skip") + ((position #\] line :end end) "skip") + ((string= line "SETANDFILEQ" :end1 end) "skip") + ((string= line "EVALANDFILEACTQ" :end1 end) "skip") + (t (write-tag-line line tagstream + (if (numberp end) (+ end 1) end) + line-count char-count)) ))))))) + +(defun write-tag-line (line tagstream endcol line-count char-count) + (write-string line tagstream :end endcol) + (write-char #\rubout tagstream) + (princ line-count tagstream) + (write-char #\, tagstream) + (princ char-count tagstream) + (terpri tagstream)) + +(defun blankcharp (c) (char= c #\Space)) + +(defun findtag (tag &optional (tagfile (concat (|systemRootDirectory|) "/../../src/interp/TAGS")) ) + ;; tag is an identifier + (with-open-file (tagstream tagfile) + (do ((tagline (read-line tagstream nil nil) + (read-line tagstream nil nil)) + (*package* (symbol-package tag)) + (sourcefile) + (stringtag (string tag)) + (pos) + (tpos) + (type)) + ((null tagline) ()) + (cond ((char= (char tagline 0) #\Page) + (setq tagline (read-line tagstream nil nil)) + (setq sourcefile (subseq tagline 0 + (position #\, tagline))) + (setq type (pathname-type sourcefile))) + ((string= type "lisp") + (if (match-lisp-tag tag tagline) + (return (cons sourcefile tagline)))) + ((> (mismatch ")abb" tagline) 3) + (setq pos (position #\Space tagline :start 3)) + (setq pos (position-if-not #'blankcharp tagline + :start pos)) + (setq pos (position #\Space tagline :start pos)) + (setq pos (position-if-not #'blankcharp tagline + :start pos)) + (setq tpos (mismatch stringtag tagline :start2 pos)) + (if (and (= tpos (length (string tag))) + (member (char tagline (+ pos tpos)) '(#\Space #\Rubout))) + (return (cons sourcefile tagline)))) + ((setq pos (mismatch stringtag tagline)) + (if (and (= pos (length stringtag)) + (> (length tagline) pos) + (member (char tagline pos) + '( #\Space #\( #\:) )) + (return (cons sourcefile tagline)))))))) + +(defun match-lisp-tag (tag tagline &optional (prefix nil) + &aux (stringtag (string tag)) pos tpos) + (when (and (if prefix + (= (mismatch prefix tagline :test #'char-equal) + (length prefix)) + t) + (numberp (setq pos (position #\Space tagline))) + (numberp (setq pos (position-if-not #'blankcharp tagline + :start pos)))) + (if (char= (char tagline pos) #\') (incf pos)) + (if (member (char tagline pos) '( #\\ #\|)) + (setq tpos (1+ pos)) + (setq tpos pos)) + (and (= (mismatch stringtag tagline :start2 tpos :test #'char-equal) + (length stringtag)) + (eq tag (read-from-string tagline nil nil :start pos))) )) + +;; Translate a single boot file to common lisp, compile it +;; and load it. +(defun compile-boot-file (file) + "compile and load a boot file" + (boot (concat file ".boot") (concat file ".lisp")) +#+:AKCL + (compile-file (concat file ".lisp")) +#+:AKCL + (load (concat file "." *bin-path*)) +#+:CCL + (load (concat file ".lisp")) +) + + +;; Translate a single boot file to common lisp +(defun translate (file) ;; translates a single boot file +#+:CCL + (setq *package* (find-package "BOOT")) +#+:AKCL + (in-package "BOOT") + (let (*print-level* *print-length* (fn (pathname-name file)) + (bootfile (merge-pathnames file (concat (|systemRootDirectory|) "nboot/.boot")))) + (declare (special *print-level* *print-length*)) + (boot bootfile (make-pathname :type "lisp" :defaults bootfile)))) + + +;; Translate a list of boot files to common lisp. +(defun translist (fns) + (mapcar #'(lambda (f) (format t "translating ~a~%" (concat f ".boot")) + (translate f)) + fns)) + + +;; The relative directory list specifies a search path for files +;; for the current directory structure. It has been changed from the +;; NAG distribution back to the original form. +(defvar $relative-directory-list + '("/../../src/input/" + "/share/msgs/" + "/../../src/algebra/" + "/../../src/interp/" ; for boot and lisp files (helps fd) + "/doc/spadhelp/" )) + +;; The relative directory list specifies how to find the algebra +;; directory from the current {\bf AXIOM} shell variable. +(defvar $relative-library-directory-list '("/algebra/")) + +(in-package "OLD-BOOT") + +(defun boot (file) ;; translates a single boot file +#+:CCL + (setq *package* (find-package "BOOT")) +#+:AKCL + (in-package "BOOT") + (let (*print-level* + *print-length* + (fn (pathname-name file)) + (*print-pretty* t)) + (declare (special *print-level* *print-length*)) + (boot::boot + file + (merge-pathnames (make-pathname :type "clisp") file)))) + + +(in-package "BOOT") + +;; This is a little used subsystem to generate {\bf ALDOR} code +;; from {\bf Spad} code. Frankly, I'd be amazed if it worked. +(setq translate-functions '( +;; .spad to .as translator, in particular +;; loadtranslate + |spad2AsTranslatorAutoloadOnceTrigger| + )) + +;; This is part of the {\bf ALDOR subsystem}. These will be loaded +;; if you compile a {\bf .as} file rather than a {\bf .spad} file. +;; {\bf ALDOR} is an external compiler that gets automatically called +;; if the file extension is {\bf .as}. +(setq asauto-functions '( + loadas +;; |as| ;; now in as.boot +;; |astran| ;; now in as.boot + |spad2AxTranslatorAutoloadOnceTrigger| + |sourceFilesToAxcliqueAxFile| + |sourceFilesToAxFile| + |setExtendedDomains| + |makeAxFile| + |makeAxcliqueAxFile| + |nrlibsToAxFile| + |attributesToAxFile| )) + +;; These are some {\bf debugging} functions that I use. I can't imagine +;; why you might autoload them but they don't need to be in a running +;; system. +(setq debug-functions '( + loaddebug + |showSummary| + |showPredicates| + |showAttributes| + |showFrom| + |showImp|)) + +;; The {\bf ANNA} subsystem, invoked thru {\bf hypertex}, is an +;; expert system that understands the Numerical Algorithms Group (NAG) +;; fortran library. +(setq anna-functions '( + |annaInt| + |annaMInt| + |annaOde| + |annaOpt| + |annaOpt2| + |annaPDESolve| + |annaOptDefaultSolve1| + |annaOptDefaultSolve2| + |annaOptDefaultSolve3| + |annaOptDefaultSolve4| + |annaOptDefaultSolve5| + |annaOpt2DefaultSolve| + |annaFoo| + |annaBar| + |annaJoe| + |annaSue| + |annaAnn| + |annaBab| + |annaFnar| + |annaDan| + |annaBlah| + |annaTub| + |annaRats| + |annaMInt| + |annaOdeDefaultSolve1| + |annaOdeDefaultSolve2|)) + +;; The Numerical Algorithms Group (NAG) fortran library has a set +;; of cover functions. These functions need to be loaded if you use +;; the NAG library. +(setq nagbr-functions '( + loadnag + |c02aff| |c02agf| + |c05adf| |c05nbf| |c05pbf| + |c06eaf| |c06ebf| |c06ecf| |c06ekf| |c06fpf| |c06fqf| |c06frf| + |c06fuf| |c06gbf| |c06gcf| |c06gqf| |c06gsf| + |d01ajf| |d01akf| |d01alf| |d01amf| |d01anf| |d01apf| |d01aqf| + |d01asf| |d01bbf| |d01fcf| |d01gaf| |d01gbf| + |d02bbf| |d02bhf| |d02cjf| |d02ejf| |d02gaf| |d02gbf| |d02kef| + |d02raf| + |d03edf| |d03eef| |d03faf| + |e01baf| |e01bef| |e01bff| |e01bgf| |e01bhf| |e01daf| |e01saf| + |e01sbf| |e01sef| + |e02adf| |e02aef| |e02agf| |e02ahf| |e02ajf| |e02akf| |e02baf| + |e02bbf| |e02bcf| |e02bdf| |e02bef| |e02daf| |e02dcf| + |e02ddf| |e02def| |e02dff| |e02gaf| |e02zaf| + |e04dgf| |e04fdf| |e04gcf| |e04jaf| |e04mbf| |e04naf| |e04ucf| + |e04ycf| + |f01brf| |f01bsf| |f01maf| |f01mcf| |f01qcf| |f01qdf| |f01qef| + |f01rcf| |f01rdf| |f01ref| + |f02aaf| |f02abf| |f02adf| |f02aef| |f02aff| |f02agf| |f02ajf| + |f02akf| |f02awf| |f02axf| |f02bbf| |f02bjf| |f02fjf| + |f02wef| |f02xef| + |f04adf| |f04arf| |f04asf| |f04atf| |f04axf| |f04faf| |f04jgf| + |f04maf| |f04mbf| |f04mcf| |f04qaf| + |f07adf| |f07aef| |f07fdf| |f07fef| + |s01eaf| |s13aaf| |s13acf| |s13adf| |s14aaf| |s14abf| |s14baf| + |s15adf| |s15aef| |s17acf| |s17adf| |s17aef| |s17aff| + |s17agf| |s17ahf| |s17ajf| |s17akf| |s17dcf| |s17def| + |s17dgf| |s17dhf| |s17dlf| |s18acf| |s18adf| |s18aef| + |s18aff| |s18dcf| |s18def| |s19aaf| |s19abf| |s19acf| + |s19adf| |s20acf| |s20adf| |s21baf| |s21bbf| |s21bcf| + |s21bdf| + )) + + +;; This function is called by {\bf build-interpsys}. It takes two lists. +;; The first is a list of functions that need to be used as +;; ``autoload triggers''. The second is a list of files to load if one +;; of the trigger functions is called. At system build time each of the +;; functions in the first list is set up to load every file in the second +;; list. In this way we will automatically load a whole subsystem if we +;; touch any function in that subsystem. We call a helper function +;; called {\bf setBootAutoLoadProperty} to set up the autoload trigger. +;; This helper function is listed below. +(defun |setBootAutloadProperties| (fun-list file-list) +#+:AKCL + (mapc #'(lambda (fun) (|setBootAutoLoadProperty| fun file-list)) fun-list) +#+:CCL + (mapc #'(lambda (fun) (lisp::set-autoload fun file-list)) fun-list) +) + + +;; This function knows where the {\bf autoload} subdirectory lives. +;; It is called by {\bf mkBootAutoLoad} above to find the necessary +;; files. +(defun boot-load (file) + (let ((name (concat (|systemRootDirectory|) + "/autoload/" + (pathname-name file)))) + (if |$printLoadMsgs| + (format t " Loading ~A.~%" name)) + (load name))) + +;; This is a helper function to set up the autoload trigger. It sets +;; the function cell of each symbol to {\bf mkBootAutoLoad} which is +;; listed below. +(defun |setBootAutoLoadProperty| (func file-list) + (setf (symbol-function func) (|mkBootAutoLoad| func file-list)) ) + +;; This is how the autoload magic happens. Every function named in the +;; autoload lists is actually just another name for this function. When +;; the named function is called we call {\bf boot-load} on all of the +;; files in the subsystem. This overwrites all of the autoload triggers. +;; We then look up the new (real) function definition and call it again +;; with the real arguments. Thus the subsystem loads and the original +;; call succeeds. +(defun |mkBootAutoLoad| (fn file-list) + (function (lambda (&rest args) + (mapc #'boot-load file-list) + (unless (string= (subseq (string fn) 0 4) "LOAD") + (apply (symbol-function fn) args))))) + +;############################################################################ +;# autoload dependencies +;# +;# if you are adding a file which is to be autoloaded the following step +;# information is useful: +;# there are 2 cases: +;# 1) adding files to currently autoloaded parts +;# (as of 2/92: browser old parser and old compiler) +;# 2) adding new files +;# case 1: +;# a) you have to add the file to the list of files currently there +;# (e.g. see BROBJS above) +;# b) add an autolaod rule +;# (e.g. ${AUTO}/parsing.${O}: ${OUT}/parsing.${O}) +;# c) edit util.lisp to add the 'external' function (those that +;# should trigger the autoload +;# case 2: +;# build-interpsys (in util.lisp) needs an extra argument for the +;# new autoload things and several functions in util.lisp need hacking. +;############################################################################ + +;; The `build-interpsys' function takes a list of files to load +;; into the image (`load-files'). It also takes several lists of files, +;; one for each subsystem which will be autoloaded. Autoloading is explained +;; below. This function is called in the src/interp/Makefile. + +;; This function calls `reroot' to set up pathnames we need. Next +;; it sets up the lisp system memory (at present only for AKCL/GCL). Next +;; it loads all of the named files, resets a few global state variables, +;; loads the databases, sets up autoload triggers and clears out hash tables. +;; After this function is called the image is clean and can be saved. + +(defun build-interpsys (load-files + translate-files nagbr-files asauto-files) + (reroot) + #+:AKCL + (init-memory-config :cons 500 :fixnum 200 :symbol 500 :package 8 + :array 400 :string 500 :cfun 100 :cpages 1000 + :rpages 1000 :hole 2000) + #+:AKCL + (setq compiler::*suppress-compiler-notes* t) + (mapcar #'|AxiomCore|::|importModule| load-files) + (|resetWorkspaceVariables|) + (|initHist|) + (|initNewWorld|) + (compressopen) + (interpopen) + (create-initializers) + (|start| :fin) +#+:CCL + (resethashtables) + (setq *load-verbose* nil) + (|setBootAutloadProperties| translate-functions translate-files) + (|setNAGBootAutloadProperties| nagbr-functions nagbr-files) + (|setBootAutloadProperties| asauto-functions asauto-files) + (setf (symbol-function 'boot::|addConsDB|) #'identity) + (resethashtables) ; the databases into core, then close the streams + ) + + +;; This is a further refinement of the autoload scheme. Since the +;; Numerical Algorithms Group (NAG) fortran library contains many +;; functions we subdivide the NAG library subsystem into chapters. +;; We use a different helper function {\bf get-NAG-chapter} to decide +;; which files to load. +(defun |setNAGBootAutloadProperties| (function-list file-list) + (mapcar + #'(lambda (f) + (|setBootAutloadProperties| + (get-NAG-chapter (chapter-name f) function-list) + (nag-files f file-list))) + file-list)) + +;; This function is used to find the names of the files to load. +;; On solaris 9 under GCL the original implementation will fail because +;; the max number of arguments is 63. We rewrite it to get around this +;; problem. +(defun get-NAG-chapter (chapter function-list) + (let ((l (length chapter)) r) + (dolist (f function-list) + (when (equalp chapter (subseq (string f) 0 l)) + (push f r))) + (nreverse r))) + + +;; We analyze the function names to decide which chapter we are in. +;; We load files based on the chapter. +(defun nag-files (filename filelist) + (apply 'append (mapcar + #'(lambda (f) + (cond ((equalp (chapter-name filename) (chapter-name f)) (list f))) ) + filelist))) + +;; The library names follow a convention that allows us to extract +;; the chapter name. +(defun chapter-name (f) +#+:AKCL + (apply + #'(lambda (s) + (cond ((equalp (aref s 0) #\s) "s") (T (reverse (subseq s 0 3))))) + (list (string-left-trim "a.o" (reverse f) )) ) +#+:CCL + (subseq (string-downcase (string f)) 4 (length (string f))) +) + + +;; The `depsys' image is one of the two images we build from +;; the src/interp subdirectory (the other is `interpsys'). We +;; use `depsys' as a compile-time image as it contains all of +;; the necessary functions and macros to compile any file. The +;; `depsys' image is almost the same as an `interpsys' +;; image but it does not have any autoload triggers or databases +;; loaded. + +(defun build-depsys (load-files) +#+:CCL + (setq *package* (find-package "BOOT")) +#+:AKCL + (in-package "BOOT") + (mapcar #'load load-files) + (reroot) + #+:AKCL + (init-memory-config :cons 1000 :fixnum 400 :symbol 1000 :package 16 + :array 800 :string 1000 :cfun 200 :cpages 2000 + :rpages 2000 :hole 4000) ) +;; (init-memory-config :cons 500 :fixnum 200 :symbol 500 :package 8 +;; :array 400 :string 500 :cfun 100 :cpages 1000 +;; :rpages 1000 :hole 2000) ) + + +(DEFUN |string2BootTree| (S) + (init-boot/spad-reader) + (LET* ((BOOT-LINE-STACK (LIST (CONS 1 S))) + ($BOOT T) + ($SPAD NIL) + (XTOKENREADER 'GET-BOOT-TOKEN) + (LINE-HANDLER 'NEXT-BOOT-LINE) + (PARSEOUT (PROGN (|PARSE-Expression|) (POP-STACK-1)))) + (DECLARE (SPECIAL BOOT-LINE-STACK $BOOT $SPAD XTOKENREADER LINE-HANDLER)) + (DEF-RENAME (|new2OldLisp| PARSEOUT)))) + +(DEFUN |string2SpadTree| (LINE) + (DECLARE (SPECIAL LINE)) + (if (and (> (LENGTH LINE) 0) (EQ (CHAR LINE 0) #\) )) + (|processSynonyms|)) + (ioclear) + (LET* ((BOOT-LINE-STACK (LIST (CONS 1 LINE))) + ($BOOT NIL) + ($SPAD T) + (XTOKENREADER 'GET-BOOT-TOKEN) + (LINE-HANDLER 'NEXT-BOOT-LINE) + (PARSEOUT (PROG2 (|PARSE-NewExpr|) (POP-STACK-1)))) + (DECLARE (SPECIAL BOOT-LINE-STACK $BOOT $SPAD XTOKENREADER LINE-HANDLER)) + PARSEOUT)) + + +;;--------------------> NEW DEFINITION (see i-syscmd.boot.pamphlet) +(defun |processSynonyms| () nil) ;;dummy def for depsys, redefined later + + +;; the following are for conditional reading +#+:ieee-floating-point (setq $ieee t) +#-:ieee-floating-point (setq $ieee nil) +(setq |$opSysName| '"shell") +#+:CCL (defun machine-type () "unknown") +(setq |$machineType| (machine-type)) +; spad-clear-input patches around fact that akcl clear-input leaves newlines chars +(defun spad-clear-input (st) (clear-input st) (if (listen st) (read-char st))) + +;; We need a way of distinguishing different versions of the system. +;; There used to be a way to touch the src/timestamp file whenever +;; you checked in a change to the change control subsystem. +;; During make PART=interp (the default for make) we set timestamp +;; to the filename of this timestamp file. This function converts it +;; to a luser readable string and sets the *yearweek* variable. +;; The result of this function is a string that is printed as a banner +;; when Axiom starts. The actual printing is done by the function +;; [[spadStartUpMsgs]] in [[src/interp/msgdb.boot]]. It uses a +;; format string from the file [[src/doc/msgs/s2-us.msgs]]. +(defun yearweek () + "set *yearweek* to the current time string for the version banner" + (declare (special timestamp) (special *yearweek*)) + (if (and (boundp 'timestamp) (probe-file timestamp)) + (let (sec min hour date month year day dayvec monvec) + (setq dayvec '("Monday" "Tuesday" "Wednesday" "Thursday" + "Friday" "Saturday" "Sunday")) + (setq monvec '("January" "February" "March" "April" "May" "June" + "July" "August" "September" "October" "November" + "December")) + (multiple-value-setq (sec min hour date month year day) + (decode-universal-time + (file-write-date timestamp))) + (setq *yearweek* + (copy-seq + (format nil "~a ~a ~d, ~d at ~2,'0d:~2,'0d:~2,'0d " + (elt dayvec day) + (elt monvec (1- month)) date year hour min sec)))) + (setq *yearweek* "no timestamp"))) + +(defun sourcepath (f) + "find the sourcefile in the system directories" + (let (axiom algebra naglink) + (setq axiom (|systemRootDirectory|)) + (setq algebra (concatenate 'string axiom "/../../src/algebra/" f ".spad")) + (setq naglink (concatenate 'string axiom "/../../src/naglink/" f ".spad")) + (cond + ((probe-file algebra) algebra) + ((probe-file naglink) naglink) + ('else nil)))) + +(defun srcabbrevs (sourcefile) + "read spad source files and return the constructor names and abbrevs" + (let (expr point mark names longnames) + (catch 'done + (with-open-file (in sourcefile) + (loop + (setq expr (read-line in nil 'done)) + (when (eq expr 'done) (throw 'done nil)) + (when (and (> (length expr) 4) (string= ")abb" (subseq expr 0 4))) + (setq expr (string-right-trim '(#\space #\tab) expr)) + (setq point (position #\space expr :from-end t :test #'char=)) + (push (subseq expr (1+ point)) longnames) + (setq expr (string-right-trim '(#\space #\tab) + (subseq expr 0 point))) + (setq mark (position #\space expr :from-end t)) + (push (subseq expr (1+ mark)) names))))) + (values longnames names))) + + +#+(and :AKCL (not (or :dos :win32))) +(in-package "COMPILER") +#+(and :AKCL (not (or :dos :win32))) +(defun gazonk-name ( &aux tem) + "return the name of the intermediate compiler file" + (dotimes (i 1000) + (setq tem (merge-pathnames (format nil "/tmp/gazonk~d.lsp" i))) + (unless (probe-file tem) + (return-from gazonk-name (pathname tem)))) + (error "1000 gazonk names used already!")) + +(in-package "BOOT") + +(defun |tr| (fn) + (|spad2AsTranslatorAutoloadOnceTrigger|) + (|convertSpadFile| fn) ) + + +;; Make will not compare dates across directories. +;; Rather than copy all of the code.lsp files to the MNT directory +;; we run this function to compile the files that are out of date +;; this function assumes that the shell variables INT and MNT are set. +;; Also of note: on the rt some files (those in the nooptimize list) +;; need to be compiled without optimize due to compiler bugs +(defun makelib (mid out stype btype) + "iterate over the NRLIBs, compiling ones that are out of date. + mid is the directory containing code.lsp + out is the directory containing code.o" + (let (libs lspdate odate nooptimize (alphabet #\space)) +#+(and :akcl :rt) + (setq nooptimize '("FFCAT-.NRLIB" "CHVAR.NRLIB" "PFO.NRLIB" "SUP.NRLIB" + "INTG0.NRLIB" "FSPRMELT.NRLIB" "VECTOR.NRLIB" + "EUCDOM-.NRLIB")) + (if (and mid out) + (format t "doing directory on ~s...~%" (concatenate 'string mid "/*")) + (error "makelib:MID=~a OUT=~a~% these are not set properly~%" mid out)) +#+:akcl (compiler::emit-fn nil) +#+:akcl (si::chdir mid) +#-:akcl (obey (concatenate 'string "cd " mid)) + (setq libs (directory "*.NRLIB")) + (unless libs + (format t "makelib:directory of ~a returned NIL~%" mid) + (bye -1)) + (princ "checking ") + (dolist (lib libs) + (unless (char= (schar (pathname-name lib) 0) alphabet) + (setq alphabet (schar (pathname-name lib) 0)) + (princ alphabet) + (finish-output)) + (let (dotlsp doto mntlib intkaf mntkaf intkafdate mntkafdate) + (setq dotlsp + (concatenate 'string mid "/" (file-namestring lib) "/code." stype)) + (setq doto + (concatenate 'string out "/" (pathname-name lib) ".NRLIB/code." btype)) + (setq mntlib + (concatenate 'string out "/" (pathname-name lib) ".NRLIB")) + (setq intkaf + (concatenate 'string mid "/" (file-namestring lib) "/index.KAF*")) + (setq mntkaf + (concatenate 'string out "/" (pathname-name lib) ".NRLIB/index.KAF*")) + (unless (probe-file mntlib) + (format t "creating directory ~a~%" mntlib) + (obey (concatenate 'string "cp -pr " (namestring lib) " " out)) + (when (probe-file (concatenate 'string mntlib "/code." stype)) + (delete-file (concatenate 'string mntlib "/code." stype)))) + (setq intkafdate (and (probe-file intkaf) (file-write-date intkaf))) + (setq mntkafdate (and (probe-file mntkaf) (file-write-date mntkaf))) + (when intkafdate + (unless (and mntkafdate (> mntkafdate intkafdate)) + (format t "~©ing ~s to ~s" intkaf mntkaf) + (obey + (concatenate 'string "cp " + (namestring intkaf) " " (namestring mntkaf))))) + (setq lspdate (and (probe-file dotlsp) (file-write-date dotlsp))) + (setq odate (and (probe-file doto) (file-write-date doto))) + (when lspdate + (unless (and odate (> odate lspdate)) +#+(and :akcl :rt) + (if (member (file-namestring lib) nooptimize :test #'string=) + (setq compiler::*speed* 0) + (setq compiler::*speed* 3)) + (compile-lib-file dotlsp :output-file doto))))))) + + +;; Make will not compare dates across directories. +;; In particular, it cannot compare the algebra files because there +;; is a one-to-many correspondence. This function will walk over +;; all of the algebra NRLIB files and find all of the spad files +;; that are out of date and need to be recompiled. This function +;; creates a file "/tmp/compile.input" to be used later in the +;; makefile. +;; Note that the file /tmp/compile.input is not currently used +;; as algebra source recompiles are not necessarily something +;; we want done automatically. Nevertheless, in the quest for +;; quality we check anyway. +(defun makespad (src mid stype) + "iterate over the spad files, compiling ones that are out of date. + src is the directory containing .spad + mid is the directory containing code.lsp + out is the directory containing code.o" + (let (mntlibs spadwork (alphabet #\space)) + (labels ( + (findsrc (mid libname) + "return a string name of the source file given the library file + name (eg PI) as a string" + (let (kaffile index alist) + (setq kaffile + (concatenate 'string mid "/" libname ".NRLIB/index.KAF*")) + (with-open-file (kaf kaffile) + (setq index (read kaf)) + (file-position kaf index) + (setq alist (read kaf)) + (setq index (third (assoc "sourceFile" alist :test #'string=))) + (file-position kaf index) + (pathname-name (pathname (read kaf index))))))) + (format t "makespad:src=~s mid=~s stype=~s~%" src mid stype) + (if (and src mid) + (format t "doing directory on ~s...~%" (concatenate 'string src "/*")) + (error "makespad:SRC=~a MID=~a not set properly~%" src mid)) +#+:akcl (si::chdir mid) +#-:akcl (obey (concatenate 'string "cd " mid)) + (setq mntlibs (directory "*.NRLIB")) + (unless mntlibs + (format t "makespad:directory of ~a returned NIL~%" src) + (bye 1)) + (princ "checking ") + (dolist (lib mntlibs) + (unless (char= (schar (pathname-name lib) 0) alphabet) + (setq alphabet (schar (pathname-name lib) 0)) + (princ alphabet) + (finish-output)) + (let (spad spaddate lsp lspdate) + (setq spad + (concatenate 'string src "/" (findsrc mid (pathname-name lib)) ".spad")) + (setq spaddate + (and (probe-file spad) (file-write-date spad))) + (setq lsp + (concatenate 'string mid "/" (pathname-name lib) ".NRLIB/code." stype)) + (setq lspdate + (and (probe-file lsp) (file-write-date lsp))) + (cond + ((and spaddate lspdate (<= spaddate lspdate))) + ((and spaddate lspdate (> spaddate lspdate)) + (setq spadwork (adjoin spad spadwork :test #'string=))) + ((and spaddate (not lspdate)) + (setq spadwork (adjoin spad spadwork :test #'string=))) + ((and (not spaddate) lspdate) + (format t "makespad:missing spad file ~a for lisp file ~a~%" spad lsp)) + ((and (not spaddate) (not lspdate)) + (format t "makespad:NRLIB ~a exist but is spad ~a and lsp ~a don't~%" + lib spad lsp))))) + (with-open-file (tmp "/tmp/compile.input" :direction :output) + (dolist (spad spadwork) + (format t "~a is out of date~%" spad) + (format tmp ")co ~a~%" spad)))))) + + +;; We need to ensure that the INTERP.EXPOSED list, which is a list +;; of the exposed constructors, is consistent with the actual libraries. +(defun libcheck (int) + "check that INTERP.EXPOSED and NRLIBs are consistent" + (let (interp nrlibs) + (labels ( + (CONSTRUCTORNAME (nrlib) + "find the long name of a constructor given an abbreviation string" + (let (file sourcefile name) + (setq file (findsrc nrlib)) + (setq sourcefile + (concatenate 'string int "/" file ".spad")) + (when (and file (probe-file sourcefile)) + (setq name (searchsource sourcefile nrlib))))) + (NOCAT (longnames) + "remove the categories from the list of long names" + (remove-if + #'(lambda (x) + (let ((c (schar x (1- (length x))))) + (or (char= c #\&) (char= c #\-)))) longnames)) + (FINDSRC (libname) + "return a string name of the source file given the library file + name (eg PI) as a string" + (let (kaffile index alist result) + (setq kaffile + (concatenate 'string int "/" libname ".NRLIB/index.KAF*")) + (if (probe-file kaffile) + (with-open-file (kaf kaffile) + (setq index (read kaf)) + (file-position kaf index) + (setq alist (read kaf)) + (setq index (third (assoc "sourceFile" alist :test #'string=))) + (file-position kaf index) + (setq result (pathname-name (pathname (read kaf index)))))) + (format t "~a does not exist~%" kaffile) + result)) + (READINTERP () + "read INTERP.EXPOSED and return a sorted abbreviation list" + (let (expr names longnames) + (with-open-file (in (concatenate 'string int "/INTERP.EXPOSED")) + (catch 'eof + (loop + (setq expr (read-line in nil 'eof)) + (when (eq expr 'eof) (throw 'eof nil)) + (when + (and + (> (length expr) 58) + (char= (schar expr 0) #\space) + (not (char= (schar expr 8) #\space))) + (push (string-trim '(#\space) (subseq expr 8 57)) longnames) + (push (string-right-trim '(#\space) (subseq expr 58)) names))))) + (setq longnames (sort longnames #'string<)) + (setq names (sort names #'string<)) + (values names longnames))) + (READLIBS (algebra) + "read the NRLIB directory and return a sorted abbreviation list" + (let (libs nrlibs) +#+:akcl (si::chdir algebra) +#-:akcl (obey (concatenate 'string "cd " algebra)) + (setq nrlibs (directory "*.NRLIB")) + (unless nrlibs + (error "libcheck: (directory ~s) returned NIL~%" + (concatenate 'string algebra "/*.NRLIB"))) + (dolist (lib nrlibs) + (push (pathname-name lib) libs)) + (sort libs #'string<))) + (SEARCHSOURCE (sourcefile nrlib) + "search a sourcefile for the long constructor name of the nrlib string" + (let (in expr start) + (setq nrlib (concatenate 'string " " nrlib " ")) + (catch 'done + (with-open-file (in sourcefile) + (loop + (setq expr (read-line in nil 'done)) + (when (eq expr 'done) (throw 'done nil)) + (when (and (> (length expr) 4) + (string= ")abb" (subseq expr 0 4)) + (search nrlib expr :test #'string=) + (setq start (position #\space expr :from-end t :test #'char=))) + (throw 'done (string-trim '(#\space) (subseq expr start))))))))) + (SRCABBREVS (sourcefile) + (let (in expr start end names longnames) + (catch 'done + (with-open-file (in sourcefile) + (loop + (setq expr (read-line in nil 'done)) + (when (eq expr 'done) (throw 'done nil)) + (when (and (> (length expr) 4) + (string= ")abb" (subseq expr 0 4))) + (setq point (position #\space expr :from-end t :test #'char=)) + (push (string-trim '(#\space) (subseq expr point)) longnames) + (setq mark + (position #\space + (string-right-trim '(#\space) + (subseq expr 0 (1- point))) :from-end t)) + (push (string-trim '(#\space) (subseq expr mark point)) names))))) + (values names longnames))) + (SRCSCAN () + (let (longnames names) +#+:gcl (system::chdir int) +#-:gcl (obey (concatenate 'string "cd " int)) + (setq spads (directory "*.spad")) + (dolist (spad spads) + (multiple-value-setq (short long) (srcabbrevs spad)) + (setq names (nconc names short)) + (setq longnames (nconc longnames long))) + (setq names (sort names #'string<)) + (setq longnames (sort longnames #'string<)) + (values names longnames)))) + (multiple-value-setq (abbrevs constructors) (readinterp)) + (setq nrlibs (readlibs int)) + (dolist (lib (set-difference nrlibs abbrevs :test #'string=)) + (format t "libcheck:~a/~a.NRLIB is not in INTERP.EXPOSED~%" int lib)) + (dolist (expose (set-difference abbrevs nrlibs :test #'string=)) + (format t "libcheck:~a is in INTERP.EXPOSED with no NRLIB~%" expose)) + (multiple-value-setq (srcabbrevs srcconstructors) (srcscan)) + (setq abbrevs (nocat abbrevs)) + (setq constructors (nocat constructors)) + (dolist (item (set-difference srcabbrevs abbrevs :test #'string=)) + (format t "libcheck:~a is in ~a but not in INTERP.EXPOSED~%" item + (findsrc item))) + (dolist (item (set-difference abbrevs srcabbrevs :test #'string=)) + (format t "libcheck:~a is in INTERP.EXPOSED but has no spad sourcfile~%" + item)) + (dolist (item (set-difference srcconstructors constructors :test #'string=)) + (format t "libcheck:~a is not in INTERP.EXPOSED~%" item)) + (dolist (item (set-difference constructors srcconstructors :test #'string=)) + (format t "libcheck:~a has no spad source file~%" item))))) + + diff --git a/src/interp/util.lisp.pamphlet b/src/interp/util.lisp.pamphlet deleted file mode 100644 index e43af5be..00000000 --- a/src/interp/util.lisp.pamphlet +++ /dev/null @@ -1,1557 +0,0 @@ -% Oh Emacs, this is a -*- Lisp -*- file, despite appearance. -\documentclass{article} -\usepackage{axiom} - -\title{\$SPAD/src/interp util.lisp} -\author{Timothy Daly} - -\begin{document} -\maketitle - -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - - -\section{util.lisp} - -This file is a collection of utility functions that are useful -for system level work. A couple of the functions, {\bf build-depsys} -and {\bf build-interpsys} interface to the src/interp/Makefile. - -A second group of related functions allows us to rebuild portions -of the system from the command prompt. This varies from rebuilding -individual files to whole directories. The most complex functions -like {\bf makespad} can rebuild the whole algebra tree. - -A third group of related functions are used to set up the -{\bf autoload} mechanism. These enable whole subsystems to -be kept out of memory until they are used. - -A fourth group of related functions are used to construct and -search Emacs TAGS files. - -A fifth group of related functions are some translated boot -functions we need to define here so they work and are available -at load time. - -\subsection{Building Depsys (build-depsys)} - -The {\bf depsys} image is one of the two images we build from -the src/interp subdirectory (the other is {\bf interpsys}). We -use {\bf depsys} as a compile-time image as it contains all of -the necessary functions and macros to compile any file. The -{\bf depsys} image is almost the same as an {\bf interpsys} -image but it does not have any autoload triggers or databases -loaded. -<>= -(defun build-depsys (load-files) -#+:CCL - (setq *package* (find-package "BOOT")) -#+:AKCL - (in-package "BOOT") - (mapcar #'load load-files) - (reroot) - #+:AKCL - (init-memory-config :cons 1000 :fixnum 400 :symbol 1000 :package 16 - :array 800 :string 1000 :cfun 200 :cpages 2000 - :rpages 2000 :hole 4000) ) -;; (init-memory-config :cons 500 :fixnum 200 :symbol 500 :package 8 -;; :array 400 :string 500 :cfun 100 :cpages 1000 -;; :rpages 1000 :hole 2000) ) - -@ - -\subsection{Building Interpsys (build-interpsys)} -\begin{verbatim} -;############################################################################ -;# autoload dependencies -;# -;# if you are adding a file which is to be autoloaded the following step -;# information is useful: -;# there are 2 cases: -;# 1) adding files to currently autoloaded parts -;# (as of 2/92: browser old parser and old compiler) -;# 2) adding new files -;# case 1: -;# a) you have to add the file to the list of files currently there -;# (e.g. see BROBJS above) -;# b) add an autolaod rule -;# (e.g. ${AUTO}/parsing.${O}: ${OUT}/parsing.${O}) -;# c) edit util.lisp to add the 'external' function (those that -;# should trigger the autoload -;# case 2: -;# build-interpsys (in util.lisp) needs an extra argument for the -;# new autoload things and several functions in util.lisp need hacking. -;############################################################################ -\end{verbatim} -The {\bf build-interpsys} function takes a list of files to load -into the image ({\bf load-files}). It also takes several lists of files, -one for each subsystem which will be autoloaded. Autoloading is explained -below. This function is called in the src/interp/Makefile. - -This function calls {\bf reroot} to set up pathnames we need. Next -it sets up the lisp system memory (at present only for AKCL/GCL). Next -it loads all of the named files, resets a few global state variables, -loads the databases, sets up autoload triggers and clears out hash tables. -After this function is called the image is clean and can be saved. -<>= -(defun build-interpsys (load-files - translate-files nagbr-files asauto-files) - (reroot) - #+:AKCL - (init-memory-config :cons 500 :fixnum 200 :symbol 500 :package 8 - :array 400 :string 500 :cfun 100 :cpages 1000 - :rpages 1000 :hole 2000) - <> - (mapcar #'|AxiomCore|::|importModule| load-files) - (|resetWorkspaceVariables|) - (|initHist|) - (|initNewWorld|) - (compressopen) - (interpopen) - (create-initializers) - (|start| :fin) -#+:CCL - (resethashtables) - (setq *load-verbose* nil) - (|setBootAutloadProperties| translate-functions translate-files) - (|setNAGBootAutloadProperties| nagbr-functions nagbr-files) - (|setBootAutloadProperties| asauto-functions asauto-files) - (setf (symbol-function 'boot::|addConsDB|) #'identity) - (resethashtables) ; the databases into core, then close the streams - ) - -@ - -\subsubsection{GCL porting changes} - -GCL likes to output lines of the form: -\begin{verbatim} -;; Note: Tail-recursive call of |matSuperList1| was replaced by iteration. -\end{verbatim} -which is pointless and should be removed. Bill Schelter added this while -he was debugging tail-recursive replacement and it never was removed. -<>= - #+:AKCL - (setq compiler::*suppress-compiler-notes* t) -@ - - -\subsection{The variables} - -Various lisps use different ``extensions'' on the filename to indicate -that a file has been compiled. We set this variable correctly depending -on the system we are using. -<>= -(defvar *bin-path* - #+kcl "o" - #+lucid "bbin" - #+symbolics "bin" - #+cmulisp "fasl" - #+:ccl "not done this way at all") - -@ - - -\subsubsection{relative-directory-list} - -The relative directory list specifies a search path for files -for the current directory structure. It has been changed from the -NAG distribution back to the original form. -<>= -(defvar $relative-directory-list - '("/../../src/input/" - "/share/msgs/" - "/../../src/algebra/" - "/../../src/interp/" ; for boot and lisp files (helps fd) - "/doc/spadhelp/" )) - -@ - - -\subsubsection{relative-library-directory-list} - -The relative directory list specifies how to find the algebra -directory from the current {\bf AXIOM} shell variable. -<>= -(defvar $relative-library-directory-list '("/algebra/")) - -@ - - -\subsection{The autoload list} - -There are several subsystems within {\bf AXIOM} that are not normally -loaded into a running system. They will be loaded only if you invoke -one of the functions listed here. Each of these listed functions will -have their definitions replaced by a special ``autoloader'' function. -The first time a function named here is called it will trigger a -load of the associated subsystem, the autoloader functions will get -overwritten, the function call is retried and now succeeds. Files -containing functions listed here are assumed to exist in the -{\bf autoload} subdirectory. The list of files to load is defined -in the src/interp/Makefile. - -\subsubsection{setBootAutloadProperties} - -This function is called by {\bf build-interpsys}. It takes two lists. -The first is a list of functions that need to be used as -``autoload triggers''. The second is a list of files to load if one -of the trigger functions is called. At system build time each of the -functions in the first list is set up to load every file in the second -list. In this way we will automatically load a whole subsystem if we -touch any function in that subsystem. We call a helper function -called {\bf setBootAutoLoadProperty} to set up the autoload trigger. -This helper function is listed below. -<>= -(defun |setBootAutloadProperties| (fun-list file-list) -#+:AKCL - (mapc #'(lambda (fun) (|setBootAutoLoadProperty| fun file-list)) fun-list) -#+:CCL - (mapc #'(lambda (fun) (lisp::set-autoload fun file-list)) fun-list) -) - -@ - -\subsubsection{setBootAutoLoadProperty} - -This is a helper function to set up the autoload trigger. It sets -the function cell of each symbol to {\bf mkBootAutoLoad} which is -listed below. -<>= -(defun |setBootAutoLoadProperty| (func file-list) - (setf (symbol-function func) (|mkBootAutoLoad| func file-list)) ) - -@ - -\subsubsection{mkBootAutoLoad} - -This is how the autoload magic happens. Every function named in the -autoload lists is actually just another name for this function. When -the named function is called we call {\bf boot-load} on all of the -files in the subsystem. This overwrites all of the autoload triggers. -We then look up the new (real) function definition and call it again -with the real arguments. Thus the subsystem loads and the original -call succeeds. -<>= -(defun |mkBootAutoLoad| (fn file-list) - (function (lambda (&rest args) - (mapc #'boot-load file-list) - (unless (string= (subseq (string fn) 0 4) "LOAD") - (apply (symbol-function fn) args))))) - -@ - -\subsubsection{boot-load} - -This function knows where the {\bf autoload} subdirectory lives. -It is called by {\bf mkBootAutoLoad} above to find the necessary -files. -<>= -(defun boot-load (file) - (let ((name (concat (|systemRootDirectory|) - "/autoload/" - (pathname-name file)))) - (if |$printLoadMsgs| - (format t " Loading ~A.~%" name)) - (load name))) - -@ - -\subsubsection{setNAGBootAutloadProperties} - -This is a further refinement of the autoload scheme. Since the -Numerical Algorithms Group (NAG) fortran library contains many -functions we subdivide the NAG library subsystem into chapters. -We use a different helper function {\bf get-NAG-chapter} to decide -which files to load. -<>= -(defun |setNAGBootAutloadProperties| (function-list file-list) - (mapcar - #'(lambda (f) - (|setBootAutloadProperties| - (get-NAG-chapter (chapter-name f) function-list) - (nag-files f file-list))) - file-list)) - -@ - -\subsubsection{get-NAG-chapter} - -This function is used to find the names of the files to load. -On solaris 9 under GCL the original implementation will fail because -the max number of arguments is 63. We rewrite it to get around this -problem. It originally read: -\begin{verbatim} -(defun get-NAG-chapter (chapter function-list) - (apply 'append - (mapcar - #'(lambda (f) - (cond - ((equalp chapter (subseq (string f) 0 (length chapter))) (list f )))) - function-list))) - -\end{verbatim} -<>= -(defun get-NAG-chapter (chapter function-list) - (let ((l (length chapter)) r) - (dolist (f function-list) - (when (equalp chapter (subseq (string f) 0 l)) - (push f r))) - (nreverse r))) - -@ - -\subsubsection{nag-files} - -We analyze the function names to decide which chapter we are in. -We load files based on the chapter. -<>= -(defun nag-files (filename filelist) - (apply 'append (mapcar - #'(lambda (f) - (cond ((equalp (chapter-name filename) (chapter-name f)) (list f))) ) - filelist))) - -@ - -\subsubsection{chapter-name} - -The library names follow a convention that allows us to extract -the chapter name. -<>= -(defun chapter-name (f) -#+:AKCL - (apply - #'(lambda (s) - (cond ((equalp (aref s 0) #\s) "s") (T (reverse (subseq s 0 3))))) - (list (string-left-trim "a.o" (reverse f) )) ) -#+:CCL - (subseq (string-downcase (string f)) 4 (length (string f))) -) - -@ - -\subsubsection{translate-functions} - -This is a little used subsystem to generate {\bf ALDOR} code -from {\bf Spad} code. Frankly, I'd be amazed if it worked. -<>= -(setq translate-functions '( -;; .spad to .as translator, in particular -;; loadtranslate - |spad2AsTranslatorAutoloadOnceTrigger| - )) - -@ - -\subsubsection{asauto-functions} - -This is part of the {\bf ALDOR subsystem}. These will be loaded -if you compile a {\bf .as} file rather than a {\bf .spad} file. -{\bf ALDOR} is an external compiler that gets automatically called -if the file extension is {\bf .as}. -<>= -(setq asauto-functions '( - loadas -;; |as| ;; now in as.boot -;; |astran| ;; now in as.boot - |spad2AxTranslatorAutoloadOnceTrigger| - |sourceFilesToAxcliqueAxFile| - |sourceFilesToAxFile| - |setExtendedDomains| - |makeAxFile| - |makeAxcliqueAxFile| - |nrlibsToAxFile| - |attributesToAxFile| )) - -@ - -\subsubsection{debug-functions} - -These are some {\bf debugging} functions that I use. I can't imagine -why you might autoload them but they don't need to be in a running -system. -<>= -(setq debug-functions '( - loaddebug - |showSummary| - |showPredicates| - |showAttributes| - |showFrom| - |showImp|)) - -@ - -\subsubsection{anna-functions} - -The {\bf ANNA} subsystem, invoked thru {\bf hypertex}, is an -expert system that understands the Numerical Algorithms Group (NAG) -fortran library. -<>= -(setq anna-functions '( - |annaInt| - |annaMInt| - |annaOde| - |annaOpt| - |annaOpt2| - |annaPDESolve| - |annaOptDefaultSolve1| - |annaOptDefaultSolve2| - |annaOptDefaultSolve3| - |annaOptDefaultSolve4| - |annaOptDefaultSolve5| - |annaOpt2DefaultSolve| - |annaFoo| - |annaBar| - |annaJoe| - |annaSue| - |annaAnn| - |annaBab| - |annaFnar| - |annaDan| - |annaBlah| - |annaTub| - |annaRats| - |annaMInt| - |annaOdeDefaultSolve1| - |annaOdeDefaultSolve2|)) - -@ - -\subsubsection{nagbr-functions} - -The Numerical Algorithms Group (NAG) fortran library has a set -of cover functions. These functions need to be loaded if you use -the NAG library. -<>= -(setq nagbr-functions '( - loadnag - |c02aff| |c02agf| - |c05adf| |c05nbf| |c05pbf| - |c06eaf| |c06ebf| |c06ecf| |c06ekf| |c06fpf| |c06fqf| |c06frf| - |c06fuf| |c06gbf| |c06gcf| |c06gqf| |c06gsf| - |d01ajf| |d01akf| |d01alf| |d01amf| |d01anf| |d01apf| |d01aqf| - |d01asf| |d01bbf| |d01fcf| |d01gaf| |d01gbf| - |d02bbf| |d02bhf| |d02cjf| |d02ejf| |d02gaf| |d02gbf| |d02kef| - |d02raf| - |d03edf| |d03eef| |d03faf| - |e01baf| |e01bef| |e01bff| |e01bgf| |e01bhf| |e01daf| |e01saf| - |e01sbf| |e01sef| - |e02adf| |e02aef| |e02agf| |e02ahf| |e02ajf| |e02akf| |e02baf| - |e02bbf| |e02bcf| |e02bdf| |e02bef| |e02daf| |e02dcf| - |e02ddf| |e02def| |e02dff| |e02gaf| |e02zaf| - |e04dgf| |e04fdf| |e04gcf| |e04jaf| |e04mbf| |e04naf| |e04ucf| - |e04ycf| - |f01brf| |f01bsf| |f01maf| |f01mcf| |f01qcf| |f01qdf| |f01qef| - |f01rcf| |f01rdf| |f01ref| - |f02aaf| |f02abf| |f02adf| |f02aef| |f02aff| |f02agf| |f02ajf| - |f02akf| |f02awf| |f02axf| |f02bbf| |f02bjf| |f02fjf| - |f02wef| |f02xef| - |f04adf| |f04arf| |f04asf| |f04atf| |f04axf| |f04faf| |f04jgf| - |f04maf| |f04mbf| |f04mcf| |f04qaf| - |f07adf| |f07aef| |f07fdf| |f07fef| - |s01eaf| |s13aaf| |s13acf| |s13adf| |s14aaf| |s14abf| |s14baf| - |s15adf| |s15aef| |s17acf| |s17adf| |s17aef| |s17aff| - |s17agf| |s17ahf| |s17ajf| |s17akf| |s17dcf| |s17def| - |s17dgf| |s17dhf| |s17dlf| |s18acf| |s18adf| |s18aef| - |s18aff| |s18dcf| |s18def| |s19aaf| |s19abf| |s19acf| - |s19adf| |s20acf| |s20adf| |s21baf| |s21bbf| |s21bcf| - |s21bdf| - )) - -@ - - -\subsection{The command-line build functions} - -\subsubsection{translist} - -Translate a list of boot files to common lisp. -<>= -(defun translist (fns) - (mapcar #'(lambda (f) (format t "translating ~a~%" (concat f ".boot")) - (translate f)) - fns)) - -@ - -\subsubsection{translate} - -Translate a single boot file to common lisp -<>= -(defun translate (file) ;; translates a single boot file -#+:CCL - (setq *package* (find-package "BOOT")) -#+:AKCL - (in-package "BOOT") - (let (*print-level* *print-length* (fn (pathname-name file)) - (bootfile (merge-pathnames file (concat (|systemRootDirectory|) "nboot/.boot")))) - (declare (special *print-level* *print-length*)) - (boot bootfile (make-pathname :type "lisp" :defaults bootfile)))) - -@ - -\subsubsection{compile-boot-file} - -Translate a single boot file to common lisp, compile it -and load it. -<>= -(defun compile-boot-file (file) - "compile and load a boot file" - (boot (concat file ".boot") (concat file ".lisp")) -#+:AKCL - (compile-file (concat file ".lisp")) -#+:AKCL - (load (concat file "." *bin-path*)) -#+:CCL - (load (concat file ".lisp")) -) - -@ - -\subsubsection{retranslate-file-if-necessary} - -Retranslate a single boot file if it has been changed. -<>= -(defun retranslate-file-if-necessary (bootfile) - (let* ((lfile (make-pathname :type "lisp" :defaults bootfile)) - (ldate (our-write-date lfile)) - (binfile (make-pathname :type *bin-path* :defaults bootfile)) - (bindate (our-write-date binfile)) - (bootdate (our-write-date bootfile))) - (if (and ldate bootdate (> ldate bootdate)) nil - (if (and bindate bootdate (> bindate bootdate)) nil - (progn (format t "translating ~a~%" bootfile) - (boot bootfile lfile) (list bootfile)))))) - -@ - -\subsubsection{retranslate-directory} - -Translate a directory of boot code to common lisp if the boot code -is newer. -<>= -(defun retranslate-directory (dir) - (let* ((direc (make-directory dir)) - (pattern (make-pathname :directory (pathname-directory direc) - :name :wild :type "boot")) - (files (directory pattern))) - (mapcan #'retranslate-file-if-necessary files))) - -@ - -\subsubsection{recompile-NRLIB-if-necessary} - -Recompile a single library's lisp file if it is out of date. -The {\bf recompile-lib-file-if-necessary} is defined in nlib.lisp. -<>= -(defun recompile-NRLIB-if-necessary (lib) - (recompile-lib-file-if-necessary (concat (namestring lib) "/code.lsp")) - (lift-NRLIB-name (namestring lib))) - -@ - -\subsubsection{lift-NRLIB-name} - -We used to use FOO.NRLIB/code.o files for algebra. However there -was no need for this additional level of indirection since the rest -of the information in an NRLIB is now kept in the daase files. Thus -we lift the FOO.NRLIB/code.o to FOO.o in the final system. -<>= -(defun lift-NRLIB-name (f) - (obey (concat "cp " f "/code.o " (subseq f 0 (position #\. f)) ".o")) - nil) - -@ - -\subsubsection{recompile-lib-directory} - -Recompile library lisp code if necessary. -<>= -(defun recompile-lib-directory (dir) - (let* ((direc (make-directory dir)) - (pattern (make-pathname :directory (pathname-directory direc) - :name :wild :type "NRLIB")) - (files (directory pattern))) - (mapcan #'recompile-NRLIB-if-necessary files))) - -@ - -\subsubsection{recompile-all-files} - -Force recompilation of all lisp files in a directory. -<>= -(defun recompile-all-files (dir) - (let* ((direc (make-directory dir)) - (pattern (make-pathname :directory (pathname-directory direc) - :name :wild :type "lisp")) - (files (directory pattern))) - (mapcar #'compile-file files))) - -@ - -\subsubsection{recompile-directory} - -This function will compile any lisp code that has changed in a directory. -<>= -(defun recompile-directory (dir) - (let* ((direc (make-directory dir)) - (pattern (make-pathname :directory (pathname-directory direc) - :name :wild :type "lisp")) - (files (directory pattern))) - (mapcan #'recompile-file-if-necessary files))) - -@ - -\subsubsection{recompile-file-if-necessary} - -This is a helper function that checks the time stamp between -the given file and its compiled binary. If the file has changed -since it was last compiled this function will recompile it. -<>= -(defun recompile-file-if-necessary (lfile) - (let* ((bfile (make-pathname :type *bin-path* :defaults lfile)) - (bdate (our-write-date bfile)) - (ldate (our-write-date lfile))) - (if (and bdate ldate (> bdate ldate)) nil - (progn - (format t "compiling ~a~%" lfile) - (compile-file lfile) - (list bfile))))) - -@ - -\subsubsection{our-write-date} - -Get the write date of a file. In GCL we need to check that it -exists first. This is a simple helper function. -<>= -(defun our-write-date (file) (and #+kcl (probe-file file) - (file-write-date file))) - -@ - -\subsubsection{fe} - -I'm unsure what this does but I believe it is related to an interpreter -command. Invoking ``)fe'' in the interpreter tries to get at the -src/interp/TAGS file. -<>= -(defun fe (function file &optional (compflag nil) &aux (fn (pathname-name file))) - (let ((tbootfile (concat "/tmp/" fn ".boot")) - (tlispfile (concat "/tmp/" fn ".lisp"))) - (system::run-aix-program "fc" - :arguments (list (string function) - (namestring - (merge-pathnames file - (concat (|systemRootDirectory|) - "nboot/.boot")))) - :if-output-exists :supersede :output tbootfile) - (boot tbootfile tlispfile) - (if compflag (progn (compile-file tlispfile) - (load (make-pathname :type *bin-path* :defaults tlispfile))) - (load tlispfile)))) -@ - -\subsubsection{fc} - -I'm unsure what this does but I believe it is related to an interpreter -command. Invoking ``)fc'' in the interpreter tries to get at the -src/interp/TAGS file. -<>= -(defun fc (function file) (fe function file t)) - -@ - -\subsubsection{compspadfiles} - -The {\bf compspadfiles} function will recompile a list of {\bf spad} files. -The filelist should be a file containing names of files to compile. -<>= -(defun compspadfiles (filelist ;; should be a file containing files to compile - &optional (*default-pathname-defaults* - (pathname (concat (|systemRootDirectory|) - "nalgebra/")))) - (with-open-file (stream filelist) - (do ((fname (read-line stream nil nil) (read-line stream nil nil))) - ((null fname) 'done) - (setq fname (string-right-trim " *" fname)) - (when (not (equal (elt fname 0) #\*)) - (spad fname (concat (pathname-name fname) ".out")))))) - -@ - -\subsubsection{load-directory} - -Load a whole subdirectory of compiled files -<>= -(defun load-directory (dir) - (let* ((direc (make-directory dir)) - (pattern (make-pathname :directory (pathname-directory direc) - :name :wild :type *bin-path*)) - (files (directory pattern))) - (mapcar #'load files))) - -@ - -\subsubsection{interp-make-directory} - -This is used by the ")cd" system command. -<>= -(defun interp-make-directory (direc) - (setq direc (namestring direc)) - (if (string= direc "") $current-directory - (if (or (memq :unix *features*) - (memq 'unix *features*)) - (progn - (if (char/= (char $current-directory (1-(length $current-directory))) #\/) - (setq $current-directory (concat $current-directory "/"))) - (if (char/= (char direc 0) #\/) - (setq direc (concat $current-directory direc))) - (if (char/= (char direc (1- (length direc))) #\/) - (setq direc (concat direc "/"))) - direc) - (progn ;; Assume Windows conventions - (if (not (or (char= (char $current-directory (1- (length $current-directory))) #\/) - (char= (char $current-directory (1- (length $current-directory))) #\\ ))) - (setq $current-directory (concat $current-directory "\\"))) - (if (not (or (char= (char direc 0) #\/) - (char= (char direc 0) #\\) - (find #\: direc))) - (setq direc (concat $current-directory direc))) - (if (not (or (char= (char direc (1- (length direc))) #\/) - (char= (char direc (1- (length direc))) #\\ ))) - (setq direc (concat direc "\\"))) - direc)))) - -@ - -\subsubsection{make-directory} - -Make a directory relative to the running system root directory. -<>= -(defun make-directory (direc) - (setq direc (namestring direc)) - (if (string= direc "") (|systemRootDirectory|) - (if (or (memq :unix *features*) - (memq 'unix *features*)) - (progn - (if (char/= (char direc 0) #\/) - (setq direc (concat (|systemRootDirectory|) "/" direc))) - (if (char/= (char direc (1- (length direc))) #\/) - (setq direc (concat direc "/"))) - direc) - (progn ;; Assume Windows conventions - (if (not (or (char= (char direc 0) #\/) - (char= (char direc 0) #\\) - (find #\: direc))) - (setq direc (concat (|systemRootDirectory|) "\\" direc))) - (if (not (or (char= (char direc (1- (length direc))) #\/) - (char= (char direc (1- (length direc))) #\\ ))) - (setq direc (concat direc "\\"))) - direc)))) - -@ - -\subsubsection{recompile-all-libs} - -Occasionally it will be necessary to iterate over all of the NRLIB -directories and compile each of the code.lsp files in every NRLIB. -This function will do that. A correct call looks like: -\begin{verbatim} -(in-package "BOOT") -(recompile-all-libs "/spad/mnt/${SYS}/algebra") -\end{verbatim} -where the [[${SYS}]] variable is same as the one set at build time. -<>= -(defun recompile-all-libs (dir) - (let* ((direc (make-directory dir)) - (pattern (make-pathname :directory (pathname-directory direc) - :name :wild :type "NRLIB")) - (files (directory pattern))) - (mapcar - #'(lambda (lib) (compile-lib-file (concat (namestring lib) "/code.lsp"))) - files))) - -@ - -\subsubsection{recompile-all-algebra-files} - -We occasionally need to completely rebuild the algebra from the spad -files. This function will iterate across a directory containing all -of the spad files and attempt to recompile them. A correct call looks -like: -\begin{verbatim} -(in-package "BOOT") -(recompile-all-algebra-files "nalg") -\end{verbatim} -Note that it will build a pathname from the current {\bf AXIOM} -shell variable. So if the {\bf AXIOM} shell variable had the value -\begin{verbatim} -/spad/mnt/${SYS} -\end{verbatim} -(where the [[${SYS}]] variable is the same one set at build time) -then the wildcard expands to -\begin{verbatim} -/spad/mnt/${SYS}/nalg/*.spad -\end{verbatim} -and all of the matching files would be recompiled. -<>= -(defun recompile-all-algebra-files (dir) ;; a desperation measure - (let* ((direc (make-directory dir)) - (pattern (make-pathname :directory (pathname-directory direc) - :name :wild :type "spad")) - (files (directory pattern)) - (*default-pathname-defaults* (pathname direc))) - (mapcar - #'(lambda (fname) (spad fname (concat (pathname-name fname) ".out"))) - files))) - -@ - -\subsubsection{boottocl} - -The {\bf boottocl} function is the workhorse function that translates -{\bf .boot} files to {\bf Common Lisp}. It basically wraps the actual -{\bf boot} function call to ensure that we don't truncate lines -because of {\bf *print-level*} or {\bf *print-length*}. -<>= -(in-package "OLD-BOOT") - -(defun boot (file) ;; translates a single boot file -#+:CCL - (setq *package* (find-package "BOOT")) -#+:AKCL - (in-package "BOOT") - (let (*print-level* - *print-length* - (fn (pathname-name file)) - (*print-pretty* t)) - (declare (special *print-level* *print-length*)) - (boot::boot - file - (merge-pathnames (make-pathname :type "clisp") file)))) - -@ - -\subsubsection{yearweek} - -We need a way of distinguishing different versions of the system. -There used to be a way to touch the src/timestamp file whenever -you checked in a change to the change control subsystem. -During make PART=interp (the default for make) we set timestamp -to the filename of this timestamp file. This function converts it -to a luser readable string and sets the *yearweek* variable. - -The result of this function is a string that is printed as a banner -when Axiom starts. The actual printing is done by the function -[[spadStartUpMsgs]] in [[src/interp/msgdb.boot]]. It uses a -format string from the file [[src/doc/msgs/s2-us.msgs]]. -<>= -(defun yearweek () - "set *yearweek* to the current time string for the version banner" - (declare (special timestamp) (special *yearweek*)) - (if (and (boundp 'timestamp) (probe-file timestamp)) - (let (sec min hour date month year day dayvec monvec) - (setq dayvec '("Monday" "Tuesday" "Wednesday" "Thursday" - "Friday" "Saturday" "Sunday")) - (setq monvec '("January" "February" "March" "April" "May" "June" - "July" "August" "September" "October" "November" - "December")) - (multiple-value-setq (sec min hour date month year day) - (decode-universal-time - (file-write-date timestamp))) - (setq *yearweek* - (copy-seq - (format nil "~a ~a ~d, ~d at ~2,'0d:~2,'0d:~2,'0d " - (elt dayvec day) - (elt monvec (1- month)) date year hour min sec)))) - (setq *yearweek* "no timestamp"))) - -@ - -\subsubsection{makelib} - -Make will not compare dates across directories. -Rather than copy all of the code.lsp files to the MNT directory -we run this function to compile the files that are out of date -this function assumes that the shell variables INT and MNT are set. - -Also of note: on the rt some files (those in the nooptimize list) -need to be compiled without optimize due to compiler bugs -<>= -(defun makelib (mid out stype btype) - "iterate over the NRLIBs, compiling ones that are out of date. - mid is the directory containing code.lsp - out is the directory containing code.o" - (let (libs lspdate odate nooptimize (alphabet #\space)) -#+(and :akcl :rt) - (setq nooptimize '("FFCAT-.NRLIB" "CHVAR.NRLIB" "PFO.NRLIB" "SUP.NRLIB" - "INTG0.NRLIB" "FSPRMELT.NRLIB" "VECTOR.NRLIB" - "EUCDOM-.NRLIB")) - (if (and mid out) - (format t "doing directory on ~s...~%" (concatenate 'string mid "/*")) - (error "makelib:MID=~a OUT=~a~% these are not set properly~%" mid out)) -#+:akcl (compiler::emit-fn nil) -#+:akcl (si::chdir mid) -#-:akcl (obey (concatenate 'string "cd " mid)) - (setq libs (directory "*.NRLIB")) - (unless libs - (format t "makelib:directory of ~a returned NIL~%" mid) - (bye -1)) - (princ "checking ") - (dolist (lib libs) - (unless (char= (schar (pathname-name lib) 0) alphabet) - (setq alphabet (schar (pathname-name lib) 0)) - (princ alphabet) - (finish-output)) - (let (dotlsp doto mntlib intkaf mntkaf intkafdate mntkafdate) - (setq dotlsp - (concatenate 'string mid "/" (file-namestring lib) "/code." stype)) - (setq doto - (concatenate 'string out "/" (pathname-name lib) ".NRLIB/code." btype)) - (setq mntlib - (concatenate 'string out "/" (pathname-name lib) ".NRLIB")) - (setq intkaf - (concatenate 'string mid "/" (file-namestring lib) "/index.KAF*")) - (setq mntkaf - (concatenate 'string out "/" (pathname-name lib) ".NRLIB/index.KAF*")) - (unless (probe-file mntlib) - (format t "creating directory ~a~%" mntlib) - (obey (concatenate 'string "cp -pr " (namestring lib) " " out)) - (when (probe-file (concatenate 'string mntlib "/code." stype)) - (delete-file (concatenate 'string mntlib "/code." stype)))) - (setq intkafdate (and (probe-file intkaf) (file-write-date intkaf))) - (setq mntkafdate (and (probe-file mntkaf) (file-write-date mntkaf))) - (when intkafdate - (unless (and mntkafdate (> mntkafdate intkafdate)) - (format t "~©ing ~s to ~s" intkaf mntkaf) - (obey - (concatenate 'string "cp " - (namestring intkaf) " " (namestring mntkaf))))) - (setq lspdate (and (probe-file dotlsp) (file-write-date dotlsp))) - (setq odate (and (probe-file doto) (file-write-date doto))) - (when lspdate - (unless (and odate (> odate lspdate)) -#+(and :akcl :rt) - (if (member (file-namestring lib) nooptimize :test #'string=) - (setq compiler::*speed* 0) - (setq compiler::*speed* 3)) - (compile-lib-file dotlsp :output-file doto))))))) - -@ - -\subsubsection{makespad} - -Make will not compare dates across directories. -In particular, it cannot compare the algebra files because there -is a one-to-many correspondence. This function will walk over -all of the algebra NRLIB files and find all of the spad files -that are out of date and need to be recompiled. This function -creates a file "/tmp/compile.input" to be used later in the -makefile. - -Note that the file /tmp/compile.input is not currently used -as algebra source recompiles are not necessarily something -we want done automatically. Nevertheless, in the quest for -quality we check anyway. -<>= -(defun makespad (src mid stype) - "iterate over the spad files, compiling ones that are out of date. - src is the directory containing .spad - mid is the directory containing code.lsp - out is the directory containing code.o" - (let (mntlibs spadwork (alphabet #\space)) - (labels ( - (findsrc (mid libname) - "return a string name of the source file given the library file - name (eg PI) as a string" - (let (kaffile index alist) - (setq kaffile - (concatenate 'string mid "/" libname ".NRLIB/index.KAF*")) - (with-open-file (kaf kaffile) - (setq index (read kaf)) - (file-position kaf index) - (setq alist (read kaf)) - (setq index (third (assoc "sourceFile" alist :test #'string=))) - (file-position kaf index) - (pathname-name (pathname (read kaf index))))))) - (format t "makespad:src=~s mid=~s stype=~s~%" src mid stype) - (if (and src mid) - (format t "doing directory on ~s...~%" (concatenate 'string src "/*")) - (error "makespad:SRC=~a MID=~a not set properly~%" src mid)) -#+:akcl (si::chdir mid) -#-:akcl (obey (concatenate 'string "cd " mid)) - (setq mntlibs (directory "*.NRLIB")) - (unless mntlibs - (format t "makespad:directory of ~a returned NIL~%" src) - (bye 1)) - (princ "checking ") - (dolist (lib mntlibs) - (unless (char= (schar (pathname-name lib) 0) alphabet) - (setq alphabet (schar (pathname-name lib) 0)) - (princ alphabet) - (finish-output)) - (let (spad spaddate lsp lspdate) - (setq spad - (concatenate 'string src "/" (findsrc mid (pathname-name lib)) ".spad")) - (setq spaddate - (and (probe-file spad) (file-write-date spad))) - (setq lsp - (concatenate 'string mid "/" (pathname-name lib) ".NRLIB/code." stype)) - (setq lspdate - (and (probe-file lsp) (file-write-date lsp))) - (cond - ((and spaddate lspdate (<= spaddate lspdate))) - ((and spaddate lspdate (> spaddate lspdate)) - (setq spadwork (adjoin spad spadwork :test #'string=))) - ((and spaddate (not lspdate)) - (setq spadwork (adjoin spad spadwork :test #'string=))) - ((and (not spaddate) lspdate) - (format t "makespad:missing spad file ~a for lisp file ~a~%" spad lsp)) - ((and (not spaddate) (not lspdate)) - (format t "makespad:NRLIB ~a exist but is spad ~a and lsp ~a don't~%" - lib spad lsp))))) - (with-open-file (tmp "/tmp/compile.input" :direction :output) - (dolist (spad spadwork) - (format t "~a is out of date~%" spad) - (format tmp ")co ~a~%" spad)))))) - -@ - -\subsubsection{libcheck} - -We need to ensure that the INTERP.EXPOSED list, which is a list -of the exposed constructors, is consistent with the actual libraries. -<>= -(defun libcheck (int) - "check that INTERP.EXPOSED and NRLIBs are consistent" - (let (interp nrlibs) - (labels ( - (CONSTRUCTORNAME (nrlib) - "find the long name of a constructor given an abbreviation string" - (let (file sourcefile name) - (setq file (findsrc nrlib)) - (setq sourcefile - (concatenate 'string int "/" file ".spad")) - (when (and file (probe-file sourcefile)) - (setq name (searchsource sourcefile nrlib))))) - (NOCAT (longnames) - "remove the categories from the list of long names" - (remove-if - #'(lambda (x) - (let ((c (schar x (1- (length x))))) - (or (char= c #\&) (char= c #\-)))) longnames)) - (FINDSRC (libname) - "return a string name of the source file given the library file - name (eg PI) as a string" - (let (kaffile index alist result) - (setq kaffile - (concatenate 'string int "/" libname ".NRLIB/index.KAF*")) - (if (probe-file kaffile) - (with-open-file (kaf kaffile) - (setq index (read kaf)) - (file-position kaf index) - (setq alist (read kaf)) - (setq index (third (assoc "sourceFile" alist :test #'string=))) - (file-position kaf index) - (setq result (pathname-name (pathname (read kaf index)))))) - (format t "~a does not exist~%" kaffile) - result)) - (READINTERP () - "read INTERP.EXPOSED and return a sorted abbreviation list" - (let (expr names longnames) - (with-open-file (in (concatenate 'string int "/INTERP.EXPOSED")) - (catch 'eof - (loop - (setq expr (read-line in nil 'eof)) - (when (eq expr 'eof) (throw 'eof nil)) - (when - (and - (> (length expr) 58) - (char= (schar expr 0) #\space) - (not (char= (schar expr 8) #\space))) - (push (string-trim '(#\space) (subseq expr 8 57)) longnames) - (push (string-right-trim '(#\space) (subseq expr 58)) names))))) - (setq longnames (sort longnames #'string<)) - (setq names (sort names #'string<)) - (values names longnames))) - (READLIBS (algebra) - "read the NRLIB directory and return a sorted abbreviation list" - (let (libs nrlibs) -#+:akcl (si::chdir algebra) -#-:akcl (obey (concatenate 'string "cd " algebra)) - (setq nrlibs (directory "*.NRLIB")) - (unless nrlibs - (error "libcheck: (directory ~s) returned NIL~%" - (concatenate 'string algebra "/*.NRLIB"))) - (dolist (lib nrlibs) - (push (pathname-name lib) libs)) - (sort libs #'string<))) - (SEARCHSOURCE (sourcefile nrlib) - "search a sourcefile for the long constructor name of the nrlib string" - (let (in expr start) - (setq nrlib (concatenate 'string " " nrlib " ")) - (catch 'done - (with-open-file (in sourcefile) - (loop - (setq expr (read-line in nil 'done)) - (when (eq expr 'done) (throw 'done nil)) - (when (and (> (length expr) 4) - (string= ")abb" (subseq expr 0 4)) - (search nrlib expr :test #'string=) - (setq start (position #\space expr :from-end t :test #'char=))) - (throw 'done (string-trim '(#\space) (subseq expr start))))))))) - (SRCABBREVS (sourcefile) - (let (in expr start end names longnames) - (catch 'done - (with-open-file (in sourcefile) - (loop - (setq expr (read-line in nil 'done)) - (when (eq expr 'done) (throw 'done nil)) - (when (and (> (length expr) 4) - (string= ")abb" (subseq expr 0 4))) - (setq point (position #\space expr :from-end t :test #'char=)) - (push (string-trim '(#\space) (subseq expr point)) longnames) - (setq mark - (position #\space - (string-right-trim '(#\space) - (subseq expr 0 (1- point))) :from-end t)) - (push (string-trim '(#\space) (subseq expr mark point)) names))))) - (values names longnames))) - (SRCSCAN () - (let (longnames names) -#+:gcl (system::chdir int) -#-:gcl (obey (concatenate 'string "cd " int)) - (setq spads (directory "*.spad")) - (dolist (spad spads) - (multiple-value-setq (short long) (srcabbrevs spad)) - (setq names (nconc names short)) - (setq longnames (nconc longnames long))) - (setq names (sort names #'string<)) - (setq longnames (sort longnames #'string<)) - (values names longnames)))) - (multiple-value-setq (abbrevs constructors) (readinterp)) - (setq nrlibs (readlibs int)) - (dolist (lib (set-difference nrlibs abbrevs :test #'string=)) - (format t "libcheck:~a/~a.NRLIB is not in INTERP.EXPOSED~%" int lib)) - (dolist (expose (set-difference abbrevs nrlibs :test #'string=)) - (format t "libcheck:~a is in INTERP.EXPOSED with no NRLIB~%" expose)) - (multiple-value-setq (srcabbrevs srcconstructors) (srcscan)) - (setq abbrevs (nocat abbrevs)) - (setq constructors (nocat constructors)) - (dolist (item (set-difference srcabbrevs abbrevs :test #'string=)) - (format t "libcheck:~a is in ~a but not in INTERP.EXPOSED~%" item - (findsrc item))) - (dolist (item (set-difference abbrevs srcabbrevs :test #'string=)) - (format t "libcheck:~a is in INTERP.EXPOSED but has no spad sourcfile~%" - item)) - (dolist (item (set-difference srcconstructors constructors :test #'string=)) - (format t "libcheck:~a is not in INTERP.EXPOSED~%" item)) - (dolist (item (set-difference constructors srcconstructors :test #'string=)) - (format t "libcheck:~a has no spad source file~%" item))))) - -@ - - -\subsection{Constructing TAGS} - -TAGS are useful for finding functions if you run Emacs. We have a -set of functions that construct TAGS files for Axiom. -\subsubsection{make-tags-file} -Run the etags command on all of the lisp code. Then run the -{\bf spadtags-from-directory} function on the boot code. The -final TAGS file is constructed in the {\bf tmp} directory. -<>= -(defun make-tags-file () -#+:gcl (system:chdir "/tmp") -#-:gcl (obey (concatenate 'string "cd " "/tmp")) - (obey (concat "etags " (make-absolute-filename "../../src/interp/*.lisp"))) - (spadtags-from-directory "../../src/interp" "boot") - (obey "cat /tmp/boot.TAGS >> /tmp/TAGS")) - -@ - -\subsubsection{spadtags-from-directory} - -This function will walk across a directory and call -{\bf spadtags-from-file} on each file. -<>= -(defun spadtags-from-directory (dir type) - (let* ((direc (make-directory dir)) - (pattern (make-pathname :directory (pathname-directory direc) - :name :wild :type type)) - (files (directory pattern))) - (with-open-file - (tagstream (concatenate 'string "/tmp/" type ".TAGS") :direction :output - :if-exists :supersede :if-does-not-exist :create) - (dolist (file files (namestring tagstream)) - (print (list "processing:" file)) - (write-char #\page tagstream) - (terpri tagstream) - (write-string (namestring file) tagstream) - (write-char #\, tagstream) - (princ (spadtags-from-file file) tagstream) - (terpri tagstream) - (with-open-file (stream "/tmp/*TAGS") - (do ((line (read-line stream nil nil) - (read-line stream nil nil))) - ((null line) nil) - (write-line line tagstream))))))) - -@ - -\subsubsection{spadtags-from-file} - -This function knows how to find function names in {\bf boot} code -so we can add them to the TAGS file using standard etags format. -<>= -(defun spadtags-from-file (spadfile) - (with-open-file (tagstream "/tmp/*TAGS" :direction :output - :if-exists :supersede :if-does-not-exist :create) - (with-open-file (stream spadfile) - (do ((char-count 0 (file-position stream)) - (line (read-line stream nil nil) (read-line stream nil nil)) - (line-count 1 (1+ line-count))) - ((null line) (file-length tagstream)) - (if (/= (length line) 0) - (let ((firstchar (elt line 0)) (end nil) - (len (length line))) - (cond ((member firstchar '(#\space #\{ #\} #\tab ) - :test #'char= ) "skip") - ((string= line ")abb" :end1 (min 4 len)) - (setq end (position #\space line :from-end t - :test-not #'eql) - end (and end (position #\space line :from-end t - :end end))) - (write-tag-line line tagstream end - line-count char-count)) - ((char= firstchar #\)) "skip") - ((and (> len 1) (string= line "--" :end1 2)) "skip") - ((and (> len 1) (string= line "++" :end1 2)) "skip") - ((search "==>" line) "skip") - ((and (setq end (position #\space line) - end (or (position #\( line :end end) end) - end (or (position #\: line :end end) end) - end (or (position #\[ line :end end) end)) - (equal end 0)) "skip") - ((position #\] line :end end) "skip") - ((string= line "SETANDFILEQ" :end1 end) "skip") - ((string= line "EVALANDFILEACTQ" :end1 end) "skip") - (t (write-tag-line line tagstream - (if (numberp end) (+ end 1) end) - line-count char-count)) ))))))) - -@ - -\subsubsection{write-tag-line} - -This function knows how to write a single line into a TAGS file -using the etags file format. -<>= -(defun write-tag-line (line tagstream endcol line-count char-count) - (write-string line tagstream :end endcol) - (write-char #\rubout tagstream) - (princ line-count tagstream) - (write-char #\, tagstream) - (princ char-count tagstream) - (terpri tagstream)) - -@ - -\subsubsection{blankcharp} - -This is a trivial predicate for calls to {\bf position-if-not} in the -{\bf findtag} function. -<>= -(defun blankcharp (c) (char= c #\Space)) - -@ - -\subsubsection{findtag} - -The {\bf findtag} function is a user-level function to figure out -which file contains a given tag. This is sometimes useful if Emacs -is not around or TAGS are not loaded. -<>= -(defun findtag (tag &optional (tagfile (concat (|systemRootDirectory|) "/../../src/interp/TAGS")) ) - ;; tag is an identifier - (with-open-file (tagstream tagfile) - (do ((tagline (read-line tagstream nil nil) - (read-line tagstream nil nil)) - (*package* (symbol-package tag)) - (sourcefile) - (stringtag (string tag)) - (pos) - (tpos) - (type)) - ((null tagline) ()) - (cond ((char= (char tagline 0) #\Page) - (setq tagline (read-line tagstream nil nil)) - (setq sourcefile (subseq tagline 0 - (position #\, tagline))) - (setq type (pathname-type sourcefile))) - ((string= type "lisp") - (if (match-lisp-tag tag tagline) - (return (cons sourcefile tagline)))) - ((> (mismatch ")abb" tagline) 3) - (setq pos (position #\Space tagline :start 3)) - (setq pos (position-if-not #'blankcharp tagline - :start pos)) - (setq pos (position #\Space tagline :start pos)) - (setq pos (position-if-not #'blankcharp tagline - :start pos)) - (setq tpos (mismatch stringtag tagline :start2 pos)) - (if (and (= tpos (length (string tag))) - (member (char tagline (+ pos tpos)) '(#\Space #\Rubout))) - (return (cons sourcefile tagline)))) - ((setq pos (mismatch stringtag tagline)) - (if (and (= pos (length stringtag)) - (> (length tagline) pos) - (member (char tagline pos) - '( #\Space #\( #\:) )) - (return (cons sourcefile tagline)))))))) - -@ - -\subsubsection{match-lisp-tag} - -The {\bf match-lisp-tag} function is used by {\bf findtag}. This -function assumes that \\ can only appear as first character of name. -<>= -(defun match-lisp-tag (tag tagline &optional (prefix nil) - &aux (stringtag (string tag)) pos tpos) - (when (and (if prefix - (= (mismatch prefix tagline :test #'char-equal) - (length prefix)) - t) - (numberp (setq pos (position #\Space tagline))) - (numberp (setq pos (position-if-not #'blankcharp tagline - :start pos)))) - (if (char= (char tagline pos) #\') (incf pos)) - (if (member (char tagline pos) '( #\\ #\|)) - (setq tpos (1+ pos)) - (setq tpos pos)) - (and (= (mismatch stringtag tagline :start2 tpos :test #'char-equal) - (length stringtag)) - (eq tag (read-from-string tagline nil nil :start pos))) )) - -@ - - -\subsection{Translated Boot functions} - -\subsubsection{string2BootTree} - -<>= -(DEFUN |string2BootTree| (S) - (init-boot/spad-reader) - (LET* ((BOOT-LINE-STACK (LIST (CONS 1 S))) - ($BOOT T) - ($SPAD NIL) - (XTOKENREADER 'GET-BOOT-TOKEN) - (LINE-HANDLER 'NEXT-BOOT-LINE) - (PARSEOUT (PROGN (|PARSE-Expression|) (POP-STACK-1)))) - (DECLARE (SPECIAL BOOT-LINE-STACK $BOOT $SPAD XTOKENREADER LINE-HANDLER)) - (DEF-RENAME (|new2OldLisp| PARSEOUT)))) - -@ - -\subsubsection{string2SpadTree} - -<>= -(DEFUN |string2SpadTree| (LINE) - (DECLARE (SPECIAL LINE)) - (if (and (> (LENGTH LINE) 0) (EQ (CHAR LINE 0) #\) )) - (|processSynonyms|)) - (ioclear) - (LET* ((BOOT-LINE-STACK (LIST (CONS 1 LINE))) - ($BOOT NIL) - ($SPAD T) - (XTOKENREADER 'GET-BOOT-TOKEN) - (LINE-HANDLER 'NEXT-BOOT-LINE) - (PARSEOUT (PROG2 (|PARSE-NewExpr|) (POP-STACK-1)))) - (DECLARE (SPECIAL BOOT-LINE-STACK $BOOT $SPAD XTOKENREADER LINE-HANDLER)) - PARSEOUT)) - -@ - -\subsubsection{processSynonyms} - -;;--------------------> NEW DEFINITION (see i-syscmd.boot.pamphlet) -<>= -(defun |processSynonyms| () nil) ;;dummy def for depsys, redefined later - -@ - - -\section{License} - -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ -<<*>>= -<> - -(IMPORT-MODULE "vmlisp") -(import-module "parsing") - -(in-package "BOOT") -(export '($directory-list $current-directory reroot - make-absolute-filename |$msgDatabaseName| |$defaultMsgDatabaseName|)) - -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> - -(in-package "BOOT") - -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> - -<> -<> -<> - -;; the following are for conditional reading -#+:ieee-floating-point (setq $ieee t) -#-:ieee-floating-point (setq $ieee nil) -(setq |$opSysName| '"shell") -#+:CCL (defun machine-type () "unknown") -(setq |$machineType| (machine-type)) -; spad-clear-input patches around fact that akcl clear-input leaves newlines chars -(defun spad-clear-input (st) (clear-input st) (if (listen st) (read-char st))) - -<> -(defun sourcepath (f) - "find the sourcefile in the system directories" - (let (axiom algebra naglink) - (setq axiom (|systemRootDirectory|)) - (setq algebra (concatenate 'string axiom "/../../src/algebra/" f ".spad")) - (setq naglink (concatenate 'string axiom "/../../src/naglink/" f ".spad")) - (cond - ((probe-file algebra) algebra) - ((probe-file naglink) naglink) - ('else nil)))) - -(defun srcabbrevs (sourcefile) - "read spad source files and return the constructor names and abbrevs" - (let (expr point mark names longnames) - (catch 'done - (with-open-file (in sourcefile) - (loop - (setq expr (read-line in nil 'done)) - (when (eq expr 'done) (throw 'done nil)) - (when (and (> (length expr) 4) (string= ")abb" (subseq expr 0 4))) - (setq expr (string-right-trim '(#\space #\tab) expr)) - (setq point (position #\space expr :from-end t :test #'char=)) - (push (subseq expr (1+ point)) longnames) - (setq expr (string-right-trim '(#\space #\tab) - (subseq expr 0 point))) - (setq mark (position #\space expr :from-end t)) - (push (subseq expr (1+ mark)) names))))) - (values longnames names))) - - -#+(and :AKCL (not (or :dos :win32))) -(in-package "COMPILER") -#+(and :AKCL (not (or :dos :win32))) -(defun gazonk-name ( &aux tem) - "return the name of the intermediate compiler file" - (dotimes (i 1000) - (setq tem (merge-pathnames (format nil "/tmp/gazonk~d.lsp" i))) - (unless (probe-file tem) - (return-from gazonk-name (pathname tem)))) - (error "1000 gazonk names used already!")) - -(in-package "BOOT") - -(defun |tr| (fn) - (|spad2AsTranslatorAutoloadOnceTrigger|) - (|convertSpadFile| fn) ) - -<> -<> -<> - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp new file mode 100644 index 00000000..e829899e --- /dev/null +++ b/src/interp/vmlisp.lisp @@ -0,0 +1,1939 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above 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. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; 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 OWNER +;; 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. + +(IMPORT-MODULE "boot-pkg") + +; VM LISP EMULATION PACKAGE +; Lars Ericson, Barry Trager, Martial Schor, tim daly, LVMCL, et al +; IBM Thomas J. Watson Research Center +; Summer, 1986 +; see /spad/daly.changes + +; This emulation package version is written for Symbolics Common Lisp. +; Emulation commentary refers to LISP/VM, IBM Program Number 5798-DQZ, +; as described in the LISP/VM User's Guide, document SH20-6477-1. +; Main comment section headings refer to sections in the User's Guide. + +; If you are using this, you are probably in Common Lisp, yes? + +(in-package "BOOT") + +;; DEFVARS + +(defvar *comp370-apply* nil "function (name def) for comp370 to apply") + +(defvar curinstream (make-synonym-stream '*standard-input*)) + +(defvar curoutstream (make-synonym-stream '*standard-output*)) + +(defvar *embedded-functions* nil) + +(defvar errorinstream (make-synonym-stream '*terminal-io*)) + +(defvar erroroutstream (make-synonym-stream '*terminal-io*)) + +(defvar *fileactq-apply* nil "function to apply in fileactq") + +(defvar *lam-name* nil "name to be used by lam macro if non-nil") + +(defvar macerrorcount 0 "Put some documentation in here someday") + +(defvar *read-place-holder* (make-symbol "%.EOF") + "default value returned by read and read-line at end-of-file") + +;; DEFMACROS + + +(defmacro absval (x) + `(abs ,x)) + +#-:CCL +(defmacro add1 (x) + `(1+ ,x)) + +(defmacro assemble (&rest ignore) + (declare (ignore ignore)) + nil) + +(defmacro applx (&rest args) + `(apply ,@args)) + +#-(or LispM Lucid :CCL) +(defmacro assq (a b) + `(assoc ,a ,b :test #'eq)) + +#+:CCL +(defmacro assq (a b) `(atsoc ,a ,b)) + +#-:CCL +(defmacro bintp (n) + `(typep ,n 'bignum)) +#+:CCL +(defun bintp (n) (and (integerp n) (not (fixp n)))) + +(defmacro |char| (x) + (if (and (consp x) (eq (car x) 'quote)) (character (cadr x)) + `(character ,x))) + +(defmacro closedfn (form) + `(function ,form)) + +(defmacro |copyList| (x) + `(copy-list ,x)) + +(defmacro create-sbc (x) x) ;a no-op for common lisp + +(defmacro cvecp (x) + `(stringp ,x)) + +(defmacro dcq (&rest args) + (cons 'setqp args)) + +#-:CCL +(defmacro difference (&rest args) + `(- ,@args)) + +(defmacro dsetq (&whole form pattern exp) + (dodsetq form pattern exp)) + +(defmacro ecq (&rest args) + (cons 'eqq args)) + +;;def needed to prevent recursion in def of eqcar +(eval-when + #+:common-lisp (:compile-toplevel :load-toplevel :execute) + #-:common-lisp (compile load eval) + (defun equable (x) + (or (null x) + (and (consp x) (eq (car x) 'quote) + (symbolp (cadr x)))))) + +#-:CCL +(defmacro eqcar (x y) + (let ((test + (cond + ((equable y) 'eq) + ((integerp y) 'i=) + ('eql)))) + (if (atom x) + `(and (consp ,x) (,test (qcar ,x) ,y)) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (and (consp ,xx) (,test (qcar ,xx) ,y))))))) + +(defmacro eqq (pattern exp) + `(,(ecqexp pattern nil) ,exp)) + +(defmacro |equal| (x y) + `(equalp ,x ,y)) + +(defmacro evalandfileactq (name &optional (form name)) + `(eval-when + #+:common-lisp (:load-toplevel :execute) + #-:common-lisp (eval load) + ,form)) + +(defmacro exit (&rest value) + `(return-from seq ,@value)) + +(defmacro fetchchar (x i) + `(char ,x ,i)) + +#-:CCL ;; fixp in ccl tests for fixnum +(defmacro fixp (x) + `(integerp ,x)) + +#-:CCL +(defmacro greaterp (&rest args) + `(> ,@args)) + +(defmacro i= (x y) ;; integer equality + (if (typep y 'fixnum) + (let ((gx (gensym))) + `(let ((,gx ,x)) + (and (typep ,gx 'fixnum) (eql (the fixnum ,gx) ,y)))) + (let ((gx (gensym)) (gy (gensym))) + `(let ((,gx ,x) (,gy ,y)) + (cond ((and (typep ,gx 'fixnum) (typep ,gy 'fixnum)) + (eql (the fixnum ,gx) (the fixnum ,gy))) + ((eql (the integer ,gx) (the integer,gy)))))))) + +(defmacro |idChar?| (x) + `(or (alphanumericp ,x) (member ,x '(#\? #\% #\' #\!) :test #'char=))) + +(defmacro identp (x) + (if (atom x) + `(and ,x (symbolp ,x)) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (and ,xx (symbolp ,xx)))))) + +(defmacro ifcar (x) + (if (atom x) + `(and (consp ,x) (qcar ,x)) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (and (consp ,xx) (qcar ,xx)))))) + +(defmacro ifcdr (x) + (if (atom x) + `(and (consp ,x) (qcdr ,x)) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (and (consp ,xx) (qcdr ,xx)))))) + +(defmacro intp (x) + `(integerp ,x)) + +(defmacro lam (&rest body) + (list 'quote (*lam (copy-tree body)))) + +(defmacro lastnode (l) + `(last ,l)) + +(defmacro lastpair (l) + `(last ,l)) + +#-:CCL +(defmacro lessp (&rest args) + `(< ,@args)) + +(defmacro lintp (n) + `(typep ,n 'bignum)) + +(defmacro makestring (a) a) + +(defmacro mapelt (f vec) + `(map 'vector ,f ,vec)) + +(defmacro maxindex (x) + `(the fixnum (1- (the fixnum (length ,x))))) + +#-(or LispM Lucid :CCL) +(defmacro memq (a b) + `(member ,a ,b :test #'eq)) + +#-:CCL +(defmacro minus (x) + `(- ,x)) + +(defmacro mrp (x) + `(special-form-p ,x)) + +(defmacro namederrset (id iexp &rest item) + (declare (ignore item)) + `(catch ,id ,iexp)) + +(defmacro ne (a b) `(not (equal ,a ,b))) + +;;; This may need adjustment in CCL where NEQ means (NOT (EQUAL ..))) +#-:CCL +(defmacro neq (a b) `(not (eq ,a ,b))) + +#-:CCL +(defmacro nreverse0 (x) + (if (atom x) + `(if (atom ,x) ,x (nreverse ,x)) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (if (atom ,xx) ,xx (nreverse ,xx)))))) + +(defmacro nump (n) + `(numberp ,n)) + +(defmacro |opOf| (x) ;(if (atom x) x (qcar x)) + (if (atom x) + `(if (consp ,x) (qcar ,x) ,x) + (let ((xx (gensym))) + `(let ((,xx ,x)) + (if (consp ,xx) (qcar ,xx) ,xx))))) + +(defmacro oraddtempdefs (filearg) + `(eval-when + #+:common-lisp (:compile-toplevel) + #-:common-lisp (compile) + (load ,filearg))) + +(defmacro pairp (x) + `(consp ,x)) + +#-:CCL +(defmacro plus (&rest args) + `(+ ,@ args)) + +; (defmacro qassq (a b) +; `(assoc ,a ,b :test #'eq)) +(defmacro qassq (a b) `(assq ,a ,b)) + +#-:CCL +(defmacro qcar (x) + `(car (the cons ,x))) +#-:CCL +(defmacro qcdr (x) + `(cdr (the cons ,x))) + +#-:CCL +(defmacro qcaar (x) + `(car (the cons (car (the cons ,x))))) +#-:CCL +(defmacro qcadr (x) + `(car (the cons (cdr (the cons ,x))))) +#-:CCL +(defmacro qcdar (x) + `(cdr (the cons (car (the cons ,x))))) +#-:CCL +(defmacro qcddr (x) + `(cdr (the cons (cdr (the cons ,x))))) + +(defmacro qcaaar (x) + `(car (the cons (car (the cons (car (the cons ,x))))))) +(defmacro qcaadr (x) + `(car (the cons (car (the cons (cdr (the cons ,x))))))) +(defmacro qcadar (x) + `(car (the cons (cdr (the cons (car (the cons ,x))))))) +(defmacro qcaddr (x) + `(car (the cons (cdr (the cons (cdr (the cons ,x))))))) +(defmacro qcdaar (x) + `(cdr (the cons (car (the cons (car (the cons ,x))))))) +(defmacro qcdadr (x) + `(cdr (the cons (car (the cons (cdr (the cons ,x))))))) +(defmacro qcddar (x) + `(cdr (the cons (cdr (the cons (car (the cons ,x))))))) +(defmacro qcdddr (x) + `(cdr (the cons (cdr (the cons (cdr (the cons ,x))))))) + +(defmacro qcaaaar (x) + `(car (the cons (car (the cons (car (the cons (car (the cons ,x))))))))) +(defmacro qcaaadr (x) + `(car (the cons (car (the cons (car (the cons (cdr (the cons ,x))))))))) +(defmacro qcaadar (x) + `(car (the cons (car (the cons (cdr (the cons (car (the cons ,x))))))))) +(defmacro qcaaddr (x) + `(car (the cons (car (the cons (cdr (the cons (cdr (the cons ,x))))))))) +(defmacro qcadaar (x) + `(car (the cons (cdr (the cons (car (the cons (car (the cons ,x))))))))) +(defmacro qcadadr (x) + `(car (the cons (cdr (the cons (car (the cons (cdr (the cons ,x))))))))) +(defmacro qcaddar (x) + `(car (the cons (cdr (the cons (cdr (the cons (car (the cons ,x))))))))) +(defmacro qcadddr (x) + `(car (the cons (cdr (the cons (cdr (the cons (cdr (the cons ,x))))))))) +(defmacro qcdaaar (x) + `(cdr (the cons (car (the cons (car (the cons (car (the cons ,x))))))))) +(defmacro qcdaadr (x) + `(cdr (the cons (car (the cons (car (the cons (cdr (the cons ,x))))))))) +(defmacro qcdadar (x) + `(cdr (the cons (car (the cons (cdr (the cons (car (the cons ,x))))))))) +(defmacro qcdaddr (x) + `(cdr (the cons (car (the cons (cdr (the cons (cdr (the cons ,x))))))))) +(defmacro qcddaar (x) + `(cdr (the cons (cdr (the cons (car (the cons (car (the cons ,x))))))))) +(defmacro qcddadr (x) + `(cdr (the cons (cdr (the cons (car (the cons (cdr (the cons ,x))))))))) +(defmacro qcdddar (x) + `(cdr (the cons (cdr (the cons (cdr (the cons (car (the cons ,x))))))))) +(defmacro qcddddr (x) + `(cdr (the cons (cdr (the cons (cdr (the cons (cdr (the cons ,x))))))))) + +(defmacro qcsize (x) + `(the fixnum (length (the simple-string ,x)))) + +(defmacro qeqq (pattern exp) + `(,(ecqexp pattern 1) ,exp)) + +(defmacro qlength (a) + `(length ,a)) + +; (defmacro qmemq (a b) +; `(member ,a ,b :test #'eq)) +(defmacro qmemq (a b) `(memq ,a ,b)) + +(defmacro qrefelt (vec ind) + `(svref ,vec ,ind)) + +(defmacro qrplaca (a b) + `(rplaca (the cons ,a) ,b)) + +(defmacro qrplacd (a b) + `(rplacd (the cons ,a) ,b)) + +(defmacro qrplq (&whole form pattern exp) + (if (or (consp pattern) (simple-vector-p pattern)) + `(,(rcqexp pattern) ,exp) + (macro-invalidargs 'qrplq form "form must be updateable."))) + +(defmacro qsadd1 (x) + `(the fixnum (1+ (the fixnum ,x)))) + +(defmacro qsdec1 (x) + `(the fixnum (1- (the fixnum ,x)))) + +(defmacro qsdifference (x y) + `(the fixnum (- (the fixnum ,x) (the fixnum ,y)))) + +(defmacro qsetq (&whole form pattern exp) + (declare (ignore form)) + `(,(dcqexp pattern '=) ,exp)) + +(defmacro qsetrefv (vec ind val) + `(setf (svref ,vec (the fixnum ,ind)) ,val)) + +(defmacro qsetvelt (vec ind val) + `(setf (svref ,vec (the fixnum ,ind)) ,val)) + +(defmacro qsetvelt-1 (vec ind val) + `(setf (svref ,vec (the fixnum (1- (the fixnum ,ind)))) ,val)) + +(defmacro qsgreaterp (a b) + `(> (the fixnum ,a) (the fixnum ,b))) + +(defmacro qsinc1 (x) + `(the fixnum (1+ (the fixnum ,x)))) + +(defmacro qsleftshift (a b) + `(the fixnum (ash (the fixnum ,a) (the fixnum ,b)))) + +(defmacro qslessp (a b) + `(< (the fixnum ,a) (the fixnum ,b))) + +(defmacro qsmax (x y) + `(the fixnum (max (the fixnum ,x) (the fixnum ,y)))) + +(defmacro qsmin (x y) + `(the fixnum (min (the fixnum ,x) (the fixnum ,y)))) + +(defmacro qsminus (x) + `(the fixnum (minus (the fixnum ,x)))) + +(defmacro qsminusp (x) + `(minusp (the fixnum ,x))) + +(defmacro qsoddp (x) + `(oddp (the fixnum ,x))) + +(defmacro qsabsval (x) + `(the fixnum (abs (the fixnum ,x)))) + +(defmacro qsplus (x y) + `(the fixnum (+ (the fixnum ,x) (the fixnum ,y)))) + +(defmacro qssub1 (x) + `(the fixnum (1- (the fixnum ,x)))) + +(defmacro qstimes (x y) + `(the fixnum (* (the fixnum ,x) (the fixnum ,y)))) + +(defmacro qstringlength (x) + `(the fixnum (length (the simple-string ,x)))) + +(defmacro qszerop (x) + `(zerop (the fixnum ,x))) + +(defmacro qvelt (vec ind) + `(svref ,vec (the fixnum ,ind))) + +(defmacro qvelt-1 (vec ind) + `(svref ,vec (the fixnum (1- (the fixnum ,ind))))) + +(defmacro qvmaxindex (x) + `(the fixnum (1- (the fixnum (length (the simple-vector ,x)))))) + +(defmacro qvsize (x) + `(the fixnum (length (the simple-vector ,x)))) + +; #-:CCL +; (defmacro refvecp (v) +; `(typep ,v '(vector t))) +; #+:CCL +; (defun refvecp (v) (and (vectorp v) (not (stringp v)))) +(defmacro refvecp (v) `(simple-vector-p ,v)) + +(defmacro resetq (a b) + `(prog1 ,a (setq ,a ,b))) + +(defmacro rnump (n) + `(floatp ,n)) + +(defmacro rplq (&whole form exp pattern) + (if (or (consp pattern) (simple-vector-p pattern)) + `(,(rcqexp pattern) ,exp) + (macro-invalidargs 'rplq form "form must be updateable."))) + +(defmacro rvecp (v) + `(typep ,v '(vector float))) + +(defmacro setandfileq (id item) + `(eval-when + #+:common-lisp (:load-toplevel :execute) + #-:common-lisp (eval load) + (setq ,id ,item) + (lam\,fileactq ',id (list 'setq ',id (list 'quote ,id))))) + +#-:CCL +(defmacro setelt (vec ind val) + `(setf (elt ,vec ,ind) ,val)) + +(defmacro setqp (&whole form pattern exp) + (declare (ignore form)) + `(,(dcqexp pattern '=) ,exp)) + +(defmacro seq (&rest form) + (let* ((body (reverse form)) + (val `(return-from seq ,(pop body)))) + (nsubstitute '(progn) nil body) ;don't treat NIL as a label + `(block seq (tagbody ,@(nreverse body) ,val)))) + +(defmacro sfp (x) + `(special-form-p ,x)) + +#-:CCL +(defmacro sintp (n) + `(typep ,n 'fixnum)) +#+:CCL +(defmacro sintp (n) + `(fixp ,n)) + +#-:CCL +(defmacro smintp (n) + `(typep ,n 'fixnum)) +#+:CCL +(defmacro smintp (n) + `(fixp ,n)) + +(defmacro stringlength (x) + `(length (the string ,x))) + +(defmacro subrp (x) + `(compiled-function-p ,x)) + +#-:CCL +(defmacro sub1 (x) + `(1- ,x)) + +(defmacro throw-protect (exp1 exp2) + `(unwind-protect ,exp1 ,exp2)) + +#-:CCL +(defmacro times (&rest args) + `(* ,@args)) + +(defmacro vec-setelt (vec ind val) + `(setf (svref ,vec ,ind) ,val)) + +; #-:CCL +; (defmacro vecp (v) +; `(typep ,v '(vector t))) +; #+:CCL +; (defun vecp (v) (and (vectorp v) (not (stringp v)))) +(defmacro vecp (v) `(simple-vector-p ,v)) + +#-:CCL +(defmacro zero? (x) + `(and (typep ,x 'fixnum) (zerop (the fixnum ,x)))) +#+:CCL +(defmacro zero? (x) `(zerop ,x)) + +;; defuns + +(eval-when + #+:common-lisp (:compile-toplevel :load-toplevel :execute) + #-:common-lisp (compile load eval) + (defun define-function (f v) + (setf (symbol-function f) v))) + +(define-function 'tempus-fugit #'get-internal-run-time) + +(defun $TOTAL-ELAPSED-TIME () + (list (get-internal-run-time) (get-internal-real-time))) + +#-(OR IBCL KCL :CMULISP :CCL) +(defun $TOTAL-GC-TIME () (list 0 0)) + +#+:CCL +(defun $TOTAL-GC-TIME () (list (gctime) (gctime))) + +#+IBCL +(defun $TOTAL-GC-TIME (&aux (gcruntime (system:gbc-time-report))) + (list gcruntime gcruntime)) + +#+KCL +(defun $TOTAL-GC-TIME (&aux (gcruntime (system:gbc-time))) + (if (minusp gcruntime) + (setq gcruntime (system:gbc-time 0))) + (list gcruntime gcruntime)) + +;;; note: this requires the 11/9/89 gc patch in code/lisp/daly/misc.lisp +#+:cmulisp +(defun $TOTAL-GC-TIME () + (declare (special ext::*gc-runtime* ext::*gc-walltime*)) + (list ext::*gc-runtime* ext::*gc-walltime*)) + +; 7.0 Macros + +; 7.2 Creating Macro Expressions + +; 5.2 Functions + +; 5.2.2 Lambda Expressions + +(defun *LAM (body) + (cond ((NOT (ISQUOTEDP (first BODY))) (cons 'LAMBDA BODY)) + ((LET* ((BV (DEQUOTE (first BODY))) + (CONTROL (QUOTESOF (first BODY))) + (BODY (cdr BODY)) + (ARGS (GENSYM)) + (INNER-FUNC (or *lam-name* (gentemp)))) + (COMP370 (LIST INNER-FUNC `(LAMBDA ,BV . ,BODY))) + `(MLAMBDA ,ARGS + (CONS (QUOTE ,INNER-FUNC) + (WRAP (cdr ,ARGS) ',CONTROL))))))) + +(defun WRAP (LIST-OF-ITEMS WRAPPER) + (prog nil + (COND ((OR (NOT (PAIRP LIST-OF-ITEMS)) (not WRAPPER)) + (RETURN LIST-OF-ITEMS)) + ((NOT (consp WRAPPER)) + (SETQ WRAPPER (LOTSOF WRAPPER)))) + (RETURN + (CONS (if (first WRAPPER) + `(,(first WRAPPER) ,(first LIST-OF-ITEMS)) + (first LIST-OF-ITEMS)) + (WRAP (cdr LIST-OF-ITEMS) (cdr WRAPPER)))))) + +(defun ISQUOTEDP (bv) + (COND ((NOT (consp BV)) NIL) + ((EQ (first BV) 'QUOTE)) + ((AND (consp (first BV)) (EQ (QCAAR BV) 'QUOTE))) + ((ISQUOTEDP (cdr BV))))) + +(defun QUOTESOF (BV) + (COND ((NOT (consp BV)) NIL) + ((EQ (first BV) 'QUOTE) 'QUOTE) + ((CONS (COND ((NOT (consp (first BV))) nil) + ((EQ (QCAAR BV) 'QUOTE) 'QUOTE) + (T NIL)) + (QUOTESOF (cdr BV)))))) + +(defun DEQUOTE (BV) + (COND ((NOT (consp BV)) BV) + ((EQ 'QUOTE (first BV)) (second BV)) + ((CONS (if (EQ 'QUOTE (IFCAR (CAR BV))) (CADAR BV) (first BV)) + (DEQUOTE (cdr BV)))))) + +(defun lotsof (&rest items) + (setq items (copy-list items)) + (nconc items items)) + +; 7.4 Using Macros + +; Beats me how to simulate macro expansion "in the environment of sd"...: + +(defun MDEF (arg item &optional sd) + (declare (ignore sd)) + (macroexpand `(,arg ,item))) + +(define-function 'MDEFX #'MDEF) + +; 8.0 Operator Definition and Transformation + +; 8.1 Definition and Transformation Operations + +(defun COMP370 (fnlist) + (cond ((atom (car fnlist)) (list (COMPILE1 fnlist))) + (t (MAPCAR #'(lambda (x) (COMPILE1 x)) fnlist)))) + +#+:CCL (proclaim '(special *vars* *decl*)) ;; declare not handled right + +(defun COMPILE1 (fn) + (let* (nargs + (fname (car fn)) + (lamda (cadr fn)) + (ltype (car lamda)) + *vars* *decl* args + (body (cddr lamda))) + (declare (special *vars* *decl*)) + (if (eq ltype 'LAM) + (let ((*lam-name* (intern (concat fname "\,LAM")))) + (setq lamda (eval lamda) ltype (car lamda) body (cddr lamda)))) + (let ((dectest (car body))) + (if (and (eqcar dectest 'declare) (eqcar (cadr dectest) 'special)) + (setq *decl* (cdr (cadr dectest)) body (cdr body)))) + (setq args (remove-fluids (cadr lamda))) + (cond ((and (eq ltype 'lambda) (simple-arglist args)) (setq nargs args)) + (t (setq nargs (gensym)) + #+LispM (setq body `((dsetq ,args (copy-list ,nargs)) ,@body)) + #-LispM (setq body `((dsetq ,args ,nargs) ,@body)) + (cond ((eq ltype 'lambda) (setq nargs `(&rest ,nargs &aux ,@*vars*))) + ((eq ltype 'mlambda) + (setq nargs `(&whole ,nargs &rest ,(gensym) &aux ,@*vars*))) + (t (error "bad function type"))))) + (cond (*decl* (setq body (cons `(declare (special ,@ *decl*)) body)))) + (setq body + (cond ((eq ltype 'lambda) `(defun ,fname ,nargs . ,body)) + ((eq ltype 'mlambda) `(defmacro ,fname ,nargs . ,body)))) + (if *COMP370-APPLY* (funcall *COMP370-APPLY* fname body)) + + body)) + +(defun simple-arglist (arglist) + (or (null arglist) + (and (consp arglist) (null (cdr (last arglist))) + (every #'symbolp arglist)))) + +(defun remove-fluids (arglist &aux f v) ;updates specials *decl* and *vars* + (declare (special *decl* *vars*)) + (cond ((null arglist) arglist) + ((symbolp arglist) (push arglist *vars*) arglist) + ;if atom but not symbol, ignore value + ((atom arglist) (push (setq arglist (gentemp)) *vars*) arglist) + ((and (setq f (car arglist)) + (eq f 'fluid) + (listp (cdr arglist)) + (setq v (cadr arglist)) + (identp v) + (null (cddr arglist))) + (push v *decl*) + (push v *vars*) + v) + (t (cons (remove-fluids (car arglist)) + (remove-fluids (cdr arglist)))))) + +(define-function 'KOMPILE #'COMP370) + +; 9.4 Vectors and Bpis + +(defun IVECP (x) (and (vectorp x) (subtypep (array-element-type x) 'integer))) + +(defun mbpip (item) (and (symbolp item) ;cannot know a compiled macro in CLISP + (compiled-function-p (macro-function item)))) + +(defun FBPIP (item) (or (compiled-function-p item) + (and (symbolp item) (fboundp item) + (not (macro-function item)) + (compiled-function-p (symbol-function item))))) + +; 9.5 Identifiers + +#-:CCL +(defun gensymp (x) (and (symbolp x) (null (symbol-package x)))) + +(defun digitp (x) + (or (and (symbolp x) (digitp (symbol-name x))) + (and (characterp x) (digit-char-p x)) + (and (stringp x) (= (length x) 1) (digit-char-p (char x 0))))) + +(defun dig2fix (x) + (if (symbolp x) + (digit-char-p (char (symbol-name x) 0)) + (digit-char-p x))) + +#-:CCL +(defun LN (x) (LOG x)) +#-:CCL +(defun LOG2 (x) (LOG x 2.0)) +(defun |log| (x) (LOG x 10.0)) + +; 9.13 Streams + +#+Lucid +(defun IS-CONSOLE (stream) + (and (streamp stream) + (or (not (consp (pathname-directory stream))) + (equal (qcar (pathname-directory stream)) "dev") + (null (pathname-name stream) )))) + +#+KCL +(defun IS-CONSOLE (stream) + (and (streamp stream) (output-stream-p stream) + (eq (system:fp-output-stream stream) + (system:fp-output-stream *terminal-io*)))) + +#-(OR Lucid KCL :CCL) +(defun IS-CONSOLE (stream) (EQ stream *terminal-io*)) + +; 10.0 Control Structures + +; 10.8.4 Auxiliary Operators + +(defun nilfn (&rest ignore) + (declare (ignore ignore)) + ()) + +; 11.0 Operations on Identifiers + +; 11.1 Creation + +(defun upcase (l) + (cond ((stringp l) (string-upcase l)) + ((identp l) (intern (string-upcase (symbol-name l)))) + ((characterp l) (char-upcase l)) + ((atom l) l) + (t (mapcar #'upcase l)))) + +(define-function 'U-CASE #'upcase) +(define-function 'LC2UC #'upcase) + +(defun downcase (l) + (cond ((stringp l) (string-downcase l)) + ((identp l) (intern (string-downcase (symbol-name l)))) + ((characterp l) (char-downcase L)) + ((atom l) l) + (t (mapcar #'downcase l)))) + +(define-function 'L-CASE #'downcase) + +; 11.2 Accessing + +;; note it is important that PNAME returns nil not an error for non-symbols +(defun pname (x) + (cond ((symbolp x) (symbol-name x)) + ((characterp x) (string x)) + (t nil))) + +;; property lists in vmlisp are alists +(defun PROPLIST (x) + (if (symbolp x) +#-:CCL + (plist2alist (symbol-plist x)) +#+:CCL + (plist2alist (plist x)) + nil)) + +(defun plist2alist (x) + (if (null x) + nil + (cons (cons (first x) (second x)) (plist2alist (cddr x))))) + +(eval-when + #+:common-lisp (:compile-toplevel :load-toplevel :execute) + #-:common-lisp (compile load eval) + (progn + (defun put (sym ind val) (setf (get sym ind) val)) + + (define-function 'MAKEPROP #'put))) + +; 12.0 Operations on Numbers + +; 12.1 Conversion + +(define-function 'FIX #'truncate) +(define-function 'INT2RNUM #'float) + +; 12.2 Predicates + +;(define-function 'lessp #'<) + +;(define-function 'greaterp #'>) + + +;(define-function 'fixp #'integerp) + +; 12.3 Computation + +;(define-function 'add1 #'1+) +;(define-function 'sub1 #'1-) +;(define-function 'plus #'+) +;(define-function 'times #'*) +;(define-function 'difference #'-) +;(define-function 'minus #'-) +;(define-function 'absval #'abs) + +(defun QUOTIENT (x y) + (cond ((or (floatp x) (floatp y)) (/ x y)) + (t (truncate x y)))) + +(define-function 'vm/ #'quotient) + +#-:CCL +(defun REMAINDER (x y) + (if (and (integerp x) (integerp y)) + (rem x y) + (- x (* y (QUOTIENT x y))))) + +#-:CCL +(defun DIVIDE (x y) + (if (and (integerp x) (integerp y)) + (multiple-value-list (truncate x y)) + (list (QUOTIENT x y) (REMAINDER x y)))) + +(defun QSQUOTIENT (a b) (the fixnum (truncate (the fixnum a) (the fixnum b)))) + +(defun QSREMAINDER (a b) (the fixnum (rem (the fixnum a) (the fixnum b)))) + + +;(defun IFCAR (x) (if (consp x) (car (the cons x)))) + +;(defun IFCDR (x) (if (consp x) (cdr (the cons x)))) + +; 13.3 Updating + + +(defun RPLPAIR (pair1 pair2) + (RPLACA pair1 (CAR pair2)) + (RPLACD pair1 (CDR pair2)) pair1) + +(defun RPLNODE (pair1 ca2 cd2) + (RPLACA pair1 ca2) + (RPLACD pair1 cd2) pair1) + +; 14.0 Operations on Lists + +; 14.1 Creation + +(defun VEC2LIST (vec) (coerce vec 'list)) + +; note default test for union, intersection and set-difference is eql +;; following are defined so as to preserve ordering in union.lisp +;;(defun SETDIFFERENCE (l1 l2) (set-difference l1 l2 :test #'equalp)) +;;(defun SETDIFFERENCEQ (l1 l2) (set-difference l1 l2 :test #'eq)) +;;(defun |union| (l1 l2) (union l1 l2 :test #'equalp)) +;;(defun UNIONQ (l1 l2) (union l1 l2 :test #'eq)) +;;(defun |intersection| (l1 l2) (intersection l1 l2 :test #'equalp)) +;;(defun INTERSECTIONQ (l1 l2) (intersection l1 l2 :test #'eq)) +(defun |member| (item sequence) + (cond ((symbolp item) (member item sequence :test #'eq)) + ((stringp item) (member item sequence :test #'equal)) + ((and (atom item) (not (arrayp item))) (member item sequence)) + (T (member item sequence :test #'equalp)))) + +(defun |remove| (list item &optional (count 1)) + (if (integerp count) + (remove item list :count count :test #'equalp) + (remove item list :test #'equalp))) + +(defun REMOVEQ (list item &optional (count 1)) + (if (integerp count) + (remove item list :count count :test #'eq) + (remove item list :test #'eq))) + +; 14.2 Accessing + +;(define-function 'lastnode #'last) +;(define-function 'lastpair #'last) +(defun |last| (x) (car (lastpair x))) + +; 14.3 Searching + +#+:CCL (DEFMACRO |assoc| (X Y) `(ASSOC** ,X ,Y)) +#-:CCL +(DEFUN |assoc| (X Y) + "Return the pair associated with key X in association list Y." + ; ignores non-nil list terminators + ; ignores non-pair a-list entries + (cond ((symbolp X) + (PROG NIL + A (COND ((ATOM Y) (RETURN NIL)) + ((NOT (consp (CAR Y))) ) + ((EQ (CAAR Y) X) (RETURN (CAR Y))) ) + (SETQ Y (CDR Y)) + (GO A))) + ((or (numberp x) (characterp x)) + (PROG NIL + A (COND ((ATOM Y) (RETURN NIL)) + ((NOT (consp (CAR Y))) ) + ((EQL (CAAR Y) X) (RETURN (CAR Y))) ) + (SETQ Y (CDR Y)) + (GO A))) + (t + (PROG NIL + A (COND ((ATOM Y) (RETURN NIL)) + ((NOT (consp (CAR Y))) ) + ((EQUAL (CAAR Y) X) (RETURN (CAR Y))) ) + (SETQ Y (CDR Y)) + (GO A))))) +; 14.5 Updating + +(defun NREMOVE (list item &optional (count 1)) + (if (integerp count) + (delete item list :count count :test #'equal) + (delete item list :test #'equal))) + +(defun NREMOVEQ (list item &optional (count 1)) + (if (integerp count) + (delete item list :count count ) + (delete item list ))) + +(defun EFFACE (item list) (delete item list :count 1 :test #'equal)) + +(defun NCONC2 (x y) (NCONC x y)) ;NCONC with exactly two arguments + +; 14.6 Miscellaneous + +(defun QSORT (l) + (declare (special sortgreaterp)) + (NREVERSE (sort (copy-seq l) SORTGREATERP))) + +(defun SORTBY (keyfn l) + (declare (special sortgreaterp)) + (nreverse (sort (copy-seq l) SORTGREATERP :key keyfn))) + +; 16.0 Operations on Vectors + +; 16.1 Creation + +(defun MAKE-VEC (n) (make-array n)) + +(define-function 'GETREFV #'make-array) + +(defun LIST2VEC (list) + (if (consp list) + (let* ((len (length list)) + (vec (make-array len))) + (dotimes (i len) + (setf (aref vec i) (pop list))) + vec) + (coerce list 'vector))) + +(define-function 'LIST2REFVEC #'LIST2VEC) + +; 16.2 Accessing + + +;(define-function 'FETCHCHAR #'char) + +;; Oddly, LENGTH is more efficient than LIST-LENGTH in CCL, since the former +;; is compiled and the latter is byte-coded! +(defun size (l) + (cond ((vectorp l) (length l)) +#+:CCL ((stringp l) (length l)) ;; Until ACN fixes his lisp -> C translator. +#-:CCL ((consp l) (list-length l)) +#+:CCL ((consp l) (length l)) + (t 0))) + +(define-function 'MOVEVEC #'replace) + +; 17.0 Operations on Character and Bit Vectors + +(defun charp (a) (or (characterp a) + (and (identp a) (= (length (symbol-name a)) 1)))) + +(defun NUM2CHAR (n) (code-char n)) + +(defun CHAR2NUM (c) (char-code (character c))) + +(defun CGREATERP (s1 s2) (string> (string s1) (string s2))) + +(define-function 'STRGREATERP #'CGREATERP) + +; 17.1 Creation + + +#-AKCL +(defun concat (a b &rest l) + (let ((type (cond ((bit-vector-p a) 'bit-vector) (t 'string)))) + (cond ((eq type 'string) + (setq a (string a) b (string b)) + (if l (setq l (mapcar #'string l))))) + (if l (apply #'concatenate type a b l) + (concatenate type a b))) ) +#+AKCL +(defun concat (a b &rest l) + (if (bit-vector-p a) + (if l (apply #'concatenate 'bit-vector a b l) + (concatenate 'bit-vector a b)) + (if l (apply #'system:string-concatenate a b l) + (system:string-concatenate a b)))) + +(define-function 'strconc #'concat) + +(defun make-cvec (sint) (make-array sint :fill-pointer 0 :element-type 'character)) + +;(define-function 'CVECP #'stringp) + +(define-function 'getstr #'make-cvec) + +(defun make-full-cvec (sint &optional (char #\space)) + (make-string sint :initial-element (character char))) + +(define-function 'getfullstr #'make-full-cvec) + +; 17.2 Accessing + +(defun QENUM (cvec ind) (char-code (char cvec ind))) + +(defun QESET (cvec ind charnum) + (setf (char cvec ind) (code-char charnum))) + +(defun string2id-n (cvec sint) + (if (< sint 1) + nil + (let ((start (position-if-not #'(lambda (x) (char= x #\Space)) cvec))) + (if start + (let ((end (or (position #\Space cvec :start start) (length cvec)))) + (if (= sint 1) + (intern (subseq cvec start end)) + (string2id-n (subseq cvec end) (1- sint)))) + 0)))) + +(defun substring (cvec start length) + (setq cvec (string cvec)) + (if length (subseq cvec start (+ start length)) (subseq cvec start))) + +; 17.3 Searching + +;;- (defun strpos (what in start dontcare) +;;- (setq what (string what) in (string in)) +;;- (if dontcare (progn (setq dontcare (character dontcare)) +;;- (search what in :start2 start +;;- :test #'(lambda (x y) (or (eql x dontcare) +;;- (eql x y))))) +;;- (search what in :start2 start))) + +(defun strpos (what in start dontcare) + (setq what (string what) in (string in)) + (if dontcare (progn (setq dontcare (character dontcare)) + (search what in :start2 start + :test #'(lambda (x y) (or (eql x dontcare) + (eql x y))))) + (if (= start 0) + (search what in) + (search what in :start2 start)) + )) + +; In the following, table should be a string: + +(defun strposl (table cvec sint item) + (setq cvec (string cvec)) + (if (not item) + (position table cvec :test #'(lambda (x y) (position y x)) :start sint) + (position table cvec :test-not #'(lambda (x y) (position y x)) :start sint))) + +; 17.4 Updating operators + +(defun suffix (id cvec) + "Suffixes the first char of the symbol or char ID to the string CVEC, + changing CVEC." + (unless (characterp id) (setq id (elt (string id) 0))) + (cond ((array-has-fill-pointer-p cvec) + (vector-push-extend id cvec) + cvec) + ((adjustable-array-p cvec) + (let ((l (length cvec))) + (adjust-array cvec (1+ l)) + (setf (elt cvec l) id) + cvec)) + (t (concat cvec id)))) + +(defun setsize (vector size) (adjust-array vector size)) + +(define-function 'changelength #'setsize) + +(defun trimstring (x) x) + +;;-- (defun rplacstr (cvec1 start1 length1 cvec2 +;;-- &optional (start2 0) (length2 nil) +;;-- &aux end1 end2) +;;-- (setq cvec2 (string cvec2)) +;;-- (if (null start1) (setq start1 0)) +;;-- (if (null start2) (setq start2 0)) +;;-- (if (null length1) (setq length1 (- (length cvec1) start1))) +;;-- (if (null length2) (setq length2 (- (length cvec2) start2))) +;;-- (if (numberp length1) (setq end1 (+ start1 length1))) +;;-- (if (numberp length2) (setq end2 (+ start2 length2))) +;;-- (if (/= length1 length2) +;;-- (concatenate 'string (subseq cvec1 0 start1) +;;-- (subseq cvec2 start2 end2) +;;-- (subseq cvec1 end1)) +;;-- (replace cvec1 cvec2 :start1 start1 :end1 end1 +;;-- :start2 start2 :end2 end2))) + +; The following version has been provided to avoid reliance on the +; Common Lisp concatenate and replace functions. These built-in Lisp +; functions would probably end up doing the character-by-character +; copying shown here, but would also need to cope with generic sorts +; of sequences and unwarranted keyword generality + +(defun rplacstr (cvec1 start1 length1 cvec2 + &optional start2 length2 + &aux end1 end2) + (setq cvec2 (string cvec2)) + (if (null start1) (setq start1 0)) + (if (null start2) (setq start2 0)) + (if (null length1) (setq length1 (- (length cvec1) start1))) + (if (null length2) (setq length2 (- (length cvec2) start2))) + (setq end1 (+ start1 length1)) + (setq end2 (+ start2 length2)) + (if (= length1 length2) + (do () + ((= start1 end1) cvec1) + (setf (aref cvec1 start1) (aref cvec2 start2)) + (setq start1 (1+ start1)) + (setq start2 (1+ start2))) + (let* ((l1 (length cvec1)) + (r (make-string (- (+ l1 length2) length1))) + (i 0)) + (do ((j 0 (1+ j))) + ((= j start1)) + (setf (aref r i) (aref cvec1 j)) + (setq i (1+ i))) + (do ((j start2 (1+ j))) + ((= j end2)) + (setf (aref r i) (aref cvec2 j)) + (setq i (1+ i))) + (do ((j end1 (1+ j))) + ((= j l1)) + (setf (aref r i) (aref cvec1 j)) + (setq i (1+ i))) + r) + )) + +; 19.0 Operations on Arbitrary Objects + +; 19.1 Creating + +(defun MSUBST (new old tree) (subst new old tree :test #'equal)) +; note subst isn't guaranteed to copy +(defun |nsubst| (new old tree) (nsubst new old tree :test #'equal)) +(define-function 'MSUBSTQ #'subst) ;default test is eql +(define-function 'SUBSTQ #'SUBST) ;default test is eql subst is not guaranteed to copy + +(defun copy (x) (copy-tree x)) ; not right since should descend vectors + +(defun eqsubstlist (new old list) (sublis (mapcar #'cons old new) list)) + +; Gen code for SETQP expr + +(eval-when + #+:common-lisp (:compile-toplevel :load-toplevel :execute) + #-:common-lisp (compile load eval) + (defun DCQEXP (FORM EQTAG) + (PROG (SV pvl avl CODE) + (declare (special pvl avl)) + (setq SV (GENSYM)) + (setq CODE (DCQGENEXP SV FORM EQTAG NIL)) + (RETURN + `(LAMBDA (,sv) + (PROG ,pvl + ,@code + (RETURN 'true) + BAD (RETURN NIL) ) )))) +) +; Generate Expr code for DCQ +(eval-when + #+:common-lisp (:compile-toplevel :load-toplevel :execute) + #-:common-lisp (compile load eval) + (defun DCQGENEXP (SV FORM EQTAG QFLAG) + (PROG (D A I L C W) + (declare (special pvl avl)) + (COND ((EQ FORM SV) (RETURN NIL)) + ((IDENTP FORM) (RETURN `((setq ,form ,sv)) )) + ((simple-vector-p FORM) + (RETURN (SEQ + (setq L (length FORM)) + (IF (EQ L 0) + (RETURN (COND ((NULL QFLAG) + `((cond ((not (simple-vector-p ,sv)) (go bad)))))))) + (setq I (1- L)) + LP (setq A (elt FORM I)) + (COND ((AND (NULL W) (OR (consp A) (simple-vector-p A))) + (COND ((consp AVL) (setq W (car (RESETQ AVL (cdr AVL))))) + ((setq PVL (CONS (setq W (GENSYM)) PVL)))))) + (setq C (NCONC (COND ((IDENTP A) `((setq ,a (ELT ,sv ,i)))) + ((OR (consp A) (simple-vector-p A)) + `((setq ,w (ELT ,sv ,i)) + ,@(dcqgenexp w a eqtag qflag)))) + C)) + (if (EQ I 0) (GO RET)) + (setq I (1- I)) + (GO LP) + RET (if W (setq AVL (CONS W AVL))) + (COND ((NULL QFLAG) + `((COND ((OR (NOT (simple-vector-p ,sv)) (< (length ,sv) ,l)) + (GO BAD))) + ,@c)) + ('T C))))) + ((NOT (consp FORM)) (RETURN NIL)) + ((AND EQTAG (EQ (car FORM) EQTAG)) + (RETURN + (COND + ((OR (NOT (EQ 3 (LENGTH FORM))) (NOT (IDENTP (car (setq FORM (cdr FORM)))))) + (MACRO-INVALIDARGS 'DCQ\/QDCQ FORM (MAKESTRING "invalid pattern."))) + (`((setq ,(car form) ,sv) ,@(DCQGENEXP SV (CADR FORM) EQTAG QFLAG))))))) + (setq A (car FORM)) + (setq D (cdr FORM)) + (setq C (COND ((IDENTP A) `((setq ,a (CAR ,sv)))) + ((OR (consp A) (simple-vector-p A)) + (COND ((AND (NULL D) (IDENTP SV)) ) + ((COND ((consp AVL) (setq W (car (RESETQ AVL (cdr AVL))))) + ((setq PVL (CONS (setq W (GENSYM)) PVL)) ) ) ) ) + (COND ((AND (consp A) EQTAG (EQ (car A) EQTAG)) + (DCQGENEXP (LIST 'CAR SV) A EQTAG QFLAG) ) + (`((setq ,(or w sv) (CAR ,sv)) + ,@(DCQGENEXP (OR W SV) A EQTAG QFLAG))))))) + (setq C (NCONC C (COND ((IDENTP D) `((setq ,d (CDR ,sv)))) + ((OR (consp D) (simple-vector-p D)) + (COND + ((OR W (IDENTP SV)) ) + ((COND ((consp AVL) + (setq W (car (RESETQ AVL (cdr AVL)))) ) + ((setq PVL (CONS (setq W (GENSYM)) PVL)) ) ) ) ) + (COND ((AND (consp D) EQTAG (EQ (car D) EQTAG)) + (DCQGENEXP (LIST 'CDR SV) D EQTAG QFLAG) ) + (`((setq ,(or w sv) (CDR ,sv)) + ,@(DCQGENEXP (OR W SV) D EQTAG QFLAG)))))))) + (COND (W (setq AVL (CONS W AVL)))) + (RETURN (COND ((NULL QFLAG) `((COND ((ATOM ,sv) (GO BAD))) ,@c)) (C))))) +) + + +; 19.3 Searching + +; Generate code for EQQ + +(eval-when + #+:common-lisp (:compile-toplevel :load-toplevel :execute) + #-:common-lisp (compile load eval) + (defun ECQEXP (FORM QFLAG) + (PROG (SV PVL CODE) + (declare (special pvl)) + (setq SV (GENSYM)) + (setq CODE (ECQGENEXP SV FORM QFLAG)) + (RETURN + `(LAMBDA (,sv) + (PROG ,pvl + ,@code + (RETURN 'true) + BAD (RETURN NIL) ) )))) +) + +; Generate code for EQQ innards + +(eval-when + #+:common-lisp (:compile-toplevel :load-toplevel :execute) + #-:common-lisp (compile load eval) + (defun ECQGENEXP (SV FORM QFLAG) + (PROG (D A I L C W) + (declare (special pvl)) + (COND + ((EQ FORM SV) (RETURN NIL)) + ((OR + (IDENTP FORM) + (NUMP FORM) + (AND (consp FORM) (EQ (qcar FORM) 'QUOTE))) + (RETURN + `((COND ((NOT (EQ ,form ,sv)) (GO BAD))) ))) + ((simple-vector-p FORM) + (RETURN (SEQ + (setq L (length FORM)) + (if (EQ L 0) + (RETURN + (COND ((NULL QFLAG) + `((COND ((NOT (simple-vector-p ,sv)) (GO BAD))) ))) + )) + (setq I (1- L)) + LP (setq A (elt FORM I)) + (if (AND (NULL W) (OR (consp A) (simple-vector-p A))) + (push (setq W (GENSYM)) PVL)) + (setq C + (NCONC + (COND + ( (OR + (IDENTP A) + (NUMP A) + (AND (consp A) (EQ (qcar A) 'QUOTE))) + `((COND ( (NOT (EQ ,a (ELT ,sv ,i))) + (GO BAD) ) ) ) ) + ( (OR (consp A) (simple-vector-p A)) + `((setq ,w (ELT ,sv ,i)) + ,@(ECQGENEXP W A QFLAG)))) + C) ) + (if (EQ I 0) (GO RET) ) + (setq I (1- I)) + (GO LP) + RET + (COND + ( (NULL QFLAG) + `((COND ( (OR + (NOT (simple-vector-p ,sv)) + (< (length ,sv) ,l)) + (GO BAD) ) ) + ,@c)) + ( 'T C ) )) )) + ( (NOT (consp FORM)) + (RETURN NIL) ) ) + (setq A (car FORM)) + (setq D (cdr FORM)) + (if (OR (consp A) (simple-vector-p A) (consp D) (simple-vector-p D)) + (setq PVL (CONS (setq W (GENSYM)) PVL))) + (setq C + (COND + ( (OR (IDENTP A) (NUMP A) (AND (consp A) (EQ (car A) 'QUOTE))) + `((COND ((NOT (EQ ,a (CAR ,sv))) (GO BAD))) )) + ( (OR (consp A) (simple-vector-p A)) + `((setq ,w (CAR ,sv)) + ,@(ECQGENEXP W A QFLAG))))) + (setq C + (NCONC + C + (COND + ( (OR (IDENTP D) (NUMP D) (AND (consp D) + (EQ (car D) 'QUOTE))) + `((COND ((NOT (EQ ,d (CDR ,sv))) (GO BAD))) )) + ( (OR (consp D) (simple-vector-p D)) + `((setq ,sv (CDR ,sv)) + ,@(ECQGENEXP SV D QFLAG)))))) + (RETURN + (COND + ( (NULL QFLAG) + `((COND ( (ATOM ,sv) + (GO BAD) ) ) + ,@c)) + ( 'T + C ) )) ) ) +) + +; 19.4 Updating + +; Generate code for RPLQ exprs + +(eval-when + #+:common-lisp (:compile-toplevel :load-toplevel :execute) + #-:common-lisp (compile load eval) + (defun RCQEXP (FORM) + (PROG (SV PVL CODE) + (declare (special pvl)) + (setq SV (GENSYM)) + (setq CODE (RCQGENEXP SV FORM NIL)) + (RETURN + `(LAMBDA (,sv) + (PROG ,pvl + ,@code + (RETURN 'true) + BAD (RETURN NIL) ) )))) +) + +; Generate code for RPLQ expr innards + +(eval-when + #+:common-lisp (:compile-toplevel :load-toplevel :execute) + #-:common-lisp (compile load eval) + (defun RCQGENEXP (SV FORM QFLAG) + (PROG (D A I L C W) + (declare (special pvl)) + (COND + ( (EQ FORM SV) + (RETURN NIL) ) + ( (simple-vector-p FORM) + (RETURN (SEQ + (setq L (length FORM)) + (if (EQ L 0) (RETURN NIL)) + (setq I (1- L)) + LP (setq A (elt FORM I)) + (COND + ( (AND + (NULL W) + (OR (AND (consp A) (NOT (EQ (car A) 'QUOTE))) + (simple-vector-p A))) + (setq PVL (CONS (setq W (GENSYM)) PVL)) ) ) + (setq C + (NCONC + (COND + ( (OR + (IDENTP A) + (NUMP A) + (AND (consp A) (EQ (car A) 'QUOTE))) + `((SETELT ,sv ,i ,a))) + ( (OR (consp A) (simple-vector-p A)) + `((setq ,w (ELT ,sv ,i)) + ,@(RCQGENEXP W A QFLAG)))) + C) ) + (COND + ( (EQ I 0) + (GO RET) ) ) + (setq I (1- I)) + (GO LP) + RET (RETURN + (COND + ( (NULL QFLAG) + `((COND ( (OR + (NOT (simple-vector-p ,sv)) + (< (length ,sv) ,l)) + (GO BAD) ) ) + ,@c)) + ( 'T + C ) )) ))) + ( (NOT (consp FORM)) + (RETURN NIL) ) ) + (setq A (car FORM)) + (setq D (cdr FORM)) + (cond + ( (or (and (consp A) (NOT (EQ (car A) 'QUOTE))) (simple-vector-p A)) + (setq PVL (CONS (setq W (GENSYM)) PVL)) ) ) + (setq C + (COND + ( (OR (IDENTP A) (NUMP A) (AND (consp A) (EQ (car A) 'QUOTE))) + `((rplaca ,sv ,a))) + ( (OR (consp A) (simple-vector-p A)) + `((setq ,w (CAR ,sv)) + ,@(RCQGENEXP W A QFLAG))))) + (setq C + (NCONC + C + (COND + ( (OR (IDENTP D) (NUMP D) (AND (consp D) (EQ (car D) 'QUOTE))) + `((RPLACD ,sv ,d))) + ( (OR (consp D) (simple-vector-p D)) + `((setq ,sv (CDR ,sv)) + ,@(RCQGENEXP SV D QFLAG)))))) + (RETURN + (COND + ( (NULL QFLAG) + `((COND ( (ATOM ,sv) + (GO BAD) ) ) + ,@c)) + ( 'T + C ) )) ) ) +) + +; 22.0 Internal and External Forms + +; 23.0 Reading + + +(define-function 'next #'read-char) + +; 24.0 Printing + +;(define-function 'prin2cvec #'write-to-string) +(define-function 'prin2cvec #'princ-to-string) +;(define-function 'stringimage #'write-to-string) +(define-function 'stringimage #'princ-to-string) + +(define-function 'printexp #'princ) +(define-function 'prin0 #'prin1) + +(defun |F,PRINT-ONE| (form &optional (stream *standard-output*)) + (declare (ignore stream)) + (let ((*print-level* 4) (*print-length* 4)) + (prin1 form) (terpri))) + +(defun prettyprint (x &optional (stream *standard-output*)) + (prettyprin0 x stream) (terpri stream)) + +(defun prettyprin0 (x &optional (stream *standard-output*)) + (let ((*print-pretty* t) (*print-array* t)) + (prin1 x stream))) + +(defun vmprint (x &optional (stream *standard-output*)) + (prin1 x stream) (terpri stream)) + +(defun tab (sint &optional (stream t)) + (format stream "~vT" sint)) + +; 27.0 Stream I/O + + +; 27.1 Creation + +(defun MAKE-INSTREAM (filespec &optional (recnum 0)) + (declare (ignore recnum)) + (cond ((numberp filespec) (make-synonym-stream '*terminal-io*)) + ((null filespec) (error "not handled yet")) + (t (open (make-input-filename filespec) + :direction :input :if-does-not-exist nil)))) + +(defun MAKE-OUTSTREAM (filespec &optional (width nil) (recnum 0)) + (declare (ignore width) (ignore recnum)) + (cond ((numberp filespec) (make-synonym-stream '*terminal-io*)) + ((null filespec) (error "not handled yet")) + (t (open (make-filename filespec) :direction :output)))) + +(defun MAKE-APPENDSTREAM (filespec &optional (width nil) (recnum 0)) + "fortran support" + (declare (ignore width) (ignore recnum)) + (cond + ((numberp filespec) (make-synonym-stream '*terminal-io*)) + ((null filespec) (error "make-appendstream: not handled yet")) + ('else (open (make-filename filespec) :direction :output + :if-exists :append :if-does-not-exist :create)))) + +(defun DEFIOSTREAM (stream-alist buffer-size char-position) + (declare (ignore buffer-size)) + (let ((mode (or (cdr (assoc 'MODE stream-alist)) 'INPUT)) + (filename (cdr (assoc 'FILE stream-alist))) + (dev (cdr (assoc 'DEVICE stream-alist)))) + (if (EQ dev 'CONSOLE) (make-synonym-stream '*terminal-io*) + (let ((strm (case mode + ((OUTPUT O) (open (make-filename filename) + :direction :output)) + ((INPUT I) (open (make-input-filename filename) + :direction :input))))) + (if (and (numberp char-position) (> char-position 0)) + (file-position strm char-position)) + strm)))) + +(defun shut (st) (if (is-console st) st + (if (streamp st) (close st) -1))) + +(defun EOFP (stream) (null (peek-char nil stream nil nil))) + +; 28.0 Key addressed I/O + + +; 46.0 Call tracing + + +(defun EMBEDDED () (mapcar #'car *embedded-functions*)) + +(defun EMBED (CURRENT-BINDING NEW-DEFINITION) + (PROG +#+:CCL (OP BV BODY OLD-DEF *COMP) +#-:CCL (OP BV BODY OLD-DEF) + (COND + ( (NOT (IDENTP CURRENT-BINDING)) + (SETQ CURRENT-BINDING + (error (format nil "invalid argument ~s to EMBED" CURRENT-BINDING))) ) ) + (SETQ OLD-DEF (symbol-function CURRENT-BINDING)) + (SETQ NEW-DEFINITION + (SETF (symbol-function CURRENT-BINDING) + (COND + ( (NOT (consp NEW-DEFINITION)) + NEW-DEFINITION ) + ( (AND + (DCQ (OP BV . BODY) NEW-DEFINITION) + (OR (EQ OP 'LAMBDA) (EQ OP 'MLAMBDA))) + (COND + ( (NOT (MEMQ CURRENT-BINDING (FLAT-BV-LIST BV))) + `(,OP ,BV ((LAMBDA (,CURRENT-BINDING) . ,BODY) ',OLD-DEF)) + ) + ( 'T + NEW-DEFINITION ) ) ) + ( 'T + `((LAMBDA (,CURRENT-BINDING) ,NEW-DEFINITION) ',OLD-DEF))) + ) ) +#+:CCL (IF (CONSP NEW-DEFINITION) (SETQ NEW-DEFINITION (CDR NEW-DEFINITION))) + (push (LIST CURRENT-BINDING NEW-DEFINITION OLD-DEF) *embedded-functions*) + (RETURN CURRENT-BINDING) ) ) + +(defun UNEMBED (CURRENT-BINDING) + (PROG +#+:CCL (TMP E-LIST CUR-DEF *COMP) +#-:CCL (TMP E-LIST CUR-DEF) + (SETQ E-LIST *embedded-functions*) + (SETQ CUR-DEF (symbol-function CURRENT-BINDING)) +#+:CCL (IF (CONSP CUR-DEF) (SETQ CUR-DEF (CDR CUR-DEF))) + (COND + ( (NOT (consp E-LIST)) + NIL ) + ( (ECQ ((CURRENT-BINDING CUR-DEF)) E-LIST) + (SETF (symbol-function CURRENT-BINDING) (QCADDAR E-LIST)) + (SETQ *embedded-functions* (QCDR E-LIST)) + (RETURN CURRENT-BINDING) ) + ( 'T + (SEQ + (SETQ TMP E-LIST) + LP (COND + ( (NOT (consp (QCDR TMP))) + (EXIT NIL) ) + ( (NULL (ECQ ((CURRENT-BINDING CUR-DEF)) (QCDR TMP))) + (SETQ TMP (QCDR TMP)) + (GO LP) ) + ( 'T + (SETF (symbol-function CURRENT-BINDING) (QCAR (QCDDADR TMP))) + (RPLACD TMP (QCDDR TMP)) + (RETURN CURRENT-BINDING) ) ) ) ) ) + (RETURN NIL) )) + +(defun FLAT-BV-LIST (BV-LIST) + (PROG (TMP1) + (RETURN + (COND + ( (VARP BV-LIST) + (LIST BV-LIST) ) + ( (REFVECP BV-LIST) + (FLAT-BV-LIST (VEC2LIST (MAPELT #'FLAT-BV-LIST BV-LIST))) ) + ( (NOT (consp BV-LIST)) + NIL ) + ( (EQ '= (SETQ TMP1 (QCAR BV-LIST))) + (FLAT-BV-LIST (QCDR BV-LIST)) ) + ( (VARP TMP1) + (CONS TMP1 (FLAT-BV-LIST (QCDR BV-LIST))) ) + ( (AND (NOT (consp TMP1)) (NOT (REFVECP TMP1))) + (FLAT-BV-LIST (QCDR BV-LIST)) ) + ( 'T + (NCONC (FLAT-BV-LIST TMP1) (FLAT-BV-LIST (QCDR BV-LIST))) ) )) )) + +(defun VARP (TEST-ITEM) + (COND + ( (IDENTP TEST-ITEM) + TEST-ITEM ) + ( (AND + (consp TEST-ITEM) + (OR (EQ (QCAR TEST-ITEM) 'FLUID) (EQ (QCAR TEST-ITEM) 'LEX)) + (consp (QCDR TEST-ITEM)) + (IDENTP (QCADR TEST-ITEM))) + TEST-ITEM ) + ( 'T + NIL ) ) ) + +; 48.0 Miscellaneous CMS Interactions + +(defun CurrentTime () + (multiple-value-bind (sec min hour day month year) (get-decoded-time) + (format nil "~2,'0D/~2,'0D/~2,'0D~2,'0D:~2,'0D:~2,'0D" + month day (rem year 100) hour min sec))) + +(defun $screensize () '(24 80)) ; You tell me!! + +; 97.0 Stuff In The Manual But Wierdly Documented + +(defun EBCDIC (x) (code-char x)) + +;; This isn't really compatible but is as close as you can get in common lisp +;; In place of ((one-of 1 2 3) l) you should use +;; (funcall (one-of 1 2 3) l) + +(defun doDSETQ (form pattern exp) + (let (PVL AVL) + (declare (special PVL AVL)) + (COND ((IDENTP PATTERN) + (LIST 'SETQ PATTERN EXP)) + ((AND (NOT (consp PATTERN)) (NOT (simple-vector-p PATTERN))) + (MACRO-INVALIDARGS 'DSETQ FORM "constant target.")) + ((let* ((SV (GENSYM)) + (E-PART (DCQGENEXP (LIST 'IDENTITY SV) PATTERN '= NIL))) + (setq e-part + `(LAMBDA (,sv) + (PROG ,pvl + ,@e-part + (RETURN ,sv) + BAD (RETURN (SETQERROR ,sv))))) + `(,e-part ,exp)))))) + +(defun SETQERROR (&rest FORM) (error (format nil "in destructuring ~S" FORM))) + + + + +(defun MACRO-INVALIDARGS (NAME FORM MESSAGE) + (setq MACERRORCOUNT (+ 1 (eval 'MACERRORCOUNT))) + (error (format nil + "invalid arguments to macro ~S with invalid argument ~S, ~S" + name form message))) + +(defun MACRO-MISSINGARGS (NAME ignore N) + (declare (ignore ignore)) + (setq MACERRORCOUNT (+ 1 (eval 'MACERRORCOUNT))) + (let ((nargs (abs N))) + (error (concatenate 'string (symbol-name NAME) " requires " + (if (minusp N) "at least " "exactly ") + (case nargs (0 "no") (1 "one") (2 "two") (3 "three") + (4 "four") (5 "five") (6 "six") + (t (princ-to-string nargs))) + (if (eq nargs 1) " argument," " arguments,"))))) + +(defun MACERR (MESSAGE &rest ignore) + (declare (ignore ignore)) + (setq MACERRORCOUNT (+ 1 (eval 'MACERRORCOUNT))) + (error + (LIST "in the expression:" MESSAGE)) + ()) + +#+Lucid +(defun numberofargs (x) + (setq x (system::arglist x)) + (let ((nx (- (length x) (length (memq '&aux x))))) + (if (memq '&rest x) (setq nx (- (1- nx)))) + (if (memq '&optional x) (setq nx (- (1- (abs nx))))) + nx)) + +; 98.0 Stuff Not In The VMLisp Manual That We Like + +; A version of GET that works with lists + +;; GETL(SYM, KEY) +;; KEY: a SYMBOL +;; SYM: a SYMBOL or a LIST whose elements are SYMBOLs or LISTs. +;; Returns: +;; when SYM is a SYMBOL, returns the KEY-property of SYM. +;; when SYM is a LIST, returns the either the KEY-property of the +;; first SYMBOL of SYM that has the KEY-property, or the CDR of the +;; first cons-cell whose CAR is EQ KEY. +(defun getl (sym key) + (cond ((symbolp sym) + (get sym key)) + ((null sym) nil) + ((consp sym) + (let ((sym-1 (car sym))) + (cond ((symbolp sym-1) + (get sym-1 key)) + ((and (consp sym-1) + (symbolp (car sym-1))) + (if (eq (car sym-1) key) + (cdr sym-1) + (getl (cdr sym) key)))))))) + +; The following should actually position the cursor at the sint'th line of the screen: + +(defun $showline (cvec sint) (terpri) sint (princ cvec)) + +; 99.0 Ancient Stuff We Decided To Keep + +(defun LAM\,EVALANDFILEACTQ (name &optional (form name)) + (LAM\,FILEACTQ name form) (eval form)) + +(defun LAM\,FILEACTQ (name form) + (if *FILEACTQ-APPLY* (FUNCALL *FILEACTQ-APPLY* name form))) + +(defun CALLBELOW (&rest junk) junk) ; to invoke system dependent code? + +(define-function 'EVA1 #'eval) ;EVA1 and VMLISP EVAL make lexicals visible +(define-function 'EVALFUN #'eval) ;EVALFUN drops lexicals before evaluating +(define-function 'EVA1FUN #'EVALFUN) + +(defun PLACEP (item) (eq item *read-place-holder*)) +(defun VMREAD (&optional (st *standard-input*) (eofval *read-place-holder*)) + (read st nil eofval)) +(defun |read-line| (st &optional (eofval *read-place-holder*)) + (read-line st nil eofval)) + +(defun STATEP (item) + (declare (ignore item)) + nil) ;no state objects +(defun FUNARGP (item) + (declare (ignore item)) + nil) ;can't tell closures from other functions +(defun PAPPP (item) + (declare (ignore item)) + nil) ;no partial application objects + +#+Lucid +(defun gcmsg (x) + (prog1 (not system::*gc-silence*) (setq system::*gc-silence* (not x)))) +#+(OR IBCL KCL) +(defun gcmsg (x) + (prog1 system:*gbc-message* (setq system:*gbc-message* x))) +#+:cmulisp +(defun gcmsg (x) + (prog1 ext:*gc-verbose* (setq ext:*gc-verbose* x))) +#+:allegro +(defun gcmsg (x)) + +#+Lucid +(defun reclaim () (system:gc)) +#+:cmulisp +(defun reclaim () (ext:gc)) +#+(OR IBCL KCL) +(defun reclaim () (gbc t)) +#+:allegro +(defun reclaim () (excl::gc t)) +#+:CCL +(defun reclaim () (gc)) + +#+Lucid +(defun BPINAME (func) + (if (functionp func) + (if (symbolp func) func + (let ((name (svref func 0))) + (if (and (consp name) (eq (car name) 'SYSTEM::NAMED-LAMBDA)) + (cadr name) + name)) ))) + +#+(OR IBCL KCL) +(defun BPINAME (func) + (if (functionp func) + (cond ((symbolp func) func) + ((and (consp func) (eq (car func) 'LAMBDA-BLOCK)) + (cadr func)) + ((compiled-function-p func) + (system:compiled-function-name func)) + ('t func)))) +#+:cmulisp +(defun BPINAME (func) + (when (functionp func) + (cond + ((symbolp func) func) + ((and (consp func) (eq (car func) 'lambda)) (second (third func))) + ((compiled-function-p func) + (system::%primitive header-ref func system::%function-name-slot)) + ('else func)))) +#+:allegro +(defun bpiname (func) + func) +#+:CCL +(defun bpiname (x) + (if (symbolp x) + (intern (symbol-name (symbol-function x)) "BOOT") + nil)) + +#+:SBCL +(defun BPINAME (x) + (multiple-value-bind (l c n) + (function-lambda-expression x) + (declare (ignore l c)) + n)) + +(defun LISTOFQUOTES (bpi) + (declare (ignore bpi)) + ()) + +#+Lucid +(defun LISTOFFREES (bpi) + (if (compiled-function-p bpi) + (let ((end (- (lucid::procedure-length bpi) 2))) + (do ((i 3 (1+ i)) + (ans nil)) + ((> i end) ans) + (let ((locexp (svref bpi i))) + (if (symbolp locexp) (push locexp ans))))))) + +#-Lucid +(defun LISTOFFREES (bpi) + (declare (ignore bpi)) + ()) + + +#+(and :Lucid (not :ibm/370)) +(defun OBEY (S) + (system::run-aix-program (make-absolute-filename "/lib/obey") + :arguments (list "-c" S))) +#+:cmulisp +(defun OBEY (S) + (ext:run-program (make-absolute-filename "/lib/obey") + (list "-c" S) :input t :output t)) +#+(OR IBCL KCL :CCL) +(defun OBEY (S) (SYSTEM S)) + +#+:allegro +(defun OBEY (S) (excl::run-shell-command s)) + +(defun RE-ENABLE-INT (number-of-handler) number-of-handler) + + +(defun QUOREM (i j r) ; never used, refed in parini.boot + (multiple-value-bind (x y) (truncate i j) + (rplaca (the cons r) x) (rplacd (the cons r) y))) + +(defun MAKE-BVEC (n) + (make-array (list n) :element-type 'bit :initial-element 0)) + diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet deleted file mode 100644 index 086c82f7..00000000 --- a/src/interp/vmlisp.lisp.pamphlet +++ /dev/null @@ -1,2015 +0,0 @@ -%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/vmlisp.lisp} Pamphlet} -\author{Lars Ericson, Barry Trager, Martial Schor, Timothy Daly} - -\begin{document} -\maketitle - -\begin{abstract} -\end{abstract} - -\tableofcontents -\eject - - -\section{License} - -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; 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 above 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. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; 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 OWNER -;; 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. - -@ - - -\section{The [[VMLISP]] package} - -This is the package that originally contained the \Tool{VMLisp} macros -but in fact contains macros to support several other lisps. It -is essentially the place where most of the macros to support -idioms from prior ports (like [[rdefiostream]] and [[fileactq]]) - -The content of [[VMLISP]] was moved to [[BOOT]]. - -\section{The StringImage Fix} - -In GCL 2.5 there is a bug in the write-to-string function. -It should respect *print-escape* but it does not. That is, -\begin{verbatim} - -In GCL 2.4.1: -(setq *print-escape* nil) -(write-to-string '|a|) ==> "a" - -In GCL 2.5: -(setq *print-escape* nil) -(write-to-string '|a|) ==> "|a|" - -\end{verbatim} -The form2LispString function uses stringimage and fails. -The princ-to-string function assumes *print-escape* is nil -and works properly. - -<>= -;(define-function 'prin2cvec #'write-to-string) -(define-function 'prin2cvec #'princ-to-string) -;(define-function 'stringimage #'write-to-string) -(define-function 'stringimage #'princ-to-string) - -@ - - -<<*>>= - -(IMPORT-MODULE "boot-pkg") - -; VM LISP EMULATION PACKAGE -; Lars Ericson, Barry Trager, Martial Schor, tim daly, LVMCL, et al -; IBM Thomas J. Watson Research Center -; Summer, 1986 -; see /spad/daly.changes - -; This emulation package version is written for Symbolics Common Lisp. -; Emulation commentary refers to LISP/VM, IBM Program Number 5798-DQZ, -; as described in the LISP/VM User's Guide, document SH20-6477-1. -; Main comment section headings refer to sections in the User's Guide. - -; If you are using this, you are probably in Common Lisp, yes? - -(in-package "BOOT") - -;; DEFVARS - -(defvar *comp370-apply* nil "function (name def) for comp370 to apply") - -(defvar curinstream (make-synonym-stream '*standard-input*)) - -(defvar curoutstream (make-synonym-stream '*standard-output*)) - -(defvar *embedded-functions* nil) - -(defvar errorinstream (make-synonym-stream '*terminal-io*)) - -(defvar erroroutstream (make-synonym-stream '*terminal-io*)) - -(defvar *fileactq-apply* nil "function to apply in fileactq") - -(defvar *lam-name* nil "name to be used by lam macro if non-nil") - -(defvar macerrorcount 0 "Put some documentation in here someday") - -(defvar *read-place-holder* (make-symbol "%.EOF") - "default value returned by read and read-line at end-of-file") - -;; DEFMACROS - - -(defmacro absval (x) - `(abs ,x)) - -#-:CCL -(defmacro add1 (x) - `(1+ ,x)) - -(defmacro assemble (&rest ignore) - (declare (ignore ignore)) - nil) - -(defmacro applx (&rest args) - `(apply ,@args)) - -#-(or LispM Lucid :CCL) -(defmacro assq (a b) - `(assoc ,a ,b :test #'eq)) - -#+:CCL -(defmacro assq (a b) `(atsoc ,a ,b)) - -#-:CCL -(defmacro bintp (n) - `(typep ,n 'bignum)) -#+:CCL -(defun bintp (n) (and (integerp n) (not (fixp n)))) - -(defmacro |char| (x) - (if (and (consp x) (eq (car x) 'quote)) (character (cadr x)) - `(character ,x))) - -(defmacro closedfn (form) - `(function ,form)) - -(defmacro |copyList| (x) - `(copy-list ,x)) - -(defmacro create-sbc (x) x) ;a no-op for common lisp - -(defmacro cvecp (x) - `(stringp ,x)) - -(defmacro dcq (&rest args) - (cons 'setqp args)) - -#-:CCL -(defmacro difference (&rest args) - `(- ,@args)) - -(defmacro dsetq (&whole form pattern exp) - (dodsetq form pattern exp)) - -(defmacro ecq (&rest args) - (cons 'eqq args)) - -;;def needed to prevent recursion in def of eqcar -(eval-when - #+:common-lisp (:compile-toplevel :load-toplevel :execute) - #-:common-lisp (compile load eval) - (defun equable (x) - (or (null x) - (and (consp x) (eq (car x) 'quote) - (symbolp (cadr x)))))) - -#-:CCL -(defmacro eqcar (x y) - (let ((test - (cond - ((equable y) 'eq) - ((integerp y) 'i=) - ('eql)))) - (if (atom x) - `(and (consp ,x) (,test (qcar ,x) ,y)) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (and (consp ,xx) (,test (qcar ,xx) ,y))))))) - -(defmacro eqq (pattern exp) - `(,(ecqexp pattern nil) ,exp)) - -(defmacro |equal| (x y) - `(equalp ,x ,y)) - -(defmacro evalandfileactq (name &optional (form name)) - `(eval-when - #+:common-lisp (:load-toplevel :execute) - #-:common-lisp (eval load) - ,form)) - -(defmacro exit (&rest value) - `(return-from seq ,@value)) - -(defmacro fetchchar (x i) - `(char ,x ,i)) - -#-:CCL ;; fixp in ccl tests for fixnum -(defmacro fixp (x) - `(integerp ,x)) - -#-:CCL -(defmacro greaterp (&rest args) - `(> ,@args)) - -(defmacro i= (x y) ;; integer equality - (if (typep y 'fixnum) - (let ((gx (gensym))) - `(let ((,gx ,x)) - (and (typep ,gx 'fixnum) (eql (the fixnum ,gx) ,y)))) - (let ((gx (gensym)) (gy (gensym))) - `(let ((,gx ,x) (,gy ,y)) - (cond ((and (typep ,gx 'fixnum) (typep ,gy 'fixnum)) - (eql (the fixnum ,gx) (the fixnum ,gy))) - ((eql (the integer ,gx) (the integer,gy)))))))) - -(defmacro |idChar?| (x) - `(or (alphanumericp ,x) (member ,x '(#\? #\% #\' #\!) :test #'char=))) - -(defmacro identp (x) - (if (atom x) - `(and ,x (symbolp ,x)) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (and ,xx (symbolp ,xx)))))) - -(defmacro ifcar (x) - (if (atom x) - `(and (consp ,x) (qcar ,x)) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (and (consp ,xx) (qcar ,xx)))))) - -(defmacro ifcdr (x) - (if (atom x) - `(and (consp ,x) (qcdr ,x)) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (and (consp ,xx) (qcdr ,xx)))))) - -(defmacro intp (x) - `(integerp ,x)) - -(defmacro lam (&rest body) - (list 'quote (*lam (copy-tree body)))) - -(defmacro lastnode (l) - `(last ,l)) - -(defmacro lastpair (l) - `(last ,l)) - -#-:CCL -(defmacro lessp (&rest args) - `(< ,@args)) - -(defmacro lintp (n) - `(typep ,n 'bignum)) - -(defmacro makestring (a) a) - -(defmacro mapelt (f vec) - `(map 'vector ,f ,vec)) - -(defmacro maxindex (x) - `(the fixnum (1- (the fixnum (length ,x))))) - -#-(or LispM Lucid :CCL) -(defmacro memq (a b) - `(member ,a ,b :test #'eq)) - -#-:CCL -(defmacro minus (x) - `(- ,x)) - -(defmacro mrp (x) - `(special-form-p ,x)) - -(defmacro namederrset (id iexp &rest item) - (declare (ignore item)) - `(catch ,id ,iexp)) - -(defmacro ne (a b) `(not (equal ,a ,b))) - -;;; This may need adjustment in CCL where NEQ means (NOT (EQUAL ..))) -#-:CCL -(defmacro neq (a b) `(not (eq ,a ,b))) - -#-:CCL -(defmacro nreverse0 (x) - (if (atom x) - `(if (atom ,x) ,x (nreverse ,x)) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (if (atom ,xx) ,xx (nreverse ,xx)))))) - -(defmacro nump (n) - `(numberp ,n)) - -(defmacro |opOf| (x) ;(if (atom x) x (qcar x)) - (if (atom x) - `(if (consp ,x) (qcar ,x) ,x) - (let ((xx (gensym))) - `(let ((,xx ,x)) - (if (consp ,xx) (qcar ,xx) ,xx))))) - -(defmacro oraddtempdefs (filearg) - `(eval-when - #+:common-lisp (:compile-toplevel) - #-:common-lisp (compile) - (load ,filearg))) - -(defmacro pairp (x) - `(consp ,x)) - -#-:CCL -(defmacro plus (&rest args) - `(+ ,@ args)) - -; (defmacro qassq (a b) -; `(assoc ,a ,b :test #'eq)) -(defmacro qassq (a b) `(assq ,a ,b)) - -#-:CCL -(defmacro qcar (x) - `(car (the cons ,x))) -#-:CCL -(defmacro qcdr (x) - `(cdr (the cons ,x))) - -#-:CCL -(defmacro qcaar (x) - `(car (the cons (car (the cons ,x))))) -#-:CCL -(defmacro qcadr (x) - `(car (the cons (cdr (the cons ,x))))) -#-:CCL -(defmacro qcdar (x) - `(cdr (the cons (car (the cons ,x))))) -#-:CCL -(defmacro qcddr (x) - `(cdr (the cons (cdr (the cons ,x))))) - -(defmacro qcaaar (x) - `(car (the cons (car (the cons (car (the cons ,x))))))) -(defmacro qcaadr (x) - `(car (the cons (car (the cons (cdr (the cons ,x))))))) -(defmacro qcadar (x) - `(car (the cons (cdr (the cons (car (the cons ,x))))))) -(defmacro qcaddr (x) - `(car (the cons (cdr (the cons (cdr (the cons ,x))))))) -(defmacro qcdaar (x) - `(cdr (the cons (car (the cons (car (the cons ,x))))))) -(defmacro qcdadr (x) - `(cdr (the cons (car (the cons (cdr (the cons ,x))))))) -(defmacro qcddar (x) - `(cdr (the cons (cdr (the cons (car (the cons ,x))))))) -(defmacro qcdddr (x) - `(cdr (the cons (cdr (the cons (cdr (the cons ,x))))))) - -(defmacro qcaaaar (x) - `(car (the cons (car (the cons (car (the cons (car (the cons ,x))))))))) -(defmacro qcaaadr (x) - `(car (the cons (car (the cons (car (the cons (cdr (the cons ,x))))))))) -(defmacro qcaadar (x) - `(car (the cons (car (the cons (cdr (the cons (car (the cons ,x))))))))) -(defmacro qcaaddr (x) - `(car (the cons (car (the cons (cdr (the cons (cdr (the cons ,x))))))))) -(defmacro qcadaar (x) - `(car (the cons (cdr (the cons (car (the cons (car (the cons ,x))))))))) -(defmacro qcadadr (x) - `(car (the cons (cdr (the cons (car (the cons (cdr (the cons ,x))))))))) -(defmacro qcaddar (x) - `(car (the cons (cdr (the cons (cdr (the cons (car (the cons ,x))))))))) -(defmacro qcadddr (x) - `(car (the cons (cdr (the cons (cdr (the cons (cdr (the cons ,x))))))))) -(defmacro qcdaaar (x) - `(cdr (the cons (car (the cons (car (the cons (car (the cons ,x))))))))) -(defmacro qcdaadr (x) - `(cdr (the cons (car (the cons (car (the cons (cdr (the cons ,x))))))))) -(defmacro qcdadar (x) - `(cdr (the cons (car (the cons (cdr (the cons (car (the cons ,x))))))))) -(defmacro qcdaddr (x) - `(cdr (the cons (car (the cons (cdr (the cons (cdr (the cons ,x))))))))) -(defmacro qcddaar (x) - `(cdr (the cons (cdr (the cons (car (the cons (car (the cons ,x))))))))) -(defmacro qcddadr (x) - `(cdr (the cons (cdr (the cons (car (the cons (cdr (the cons ,x))))))))) -(defmacro qcdddar (x) - `(cdr (the cons (cdr (the cons (cdr (the cons (car (the cons ,x))))))))) -(defmacro qcddddr (x) - `(cdr (the cons (cdr (the cons (cdr (the cons (cdr (the cons ,x))))))))) - -(defmacro qcsize (x) - `(the fixnum (length (the simple-string ,x)))) - -(defmacro qeqq (pattern exp) - `(,(ecqexp pattern 1) ,exp)) - -(defmacro qlength (a) - `(length ,a)) - -; (defmacro qmemq (a b) -; `(member ,a ,b :test #'eq)) -(defmacro qmemq (a b) `(memq ,a ,b)) - -(defmacro qrefelt (vec ind) - `(svref ,vec ,ind)) - -(defmacro qrplaca (a b) - `(rplaca (the cons ,a) ,b)) - -(defmacro qrplacd (a b) - `(rplacd (the cons ,a) ,b)) - -(defmacro qrplq (&whole form pattern exp) - (if (or (consp pattern) (simple-vector-p pattern)) - `(,(rcqexp pattern) ,exp) - (macro-invalidargs 'qrplq form "form must be updateable."))) - -(defmacro qsadd1 (x) - `(the fixnum (1+ (the fixnum ,x)))) - -(defmacro qsdec1 (x) - `(the fixnum (1- (the fixnum ,x)))) - -(defmacro qsdifference (x y) - `(the fixnum (- (the fixnum ,x) (the fixnum ,y)))) - -(defmacro qsetq (&whole form pattern exp) - (declare (ignore form)) - `(,(dcqexp pattern '=) ,exp)) - -(defmacro qsetrefv (vec ind val) - `(setf (svref ,vec (the fixnum ,ind)) ,val)) - -(defmacro qsetvelt (vec ind val) - `(setf (svref ,vec (the fixnum ,ind)) ,val)) - -(defmacro qsetvelt-1 (vec ind val) - `(setf (svref ,vec (the fixnum (1- (the fixnum ,ind)))) ,val)) - -(defmacro qsgreaterp (a b) - `(> (the fixnum ,a) (the fixnum ,b))) - -(defmacro qsinc1 (x) - `(the fixnum (1+ (the fixnum ,x)))) - -(defmacro qsleftshift (a b) - `(the fixnum (ash (the fixnum ,a) (the fixnum ,b)))) - -(defmacro qslessp (a b) - `(< (the fixnum ,a) (the fixnum ,b))) - -(defmacro qsmax (x y) - `(the fixnum (max (the fixnum ,x) (the fixnum ,y)))) - -(defmacro qsmin (x y) - `(the fixnum (min (the fixnum ,x) (the fixnum ,y)))) - -(defmacro qsminus (x) - `(the fixnum (minus (the fixnum ,x)))) - -(defmacro qsminusp (x) - `(minusp (the fixnum ,x))) - -(defmacro qsoddp (x) - `(oddp (the fixnum ,x))) - -(defmacro qsabsval (x) - `(the fixnum (abs (the fixnum ,x)))) - -(defmacro qsplus (x y) - `(the fixnum (+ (the fixnum ,x) (the fixnum ,y)))) - -(defmacro qssub1 (x) - `(the fixnum (1- (the fixnum ,x)))) - -(defmacro qstimes (x y) - `(the fixnum (* (the fixnum ,x) (the fixnum ,y)))) - -(defmacro qstringlength (x) - `(the fixnum (length (the simple-string ,x)))) - -(defmacro qszerop (x) - `(zerop (the fixnum ,x))) - -(defmacro qvelt (vec ind) - `(svref ,vec (the fixnum ,ind))) - -(defmacro qvelt-1 (vec ind) - `(svref ,vec (the fixnum (1- (the fixnum ,ind))))) - -(defmacro qvmaxindex (x) - `(the fixnum (1- (the fixnum (length (the simple-vector ,x)))))) - -(defmacro qvsize (x) - `(the fixnum (length (the simple-vector ,x)))) - -; #-:CCL -; (defmacro refvecp (v) -; `(typep ,v '(vector t))) -; #+:CCL -; (defun refvecp (v) (and (vectorp v) (not (stringp v)))) -(defmacro refvecp (v) `(simple-vector-p ,v)) - -(defmacro resetq (a b) - `(prog1 ,a (setq ,a ,b))) - -(defmacro rnump (n) - `(floatp ,n)) - -(defmacro rplq (&whole form exp pattern) - (if (or (consp pattern) (simple-vector-p pattern)) - `(,(rcqexp pattern) ,exp) - (macro-invalidargs 'rplq form "form must be updateable."))) - -(defmacro rvecp (v) - `(typep ,v '(vector float))) - -(defmacro setandfileq (id item) - `(eval-when - #+:common-lisp (:load-toplevel :execute) - #-:common-lisp (eval load) - (setq ,id ,item) - (lam\,fileactq ',id (list 'setq ',id (list 'quote ,id))))) - -#-:CCL -(defmacro setelt (vec ind val) - `(setf (elt ,vec ,ind) ,val)) - -(defmacro setqp (&whole form pattern exp) - (declare (ignore form)) - `(,(dcqexp pattern '=) ,exp)) - -(defmacro seq (&rest form) - (let* ((body (reverse form)) - (val `(return-from seq ,(pop body)))) - (nsubstitute '(progn) nil body) ;don't treat NIL as a label - `(block seq (tagbody ,@(nreverse body) ,val)))) - -(defmacro sfp (x) - `(special-form-p ,x)) - -#-:CCL -(defmacro sintp (n) - `(typep ,n 'fixnum)) -#+:CCL -(defmacro sintp (n) - `(fixp ,n)) - -#-:CCL -(defmacro smintp (n) - `(typep ,n 'fixnum)) -#+:CCL -(defmacro smintp (n) - `(fixp ,n)) - -(defmacro stringlength (x) - `(length (the string ,x))) - -(defmacro subrp (x) - `(compiled-function-p ,x)) - -#-:CCL -(defmacro sub1 (x) - `(1- ,x)) - -(defmacro throw-protect (exp1 exp2) - `(unwind-protect ,exp1 ,exp2)) - -#-:CCL -(defmacro times (&rest args) - `(* ,@args)) - -(defmacro vec-setelt (vec ind val) - `(setf (svref ,vec ,ind) ,val)) - -; #-:CCL -; (defmacro vecp (v) -; `(typep ,v '(vector t))) -; #+:CCL -; (defun vecp (v) (and (vectorp v) (not (stringp v)))) -(defmacro vecp (v) `(simple-vector-p ,v)) - -#-:CCL -(defmacro zero? (x) - `(and (typep ,x 'fixnum) (zerop (the fixnum ,x)))) -#+:CCL -(defmacro zero? (x) `(zerop ,x)) - -;; defuns - -(eval-when - #+:common-lisp (:compile-toplevel :load-toplevel :execute) - #-:common-lisp (compile load eval) - (defun define-function (f v) - (setf (symbol-function f) v))) - -(define-function 'tempus-fugit #'get-internal-run-time) - -(defun $TOTAL-ELAPSED-TIME () - (list (get-internal-run-time) (get-internal-real-time))) - -#-(OR IBCL KCL :CMULISP :CCL) -(defun $TOTAL-GC-TIME () (list 0 0)) - -#+:CCL -(defun $TOTAL-GC-TIME () (list (gctime) (gctime))) - -#+IBCL -(defun $TOTAL-GC-TIME (&aux (gcruntime (system:gbc-time-report))) - (list gcruntime gcruntime)) - -#+KCL -(defun $TOTAL-GC-TIME (&aux (gcruntime (system:gbc-time))) - (if (minusp gcruntime) - (setq gcruntime (system:gbc-time 0))) - (list gcruntime gcruntime)) - -;;; note: this requires the 11/9/89 gc patch in code/lisp/daly/misc.lisp -#+:cmulisp -(defun $TOTAL-GC-TIME () - (declare (special ext::*gc-runtime* ext::*gc-walltime*)) - (list ext::*gc-runtime* ext::*gc-walltime*)) - -; 7.0 Macros - -; 7.2 Creating Macro Expressions - -; 5.2 Functions - -; 5.2.2 Lambda Expressions - -(defun *LAM (body) - (cond ((NOT (ISQUOTEDP (first BODY))) (cons 'LAMBDA BODY)) - ((LET* ((BV (DEQUOTE (first BODY))) - (CONTROL (QUOTESOF (first BODY))) - (BODY (cdr BODY)) - (ARGS (GENSYM)) - (INNER-FUNC (or *lam-name* (gentemp)))) - (COMP370 (LIST INNER-FUNC `(LAMBDA ,BV . ,BODY))) - `(MLAMBDA ,ARGS - (CONS (QUOTE ,INNER-FUNC) - (WRAP (cdr ,ARGS) ',CONTROL))))))) - -(defun WRAP (LIST-OF-ITEMS WRAPPER) - (prog nil - (COND ((OR (NOT (PAIRP LIST-OF-ITEMS)) (not WRAPPER)) - (RETURN LIST-OF-ITEMS)) - ((NOT (consp WRAPPER)) - (SETQ WRAPPER (LOTSOF WRAPPER)))) - (RETURN - (CONS (if (first WRAPPER) - `(,(first WRAPPER) ,(first LIST-OF-ITEMS)) - (first LIST-OF-ITEMS)) - (WRAP (cdr LIST-OF-ITEMS) (cdr WRAPPER)))))) - -(defun ISQUOTEDP (bv) - (COND ((NOT (consp BV)) NIL) - ((EQ (first BV) 'QUOTE)) - ((AND (consp (first BV)) (EQ (QCAAR BV) 'QUOTE))) - ((ISQUOTEDP (cdr BV))))) - -(defun QUOTESOF (BV) - (COND ((NOT (consp BV)) NIL) - ((EQ (first BV) 'QUOTE) 'QUOTE) - ((CONS (COND ((NOT (consp (first BV))) nil) - ((EQ (QCAAR BV) 'QUOTE) 'QUOTE) - (T NIL)) - (QUOTESOF (cdr BV)))))) - -(defun DEQUOTE (BV) - (COND ((NOT (consp BV)) BV) - ((EQ 'QUOTE (first BV)) (second BV)) - ((CONS (if (EQ 'QUOTE (IFCAR (CAR BV))) (CADAR BV) (first BV)) - (DEQUOTE (cdr BV)))))) - -(defun lotsof (&rest items) - (setq items (copy-list items)) - (nconc items items)) - -; 7.4 Using Macros - -; Beats me how to simulate macro expansion "in the environment of sd"...: - -(defun MDEF (arg item &optional sd) - (declare (ignore sd)) - (macroexpand `(,arg ,item))) - -(define-function 'MDEFX #'MDEF) - -; 8.0 Operator Definition and Transformation - -; 8.1 Definition and Transformation Operations - -(defun COMP370 (fnlist) - (cond ((atom (car fnlist)) (list (COMPILE1 fnlist))) - (t (MAPCAR #'(lambda (x) (COMPILE1 x)) fnlist)))) - -#+:CCL (proclaim '(special *vars* *decl*)) ;; declare not handled right - -(defun COMPILE1 (fn) - (let* (nargs - (fname (car fn)) - (lamda (cadr fn)) - (ltype (car lamda)) - *vars* *decl* args - (body (cddr lamda))) - (declare (special *vars* *decl*)) - (if (eq ltype 'LAM) - (let ((*lam-name* (intern (concat fname "\,LAM")))) - (setq lamda (eval lamda) ltype (car lamda) body (cddr lamda)))) - (let ((dectest (car body))) - (if (and (eqcar dectest 'declare) (eqcar (cadr dectest) 'special)) - (setq *decl* (cdr (cadr dectest)) body (cdr body)))) - (setq args (remove-fluids (cadr lamda))) - (cond ((and (eq ltype 'lambda) (simple-arglist args)) (setq nargs args)) - (t (setq nargs (gensym)) - #+LispM (setq body `((dsetq ,args (copy-list ,nargs)) ,@body)) - #-LispM (setq body `((dsetq ,args ,nargs) ,@body)) - (cond ((eq ltype 'lambda) (setq nargs `(&rest ,nargs &aux ,@*vars*))) - ((eq ltype 'mlambda) - (setq nargs `(&whole ,nargs &rest ,(gensym) &aux ,@*vars*))) - (t (error "bad function type"))))) - (cond (*decl* (setq body (cons `(declare (special ,@ *decl*)) body)))) - (setq body - (cond ((eq ltype 'lambda) `(defun ,fname ,nargs . ,body)) - ((eq ltype 'mlambda) `(defmacro ,fname ,nargs . ,body)))) - (if *COMP370-APPLY* (funcall *COMP370-APPLY* fname body)) - - body)) - -(defun simple-arglist (arglist) - (or (null arglist) - (and (consp arglist) (null (cdr (last arglist))) - (every #'symbolp arglist)))) - -(defun remove-fluids (arglist &aux f v) ;updates specials *decl* and *vars* - (declare (special *decl* *vars*)) - (cond ((null arglist) arglist) - ((symbolp arglist) (push arglist *vars*) arglist) - ;if atom but not symbol, ignore value - ((atom arglist) (push (setq arglist (gentemp)) *vars*) arglist) - ((and (setq f (car arglist)) - (eq f 'fluid) - (listp (cdr arglist)) - (setq v (cadr arglist)) - (identp v) - (null (cddr arglist))) - (push v *decl*) - (push v *vars*) - v) - (t (cons (remove-fluids (car arglist)) - (remove-fluids (cdr arglist)))))) - -(define-function 'KOMPILE #'COMP370) - -; 9.4 Vectors and Bpis - -(defun IVECP (x) (and (vectorp x) (subtypep (array-element-type x) 'integer))) - -(defun mbpip (item) (and (symbolp item) ;cannot know a compiled macro in CLISP - (compiled-function-p (macro-function item)))) - -(defun FBPIP (item) (or (compiled-function-p item) - (and (symbolp item) (fboundp item) - (not (macro-function item)) - (compiled-function-p (symbol-function item))))) - -; 9.5 Identifiers - -#-:CCL -(defun gensymp (x) (and (symbolp x) (null (symbol-package x)))) - -(defun digitp (x) - (or (and (symbolp x) (digitp (symbol-name x))) - (and (characterp x) (digit-char-p x)) - (and (stringp x) (= (length x) 1) (digit-char-p (char x 0))))) - -(defun dig2fix (x) - (if (symbolp x) - (digit-char-p (char (symbol-name x) 0)) - (digit-char-p x))) - -#-:CCL -(defun LN (x) (LOG x)) -#-:CCL -(defun LOG2 (x) (LOG x 2.0)) -(defun |log| (x) (LOG x 10.0)) - -; 9.13 Streams - -#+Lucid -(defun IS-CONSOLE (stream) - (and (streamp stream) - (or (not (consp (pathname-directory stream))) - (equal (qcar (pathname-directory stream)) "dev") - (null (pathname-name stream) )))) - -#+KCL -(defun IS-CONSOLE (stream) - (and (streamp stream) (output-stream-p stream) - (eq (system:fp-output-stream stream) - (system:fp-output-stream *terminal-io*)))) - -#-(OR Lucid KCL :CCL) -(defun IS-CONSOLE (stream) (EQ stream *terminal-io*)) - -; 10.0 Control Structures - -; 10.8.4 Auxiliary Operators - -(defun nilfn (&rest ignore) - (declare (ignore ignore)) - ()) - -; 11.0 Operations on Identifiers - -; 11.1 Creation - -(defun upcase (l) - (cond ((stringp l) (string-upcase l)) - ((identp l) (intern (string-upcase (symbol-name l)))) - ((characterp l) (char-upcase l)) - ((atom l) l) - (t (mapcar #'upcase l)))) - -(define-function 'U-CASE #'upcase) -(define-function 'LC2UC #'upcase) - -(defun downcase (l) - (cond ((stringp l) (string-downcase l)) - ((identp l) (intern (string-downcase (symbol-name l)))) - ((characterp l) (char-downcase L)) - ((atom l) l) - (t (mapcar #'downcase l)))) - -(define-function 'L-CASE #'downcase) - -; 11.2 Accessing - -;; note it is important that PNAME returns nil not an error for non-symbols -(defun pname (x) - (cond ((symbolp x) (symbol-name x)) - ((characterp x) (string x)) - (t nil))) - -;; property lists in vmlisp are alists -(defun PROPLIST (x) - (if (symbolp x) -#-:CCL - (plist2alist (symbol-plist x)) -#+:CCL - (plist2alist (plist x)) - nil)) - -(defun plist2alist (x) - (if (null x) - nil - (cons (cons (first x) (second x)) (plist2alist (cddr x))))) - -(eval-when - #+:common-lisp (:compile-toplevel :load-toplevel :execute) - #-:common-lisp (compile load eval) - (progn - (defun put (sym ind val) (setf (get sym ind) val)) - - (define-function 'MAKEPROP #'put))) - -; 12.0 Operations on Numbers - -; 12.1 Conversion - -(define-function 'FIX #'truncate) -(define-function 'INT2RNUM #'float) - -; 12.2 Predicates - -;(define-function 'lessp #'<) - -;(define-function 'greaterp #'>) - - -;(define-function 'fixp #'integerp) - -; 12.3 Computation - -;(define-function 'add1 #'1+) -;(define-function 'sub1 #'1-) -;(define-function 'plus #'+) -;(define-function 'times #'*) -;(define-function 'difference #'-) -;(define-function 'minus #'-) -;(define-function 'absval #'abs) - -(defun QUOTIENT (x y) - (cond ((or (floatp x) (floatp y)) (/ x y)) - (t (truncate x y)))) - -(define-function 'vm/ #'quotient) - -#-:CCL -(defun REMAINDER (x y) - (if (and (integerp x) (integerp y)) - (rem x y) - (- x (* y (QUOTIENT x y))))) - -#-:CCL -(defun DIVIDE (x y) - (if (and (integerp x) (integerp y)) - (multiple-value-list (truncate x y)) - (list (QUOTIENT x y) (REMAINDER x y)))) - -(defun QSQUOTIENT (a b) (the fixnum (truncate (the fixnum a) (the fixnum b)))) - -(defun QSREMAINDER (a b) (the fixnum (rem (the fixnum a) (the fixnum b)))) - - -;(defun IFCAR (x) (if (consp x) (car (the cons x)))) - -;(defun IFCDR (x) (if (consp x) (cdr (the cons x)))) - -; 13.3 Updating - - -(defun RPLPAIR (pair1 pair2) - (RPLACA pair1 (CAR pair2)) - (RPLACD pair1 (CDR pair2)) pair1) - -(defun RPLNODE (pair1 ca2 cd2) - (RPLACA pair1 ca2) - (RPLACD pair1 cd2) pair1) - -; 14.0 Operations on Lists - -; 14.1 Creation - -(defun VEC2LIST (vec) (coerce vec 'list)) - -; note default test for union, intersection and set-difference is eql -;; following are defined so as to preserve ordering in union.lisp -;;(defun SETDIFFERENCE (l1 l2) (set-difference l1 l2 :test #'equalp)) -;;(defun SETDIFFERENCEQ (l1 l2) (set-difference l1 l2 :test #'eq)) -;;(defun |union| (l1 l2) (union l1 l2 :test #'equalp)) -;;(defun UNIONQ (l1 l2) (union l1 l2 :test #'eq)) -;;(defun |intersection| (l1 l2) (intersection l1 l2 :test #'equalp)) -;;(defun INTERSECTIONQ (l1 l2) (intersection l1 l2 :test #'eq)) -(defun |member| (item sequence) - (cond ((symbolp item) (member item sequence :test #'eq)) - ((stringp item) (member item sequence :test #'equal)) - ((and (atom item) (not (arrayp item))) (member item sequence)) - (T (member item sequence :test #'equalp)))) - -(defun |remove| (list item &optional (count 1)) - (if (integerp count) - (remove item list :count count :test #'equalp) - (remove item list :test #'equalp))) - -(defun REMOVEQ (list item &optional (count 1)) - (if (integerp count) - (remove item list :count count :test #'eq) - (remove item list :test #'eq))) - -; 14.2 Accessing - -;(define-function 'lastnode #'last) -;(define-function 'lastpair #'last) -(defun |last| (x) (car (lastpair x))) - -; 14.3 Searching - -#+:CCL (DEFMACRO |assoc| (X Y) `(ASSOC** ,X ,Y)) -#-:CCL -(DEFUN |assoc| (X Y) - "Return the pair associated with key X in association list Y." - ; ignores non-nil list terminators - ; ignores non-pair a-list entries - (cond ((symbolp X) - (PROG NIL - A (COND ((ATOM Y) (RETURN NIL)) - ((NOT (consp (CAR Y))) ) - ((EQ (CAAR Y) X) (RETURN (CAR Y))) ) - (SETQ Y (CDR Y)) - (GO A))) - ((or (numberp x) (characterp x)) - (PROG NIL - A (COND ((ATOM Y) (RETURN NIL)) - ((NOT (consp (CAR Y))) ) - ((EQL (CAAR Y) X) (RETURN (CAR Y))) ) - (SETQ Y (CDR Y)) - (GO A))) - (t - (PROG NIL - A (COND ((ATOM Y) (RETURN NIL)) - ((NOT (consp (CAR Y))) ) - ((EQUAL (CAAR Y) X) (RETURN (CAR Y))) ) - (SETQ Y (CDR Y)) - (GO A))))) -; 14.5 Updating - -(defun NREMOVE (list item &optional (count 1)) - (if (integerp count) - (delete item list :count count :test #'equal) - (delete item list :test #'equal))) - -(defun NREMOVEQ (list item &optional (count 1)) - (if (integerp count) - (delete item list :count count ) - (delete item list ))) - -(defun EFFACE (item list) (delete item list :count 1 :test #'equal)) - -(defun NCONC2 (x y) (NCONC x y)) ;NCONC with exactly two arguments - -; 14.6 Miscellaneous - -(defun QSORT (l) - (declare (special sortgreaterp)) - (NREVERSE (sort (copy-seq l) SORTGREATERP))) - -(defun SORTBY (keyfn l) - (declare (special sortgreaterp)) - (nreverse (sort (copy-seq l) SORTGREATERP :key keyfn))) - -; 16.0 Operations on Vectors - -; 16.1 Creation - -(defun MAKE-VEC (n) (make-array n)) - -(define-function 'GETREFV #'make-array) - -@ -Waldek Hebisch points out that, in the expression: -\begin{verbatim} - reduce(+,[1.0/i for i in 1..20000]) -\end{verbatim} -a significant amount of the time is spent in this function. -A special case was added to significantly reduce the execution time. -This was a problem in GCL as of 2.6.8pre and may be fixed in future -releases. If it is fixed then the original definition, which was -\begin{verbatim} -(defun LIST2VEC (list) (coerce list 'vector)) -\end{verbatim} -can be restored. -<<*>>= -(defun LIST2VEC (list) - (if (consp list) - (let* ((len (length list)) - (vec (make-array len))) - (dotimes (i len) - (setf (aref vec i) (pop list))) - vec) - (coerce list 'vector))) - -(define-function 'LIST2REFVEC #'LIST2VEC) - -; 16.2 Accessing - - -;(define-function 'FETCHCHAR #'char) - -;; Oddly, LENGTH is more efficient than LIST-LENGTH in CCL, since the former -;; is compiled and the latter is byte-coded! -(defun size (l) - (cond ((vectorp l) (length l)) -#+:CCL ((stringp l) (length l)) ;; Until ACN fixes his lisp -> C translator. -#-:CCL ((consp l) (list-length l)) -#+:CCL ((consp l) (length l)) - (t 0))) - -(define-function 'MOVEVEC #'replace) - -; 17.0 Operations on Character and Bit Vectors - -(defun charp (a) (or (characterp a) - (and (identp a) (= (length (symbol-name a)) 1)))) - -(defun NUM2CHAR (n) (code-char n)) - -(defun CHAR2NUM (c) (char-code (character c))) - -(defun CGREATERP (s1 s2) (string> (string s1) (string s2))) - -(define-function 'STRGREATERP #'CGREATERP) - -; 17.1 Creation - - -#-AKCL -(defun concat (a b &rest l) - (let ((type (cond ((bit-vector-p a) 'bit-vector) (t 'string)))) - (cond ((eq type 'string) - (setq a (string a) b (string b)) - (if l (setq l (mapcar #'string l))))) - (if l (apply #'concatenate type a b l) - (concatenate type a b))) ) -#+AKCL -(defun concat (a b &rest l) - (if (bit-vector-p a) - (if l (apply #'concatenate 'bit-vector a b l) - (concatenate 'bit-vector a b)) - (if l (apply #'system:string-concatenate a b l) - (system:string-concatenate a b)))) - -(define-function 'strconc #'concat) - -(defun make-cvec (sint) (make-array sint :fill-pointer 0 :element-type 'character)) - -;(define-function 'CVECP #'stringp) - -(define-function 'getstr #'make-cvec) - -(defun make-full-cvec (sint &optional (char #\space)) - (make-string sint :initial-element (character char))) - -(define-function 'getfullstr #'make-full-cvec) - -; 17.2 Accessing - -(defun QENUM (cvec ind) (char-code (char cvec ind))) - -(defun QESET (cvec ind charnum) - (setf (char cvec ind) (code-char charnum))) - -(defun string2id-n (cvec sint) - (if (< sint 1) - nil - (let ((start (position-if-not #'(lambda (x) (char= x #\Space)) cvec))) - (if start - (let ((end (or (position #\Space cvec :start start) (length cvec)))) - (if (= sint 1) - (intern (subseq cvec start end)) - (string2id-n (subseq cvec end) (1- sint)))) - 0)))) - -(defun substring (cvec start length) - (setq cvec (string cvec)) - (if length (subseq cvec start (+ start length)) (subseq cvec start))) - -; 17.3 Searching - -;;- (defun strpos (what in start dontcare) -;;- (setq what (string what) in (string in)) -;;- (if dontcare (progn (setq dontcare (character dontcare)) -;;- (search what in :start2 start -;;- :test #'(lambda (x y) (or (eql x dontcare) -;;- (eql x y))))) -;;- (search what in :start2 start))) - -(defun strpos (what in start dontcare) - (setq what (string what) in (string in)) - (if dontcare (progn (setq dontcare (character dontcare)) - (search what in :start2 start - :test #'(lambda (x y) (or (eql x dontcare) - (eql x y))))) - (if (= start 0) - (search what in) - (search what in :start2 start)) - )) - -; In the following, table should be a string: - -(defun strposl (table cvec sint item) - (setq cvec (string cvec)) - (if (not item) - (position table cvec :test #'(lambda (x y) (position y x)) :start sint) - (position table cvec :test-not #'(lambda (x y) (position y x)) :start sint))) - -; 17.4 Updating operators - -(defun suffix (id cvec) - "Suffixes the first char of the symbol or char ID to the string CVEC, - changing CVEC." - (unless (characterp id) (setq id (elt (string id) 0))) - (cond ((array-has-fill-pointer-p cvec) - (vector-push-extend id cvec) - cvec) - ((adjustable-array-p cvec) - (let ((l (length cvec))) - (adjust-array cvec (1+ l)) - (setf (elt cvec l) id) - cvec)) - (t (concat cvec id)))) - -(defun setsize (vector size) (adjust-array vector size)) - -(define-function 'changelength #'setsize) - -(defun trimstring (x) x) - -;;-- (defun rplacstr (cvec1 start1 length1 cvec2 -;;-- &optional (start2 0) (length2 nil) -;;-- &aux end1 end2) -;;-- (setq cvec2 (string cvec2)) -;;-- (if (null start1) (setq start1 0)) -;;-- (if (null start2) (setq start2 0)) -;;-- (if (null length1) (setq length1 (- (length cvec1) start1))) -;;-- (if (null length2) (setq length2 (- (length cvec2) start2))) -;;-- (if (numberp length1) (setq end1 (+ start1 length1))) -;;-- (if (numberp length2) (setq end2 (+ start2 length2))) -;;-- (if (/= length1 length2) -;;-- (concatenate 'string (subseq cvec1 0 start1) -;;-- (subseq cvec2 start2 end2) -;;-- (subseq cvec1 end1)) -;;-- (replace cvec1 cvec2 :start1 start1 :end1 end1 -;;-- :start2 start2 :end2 end2))) - -; The following version has been provided to avoid reliance on the -; Common Lisp concatenate and replace functions. These built-in Lisp -; functions would probably end up doing the character-by-character -; copying shown here, but would also need to cope with generic sorts -; of sequences and unwarranted keyword generality - -(defun rplacstr (cvec1 start1 length1 cvec2 - &optional start2 length2 - &aux end1 end2) - (setq cvec2 (string cvec2)) - (if (null start1) (setq start1 0)) - (if (null start2) (setq start2 0)) - (if (null length1) (setq length1 (- (length cvec1) start1))) - (if (null length2) (setq length2 (- (length cvec2) start2))) - (setq end1 (+ start1 length1)) - (setq end2 (+ start2 length2)) - (if (= length1 length2) - (do () - ((= start1 end1) cvec1) - (setf (aref cvec1 start1) (aref cvec2 start2)) - (setq start1 (1+ start1)) - (setq start2 (1+ start2))) - (let* ((l1 (length cvec1)) - (r (make-string (- (+ l1 length2) length1))) - (i 0)) - (do ((j 0 (1+ j))) - ((= j start1)) - (setf (aref r i) (aref cvec1 j)) - (setq i (1+ i))) - (do ((j start2 (1+ j))) - ((= j end2)) - (setf (aref r i) (aref cvec2 j)) - (setq i (1+ i))) - (do ((j end1 (1+ j))) - ((= j l1)) - (setf (aref r i) (aref cvec1 j)) - (setq i (1+ i))) - r) - )) - -; 19.0 Operations on Arbitrary Objects - -; 19.1 Creating - -(defun MSUBST (new old tree) (subst new old tree :test #'equal)) -; note subst isn't guaranteed to copy -(defun |nsubst| (new old tree) (nsubst new old tree :test #'equal)) -(define-function 'MSUBSTQ #'subst) ;default test is eql -(define-function 'SUBSTQ #'SUBST) ;default test is eql subst is not guaranteed to copy - -(defun copy (x) (copy-tree x)) ; not right since should descend vectors - -(defun eqsubstlist (new old list) (sublis (mapcar #'cons old new) list)) - -; Gen code for SETQP expr - -(eval-when - #+:common-lisp (:compile-toplevel :load-toplevel :execute) - #-:common-lisp (compile load eval) - (defun DCQEXP (FORM EQTAG) - (PROG (SV pvl avl CODE) - (declare (special pvl avl)) - (setq SV (GENSYM)) - (setq CODE (DCQGENEXP SV FORM EQTAG NIL)) - (RETURN - `(LAMBDA (,sv) - (PROG ,pvl - ,@code - (RETURN 'true) - BAD (RETURN NIL) ) )))) -) -; Generate Expr code for DCQ -(eval-when - #+:common-lisp (:compile-toplevel :load-toplevel :execute) - #-:common-lisp (compile load eval) - (defun DCQGENEXP (SV FORM EQTAG QFLAG) - (PROG (D A I L C W) - (declare (special pvl avl)) - (COND ((EQ FORM SV) (RETURN NIL)) - ((IDENTP FORM) (RETURN `((setq ,form ,sv)) )) - ((simple-vector-p FORM) - (RETURN (SEQ - (setq L (length FORM)) - (IF (EQ L 0) - (RETURN (COND ((NULL QFLAG) - `((cond ((not (simple-vector-p ,sv)) (go bad)))))))) - (setq I (1- L)) - LP (setq A (elt FORM I)) - (COND ((AND (NULL W) (OR (consp A) (simple-vector-p A))) - (COND ((consp AVL) (setq W (car (RESETQ AVL (cdr AVL))))) - ((setq PVL (CONS (setq W (GENSYM)) PVL)))))) - (setq C (NCONC (COND ((IDENTP A) `((setq ,a (ELT ,sv ,i)))) - ((OR (consp A) (simple-vector-p A)) - `((setq ,w (ELT ,sv ,i)) - ,@(dcqgenexp w a eqtag qflag)))) - C)) - (if (EQ I 0) (GO RET)) - (setq I (1- I)) - (GO LP) - RET (if W (setq AVL (CONS W AVL))) - (COND ((NULL QFLAG) - `((COND ((OR (NOT (simple-vector-p ,sv)) (< (length ,sv) ,l)) - (GO BAD))) - ,@c)) - ('T C))))) - ((NOT (consp FORM)) (RETURN NIL)) - ((AND EQTAG (EQ (car FORM) EQTAG)) - (RETURN - (COND - ((OR (NOT (EQ 3 (LENGTH FORM))) (NOT (IDENTP (car (setq FORM (cdr FORM)))))) - (MACRO-INVALIDARGS 'DCQ\/QDCQ FORM (MAKESTRING "invalid pattern."))) - (`((setq ,(car form) ,sv) ,@(DCQGENEXP SV (CADR FORM) EQTAG QFLAG))))))) - (setq A (car FORM)) - (setq D (cdr FORM)) - (setq C (COND ((IDENTP A) `((setq ,a (CAR ,sv)))) - ((OR (consp A) (simple-vector-p A)) - (COND ((AND (NULL D) (IDENTP SV)) ) - ((COND ((consp AVL) (setq W (car (RESETQ AVL (cdr AVL))))) - ((setq PVL (CONS (setq W (GENSYM)) PVL)) ) ) ) ) - (COND ((AND (consp A) EQTAG (EQ (car A) EQTAG)) - (DCQGENEXP (LIST 'CAR SV) A EQTAG QFLAG) ) - (`((setq ,(or w sv) (CAR ,sv)) - ,@(DCQGENEXP (OR W SV) A EQTAG QFLAG))))))) - (setq C (NCONC C (COND ((IDENTP D) `((setq ,d (CDR ,sv)))) - ((OR (consp D) (simple-vector-p D)) - (COND - ((OR W (IDENTP SV)) ) - ((COND ((consp AVL) - (setq W (car (RESETQ AVL (cdr AVL)))) ) - ((setq PVL (CONS (setq W (GENSYM)) PVL)) ) ) ) ) - (COND ((AND (consp D) EQTAG (EQ (car D) EQTAG)) - (DCQGENEXP (LIST 'CDR SV) D EQTAG QFLAG) ) - (`((setq ,(or w sv) (CDR ,sv)) - ,@(DCQGENEXP (OR W SV) D EQTAG QFLAG)))))))) - (COND (W (setq AVL (CONS W AVL)))) - (RETURN (COND ((NULL QFLAG) `((COND ((ATOM ,sv) (GO BAD))) ,@c)) (C))))) -) - - -; 19.3 Searching - -; Generate code for EQQ - -(eval-when - #+:common-lisp (:compile-toplevel :load-toplevel :execute) - #-:common-lisp (compile load eval) - (defun ECQEXP (FORM QFLAG) - (PROG (SV PVL CODE) - (declare (special pvl)) - (setq SV (GENSYM)) - (setq CODE (ECQGENEXP SV FORM QFLAG)) - (RETURN - `(LAMBDA (,sv) - (PROG ,pvl - ,@code - (RETURN 'true) - BAD (RETURN NIL) ) )))) -) - -; Generate code for EQQ innards - -(eval-when - #+:common-lisp (:compile-toplevel :load-toplevel :execute) - #-:common-lisp (compile load eval) - (defun ECQGENEXP (SV FORM QFLAG) - (PROG (D A I L C W) - (declare (special pvl)) - (COND - ((EQ FORM SV) (RETURN NIL)) - ((OR - (IDENTP FORM) - (NUMP FORM) - (AND (consp FORM) (EQ (qcar FORM) 'QUOTE))) - (RETURN - `((COND ((NOT (EQ ,form ,sv)) (GO BAD))) ))) - ((simple-vector-p FORM) - (RETURN (SEQ - (setq L (length FORM)) - (if (EQ L 0) - (RETURN - (COND ((NULL QFLAG) - `((COND ((NOT (simple-vector-p ,sv)) (GO BAD))) ))) - )) - (setq I (1- L)) - LP (setq A (elt FORM I)) - (if (AND (NULL W) (OR (consp A) (simple-vector-p A))) - (push (setq W (GENSYM)) PVL)) - (setq C - (NCONC - (COND - ( (OR - (IDENTP A) - (NUMP A) - (AND (consp A) (EQ (qcar A) 'QUOTE))) - `((COND ( (NOT (EQ ,a (ELT ,sv ,i))) - (GO BAD) ) ) ) ) - ( (OR (consp A) (simple-vector-p A)) - `((setq ,w (ELT ,sv ,i)) - ,@(ECQGENEXP W A QFLAG)))) - C) ) - (if (EQ I 0) (GO RET) ) - (setq I (1- I)) - (GO LP) - RET - (COND - ( (NULL QFLAG) - `((COND ( (OR - (NOT (simple-vector-p ,sv)) - (< (length ,sv) ,l)) - (GO BAD) ) ) - ,@c)) - ( 'T C ) )) )) - ( (NOT (consp FORM)) - (RETURN NIL) ) ) - (setq A (car FORM)) - (setq D (cdr FORM)) - (if (OR (consp A) (simple-vector-p A) (consp D) (simple-vector-p D)) - (setq PVL (CONS (setq W (GENSYM)) PVL))) - (setq C - (COND - ( (OR (IDENTP A) (NUMP A) (AND (consp A) (EQ (car A) 'QUOTE))) - `((COND ((NOT (EQ ,a (CAR ,sv))) (GO BAD))) )) - ( (OR (consp A) (simple-vector-p A)) - `((setq ,w (CAR ,sv)) - ,@(ECQGENEXP W A QFLAG))))) - (setq C - (NCONC - C - (COND - ( (OR (IDENTP D) (NUMP D) (AND (consp D) - (EQ (car D) 'QUOTE))) - `((COND ((NOT (EQ ,d (CDR ,sv))) (GO BAD))) )) - ( (OR (consp D) (simple-vector-p D)) - `((setq ,sv (CDR ,sv)) - ,@(ECQGENEXP SV D QFLAG)))))) - (RETURN - (COND - ( (NULL QFLAG) - `((COND ( (ATOM ,sv) - (GO BAD) ) ) - ,@c)) - ( 'T - C ) )) ) ) -) - -; 19.4 Updating - -; Generate code for RPLQ exprs - -(eval-when - #+:common-lisp (:compile-toplevel :load-toplevel :execute) - #-:common-lisp (compile load eval) - (defun RCQEXP (FORM) - (PROG (SV PVL CODE) - (declare (special pvl)) - (setq SV (GENSYM)) - (setq CODE (RCQGENEXP SV FORM NIL)) - (RETURN - `(LAMBDA (,sv) - (PROG ,pvl - ,@code - (RETURN 'true) - BAD (RETURN NIL) ) )))) -) - -; Generate code for RPLQ expr innards - -(eval-when - #+:common-lisp (:compile-toplevel :load-toplevel :execute) - #-:common-lisp (compile load eval) - (defun RCQGENEXP (SV FORM QFLAG) - (PROG (D A I L C W) - (declare (special pvl)) - (COND - ( (EQ FORM SV) - (RETURN NIL) ) - ( (simple-vector-p FORM) - (RETURN (SEQ - (setq L (length FORM)) - (if (EQ L 0) (RETURN NIL)) - (setq I (1- L)) - LP (setq A (elt FORM I)) - (COND - ( (AND - (NULL W) - (OR (AND (consp A) (NOT (EQ (car A) 'QUOTE))) - (simple-vector-p A))) - (setq PVL (CONS (setq W (GENSYM)) PVL)) ) ) - (setq C - (NCONC - (COND - ( (OR - (IDENTP A) - (NUMP A) - (AND (consp A) (EQ (car A) 'QUOTE))) - `((SETELT ,sv ,i ,a))) - ( (OR (consp A) (simple-vector-p A)) - `((setq ,w (ELT ,sv ,i)) - ,@(RCQGENEXP W A QFLAG)))) - C) ) - (COND - ( (EQ I 0) - (GO RET) ) ) - (setq I (1- I)) - (GO LP) - RET (RETURN - (COND - ( (NULL QFLAG) - `((COND ( (OR - (NOT (simple-vector-p ,sv)) - (< (length ,sv) ,l)) - (GO BAD) ) ) - ,@c)) - ( 'T - C ) )) ))) - ( (NOT (consp FORM)) - (RETURN NIL) ) ) - (setq A (car FORM)) - (setq D (cdr FORM)) - (cond - ( (or (and (consp A) (NOT (EQ (car A) 'QUOTE))) (simple-vector-p A)) - (setq PVL (CONS (setq W (GENSYM)) PVL)) ) ) - (setq C - (COND - ( (OR (IDENTP A) (NUMP A) (AND (consp A) (EQ (car A) 'QUOTE))) - `((rplaca ,sv ,a))) - ( (OR (consp A) (simple-vector-p A)) - `((setq ,w (CAR ,sv)) - ,@(RCQGENEXP W A QFLAG))))) - (setq C - (NCONC - C - (COND - ( (OR (IDENTP D) (NUMP D) (AND (consp D) (EQ (car D) 'QUOTE))) - `((RPLACD ,sv ,d))) - ( (OR (consp D) (simple-vector-p D)) - `((setq ,sv (CDR ,sv)) - ,@(RCQGENEXP SV D QFLAG)))))) - (RETURN - (COND - ( (NULL QFLAG) - `((COND ( (ATOM ,sv) - (GO BAD) ) ) - ,@c)) - ( 'T - C ) )) ) ) -) - -; 22.0 Internal and External Forms - -; 23.0 Reading - - -(define-function 'next #'read-char) - -; 24.0 Printing - -<> -(define-function 'printexp #'princ) -(define-function 'prin0 #'prin1) - -(defun |F,PRINT-ONE| (form &optional (stream *standard-output*)) - (declare (ignore stream)) - (let ((*print-level* 4) (*print-length* 4)) - (prin1 form) (terpri))) - -(defun prettyprint (x &optional (stream *standard-output*)) - (prettyprin0 x stream) (terpri stream)) - -(defun prettyprin0 (x &optional (stream *standard-output*)) - (let ((*print-pretty* t) (*print-array* t)) - (prin1 x stream))) - -(defun vmprint (x &optional (stream *standard-output*)) - (prin1 x stream) (terpri stream)) - -(defun tab (sint &optional (stream t)) - (format stream "~vT" sint)) - -; 27.0 Stream I/O - - -; 27.1 Creation - -(defun MAKE-INSTREAM (filespec &optional (recnum 0)) - (declare (ignore recnum)) - (cond ((numberp filespec) (make-synonym-stream '*terminal-io*)) - ((null filespec) (error "not handled yet")) - (t (open (make-input-filename filespec) - :direction :input :if-does-not-exist nil)))) - -(defun MAKE-OUTSTREAM (filespec &optional (width nil) (recnum 0)) - (declare (ignore width) (ignore recnum)) - (cond ((numberp filespec) (make-synonym-stream '*terminal-io*)) - ((null filespec) (error "not handled yet")) - (t (open (make-filename filespec) :direction :output)))) - -(defun MAKE-APPENDSTREAM (filespec &optional (width nil) (recnum 0)) - "fortran support" - (declare (ignore width) (ignore recnum)) - (cond - ((numberp filespec) (make-synonym-stream '*terminal-io*)) - ((null filespec) (error "make-appendstream: not handled yet")) - ('else (open (make-filename filespec) :direction :output - :if-exists :append :if-does-not-exist :create)))) - -(defun DEFIOSTREAM (stream-alist buffer-size char-position) - (declare (ignore buffer-size)) - (let ((mode (or (cdr (assoc 'MODE stream-alist)) 'INPUT)) - (filename (cdr (assoc 'FILE stream-alist))) - (dev (cdr (assoc 'DEVICE stream-alist)))) - (if (EQ dev 'CONSOLE) (make-synonym-stream '*terminal-io*) - (let ((strm (case mode - ((OUTPUT O) (open (make-filename filename) - :direction :output)) - ((INPUT I) (open (make-input-filename filename) - :direction :input))))) - (if (and (numberp char-position) (> char-position 0)) - (file-position strm char-position)) - strm)))) - -(defun shut (st) (if (is-console st) st - (if (streamp st) (close st) -1))) - -(defun EOFP (stream) (null (peek-char nil stream nil nil))) - -; 28.0 Key addressed I/O - - -; 46.0 Call tracing - - -(defun EMBEDDED () (mapcar #'car *embedded-functions*)) - -(defun EMBED (CURRENT-BINDING NEW-DEFINITION) - (PROG -#+:CCL (OP BV BODY OLD-DEF *COMP) -#-:CCL (OP BV BODY OLD-DEF) - (COND - ( (NOT (IDENTP CURRENT-BINDING)) - (SETQ CURRENT-BINDING - (error (format nil "invalid argument ~s to EMBED" CURRENT-BINDING))) ) ) - (SETQ OLD-DEF (symbol-function CURRENT-BINDING)) - (SETQ NEW-DEFINITION - (SETF (symbol-function CURRENT-BINDING) - (COND - ( (NOT (consp NEW-DEFINITION)) - NEW-DEFINITION ) - ( (AND - (DCQ (OP BV . BODY) NEW-DEFINITION) - (OR (EQ OP 'LAMBDA) (EQ OP 'MLAMBDA))) - (COND - ( (NOT (MEMQ CURRENT-BINDING (FLAT-BV-LIST BV))) - `(,OP ,BV ((LAMBDA (,CURRENT-BINDING) . ,BODY) ',OLD-DEF)) - ) - ( 'T - NEW-DEFINITION ) ) ) - ( 'T - `((LAMBDA (,CURRENT-BINDING) ,NEW-DEFINITION) ',OLD-DEF))) - ) ) -#+:CCL (IF (CONSP NEW-DEFINITION) (SETQ NEW-DEFINITION (CDR NEW-DEFINITION))) - (push (LIST CURRENT-BINDING NEW-DEFINITION OLD-DEF) *embedded-functions*) - (RETURN CURRENT-BINDING) ) ) - -(defun UNEMBED (CURRENT-BINDING) - (PROG -#+:CCL (TMP E-LIST CUR-DEF *COMP) -#-:CCL (TMP E-LIST CUR-DEF) - (SETQ E-LIST *embedded-functions*) - (SETQ CUR-DEF (symbol-function CURRENT-BINDING)) -#+:CCL (IF (CONSP CUR-DEF) (SETQ CUR-DEF (CDR CUR-DEF))) - (COND - ( (NOT (consp E-LIST)) - NIL ) - ( (ECQ ((CURRENT-BINDING CUR-DEF)) E-LIST) - (SETF (symbol-function CURRENT-BINDING) (QCADDAR E-LIST)) - (SETQ *embedded-functions* (QCDR E-LIST)) - (RETURN CURRENT-BINDING) ) - ( 'T - (SEQ - (SETQ TMP E-LIST) - LP (COND - ( (NOT (consp (QCDR TMP))) - (EXIT NIL) ) - ( (NULL (ECQ ((CURRENT-BINDING CUR-DEF)) (QCDR TMP))) - (SETQ TMP (QCDR TMP)) - (GO LP) ) - ( 'T - (SETF (symbol-function CURRENT-BINDING) (QCAR (QCDDADR TMP))) - (RPLACD TMP (QCDDR TMP)) - (RETURN CURRENT-BINDING) ) ) ) ) ) - (RETURN NIL) )) - -(defun FLAT-BV-LIST (BV-LIST) - (PROG (TMP1) - (RETURN - (COND - ( (VARP BV-LIST) - (LIST BV-LIST) ) - ( (REFVECP BV-LIST) - (FLAT-BV-LIST (VEC2LIST (MAPELT #'FLAT-BV-LIST BV-LIST))) ) - ( (NOT (consp BV-LIST)) - NIL ) - ( (EQ '= (SETQ TMP1 (QCAR BV-LIST))) - (FLAT-BV-LIST (QCDR BV-LIST)) ) - ( (VARP TMP1) - (CONS TMP1 (FLAT-BV-LIST (QCDR BV-LIST))) ) - ( (AND (NOT (consp TMP1)) (NOT (REFVECP TMP1))) - (FLAT-BV-LIST (QCDR BV-LIST)) ) - ( 'T - (NCONC (FLAT-BV-LIST TMP1) (FLAT-BV-LIST (QCDR BV-LIST))) ) )) )) - -(defun VARP (TEST-ITEM) - (COND - ( (IDENTP TEST-ITEM) - TEST-ITEM ) - ( (AND - (consp TEST-ITEM) - (OR (EQ (QCAR TEST-ITEM) 'FLUID) (EQ (QCAR TEST-ITEM) 'LEX)) - (consp (QCDR TEST-ITEM)) - (IDENTP (QCADR TEST-ITEM))) - TEST-ITEM ) - ( 'T - NIL ) ) ) - -; 48.0 Miscellaneous CMS Interactions - -(defun CurrentTime () - (multiple-value-bind (sec min hour day month year) (get-decoded-time) - (format nil "~2,'0D/~2,'0D/~2,'0D~2,'0D:~2,'0D:~2,'0D" - month day (rem year 100) hour min sec))) - -(defun $screensize () '(24 80)) ; You tell me!! - -; 97.0 Stuff In The Manual But Wierdly Documented - -(defun EBCDIC (x) (code-char x)) - -;; This isn't really compatible but is as close as you can get in common lisp -;; In place of ((one-of 1 2 3) l) you should use -;; (funcall (one-of 1 2 3) l) - -(defun doDSETQ (form pattern exp) - (let (PVL AVL) - (declare (special PVL AVL)) - (COND ((IDENTP PATTERN) - (LIST 'SETQ PATTERN EXP)) - ((AND (NOT (consp PATTERN)) (NOT (simple-vector-p PATTERN))) - (MACRO-INVALIDARGS 'DSETQ FORM "constant target.")) - ((let* ((SV (GENSYM)) - (E-PART (DCQGENEXP (LIST 'IDENTITY SV) PATTERN '= NIL))) - (setq e-part - `(LAMBDA (,sv) - (PROG ,pvl - ,@e-part - (RETURN ,sv) - BAD (RETURN (SETQERROR ,sv))))) - `(,e-part ,exp)))))) - -(defun SETQERROR (&rest FORM) (error (format nil "in destructuring ~S" FORM))) - - - - -(defun MACRO-INVALIDARGS (NAME FORM MESSAGE) - (setq MACERRORCOUNT (+ 1 (eval 'MACERRORCOUNT))) - (error (format nil - "invalid arguments to macro ~S with invalid argument ~S, ~S" - name form message))) - -(defun MACRO-MISSINGARGS (NAME ignore N) - (declare (ignore ignore)) - (setq MACERRORCOUNT (+ 1 (eval 'MACERRORCOUNT))) - (let ((nargs (abs N))) - (error (concatenate 'string (symbol-name NAME) " requires " - (if (minusp N) "at least " "exactly ") - (case nargs (0 "no") (1 "one") (2 "two") (3 "three") - (4 "four") (5 "five") (6 "six") - (t (princ-to-string nargs))) - (if (eq nargs 1) " argument," " arguments,"))))) - -(defun MACERR (MESSAGE &rest ignore) - (declare (ignore ignore)) - (setq MACERRORCOUNT (+ 1 (eval 'MACERRORCOUNT))) - (error - (LIST "in the expression:" MESSAGE)) - ()) - -#+Lucid -(defun numberofargs (x) - (setq x (system::arglist x)) - (let ((nx (- (length x) (length (memq '&aux x))))) - (if (memq '&rest x) (setq nx (- (1- nx)))) - (if (memq '&optional x) (setq nx (- (1- (abs nx))))) - nx)) - -; 98.0 Stuff Not In The VMLisp Manual That We Like - -; A version of GET that works with lists - -;; GETL(SYM, KEY) -;; KEY: a SYMBOL -;; SYM: a SYMBOL or a LIST whose elements are SYMBOLs or LISTs. -;; Returns: -;; when SYM is a SYMBOL, returns the KEY-property of SYM. -;; when SYM is a LIST, returns the either the KEY-property of the -;; first SYMBOL of SYM that has the KEY-property, or the CDR of the -;; first cons-cell whose CAR is EQ KEY. -(defun getl (sym key) - (cond ((symbolp sym) - (get sym key)) - ((null sym) nil) - ((consp sym) - (let ((sym-1 (car sym))) - (cond ((symbolp sym-1) - (get sym-1 key)) - ((and (consp sym-1) - (symbolp (car sym-1))) - (if (eq (car sym-1) key) - (cdr sym-1) - (getl (cdr sym) key)))))))) - -; The following should actually position the cursor at the sint'th line of the screen: - -(defun $showline (cvec sint) (terpri) sint (princ cvec)) - -; 99.0 Ancient Stuff We Decided To Keep - -(defun LAM\,EVALANDFILEACTQ (name &optional (form name)) - (LAM\,FILEACTQ name form) (eval form)) - -(defun LAM\,FILEACTQ (name form) - (if *FILEACTQ-APPLY* (FUNCALL *FILEACTQ-APPLY* name form))) - -(defun CALLBELOW (&rest junk) junk) ; to invoke system dependent code? - -(define-function 'EVA1 #'eval) ;EVA1 and VMLISP EVAL make lexicals visible -(define-function 'EVALFUN #'eval) ;EVALFUN drops lexicals before evaluating -(define-function 'EVA1FUN #'EVALFUN) - -(defun PLACEP (item) (eq item *read-place-holder*)) -(defun VMREAD (&optional (st *standard-input*) (eofval *read-place-holder*)) - (read st nil eofval)) -(defun |read-line| (st &optional (eofval *read-place-holder*)) - (read-line st nil eofval)) - -(defun STATEP (item) - (declare (ignore item)) - nil) ;no state objects -(defun FUNARGP (item) - (declare (ignore item)) - nil) ;can't tell closures from other functions -(defun PAPPP (item) - (declare (ignore item)) - nil) ;no partial application objects - -#+Lucid -(defun gcmsg (x) - (prog1 (not system::*gc-silence*) (setq system::*gc-silence* (not x)))) -#+(OR IBCL KCL) -(defun gcmsg (x) - (prog1 system:*gbc-message* (setq system:*gbc-message* x))) -#+:cmulisp -(defun gcmsg (x) - (prog1 ext:*gc-verbose* (setq ext:*gc-verbose* x))) -#+:allegro -(defun gcmsg (x)) - -#+Lucid -(defun reclaim () (system:gc)) -#+:cmulisp -(defun reclaim () (ext:gc)) -#+(OR IBCL KCL) -(defun reclaim () (gbc t)) -#+:allegro -(defun reclaim () (excl::gc t)) -#+:CCL -(defun reclaim () (gc)) - -#+Lucid -(defun BPINAME (func) - (if (functionp func) - (if (symbolp func) func - (let ((name (svref func 0))) - (if (and (consp name) (eq (car name) 'SYSTEM::NAMED-LAMBDA)) - (cadr name) - name)) ))) - -#+(OR IBCL KCL) -(defun BPINAME (func) - (if (functionp func) - (cond ((symbolp func) func) - ((and (consp func) (eq (car func) 'LAMBDA-BLOCK)) - (cadr func)) - ((compiled-function-p func) - (system:compiled-function-name func)) - ('t func)))) -#+:cmulisp -(defun BPINAME (func) - (when (functionp func) - (cond - ((symbolp func) func) - ((and (consp func) (eq (car func) 'lambda)) (second (third func))) - ((compiled-function-p func) - (system::%primitive header-ref func system::%function-name-slot)) - ('else func)))) -#+:allegro -(defun bpiname (func) - func) -#+:CCL -(defun bpiname (x) - (if (symbolp x) - (intern (symbol-name (symbol-function x)) "BOOT") - nil)) - -#+:SBCL -(defun BPINAME (x) - (multiple-value-bind (l c n) - (function-lambda-expression x) - (declare (ignore l c)) - n)) - -(defun LISTOFQUOTES (bpi) - (declare (ignore bpi)) - ()) - -#+Lucid -(defun LISTOFFREES (bpi) - (if (compiled-function-p bpi) - (let ((end (- (lucid::procedure-length bpi) 2))) - (do ((i 3 (1+ i)) - (ans nil)) - ((> i end) ans) - (let ((locexp (svref bpi i))) - (if (symbolp locexp) (push locexp ans))))))) - -#-Lucid -(defun LISTOFFREES (bpi) - (declare (ignore bpi)) - ()) - - -#+(and :Lucid (not :ibm/370)) -(defun OBEY (S) - (system::run-aix-program (make-absolute-filename "/lib/obey") - :arguments (list "-c" S))) -#+:cmulisp -(defun OBEY (S) - (ext:run-program (make-absolute-filename "/lib/obey") - (list "-c" S) :input t :output t)) -#+(OR IBCL KCL :CCL) -(defun OBEY (S) (SYSTEM S)) - -#+:allegro -(defun OBEY (S) (excl::run-shell-command s)) - -(defun RE-ENABLE-INT (number-of-handler) number-of-handler) - - -(defun QUOREM (i j r) ; never used, refed in parini.boot - (multiple-value-bind (x y) (truncate i j) - (rplaca (the cons r) x) (rplacd (the cons r) y))) - -(defun MAKE-BVEC (n) - (make-array (list n) :element-type 'bit :initial-element 0)) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} -- cgit v1.2.3