aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2011-03-16 16:39:22 +0000
committerdos-reis <gdr@axiomatics.org>2011-03-16 16:39:22 +0000
commit3156d86ff1d99c2d5291f057bd3a4cb710756472 (patch)
tree2733201d18adb1fd2054e59ccd0aa6b0e5b5cc94
parent11eebf207528f86dfa4556be3b2cc7cba57244a6 (diff)
downloadopen-axiom-3156d86ff1d99c2d5291f057bd3a4cb710756472.tar.gz
* interp/i-syscmd.boot (compileSpad2Cmd): Remove experimental
support for Spad to Aldor translation. (convertSpasToAsFile): Remove. * interp/mark.boot: Remove. * interp/nspadux.lisp: Likewise. * interp/pspad1.boot: Likewise. * interp/pspad2.boot: Likewise. * interp/wi1.boot: Likewise. * interp/wi2.boot: Likewise. * interp/spad.lisp: Don't register removed formatters. * interp/util.lisp: (TRANSLATE-FUNCTIONS): Remove. (BUILD-INTERPSYS): Now take only one argument. * src/share/doc/msgs/s2-us.msgs: Remove diagnostic S2IZ0085. * interp/Makefile.in: Remove rules for building wi1.boot, wi2.boot, mark.boot, pspad1.boot pspad2.boot.
Diffstat
-rw-r--r--src/ChangeLog18
-rw-r--r--src/interp/Makefile.in19
-rw-r--r--src/interp/i-syscmd.boot39
-rw-r--r--src/interp/mark.boot1543
-rw-r--r--src/interp/nspadaux.lisp119
-rw-r--r--src/interp/pspad1.boot745
-rw-r--r--src/interp/pspad2.boot663
-rw-r--r--src/interp/spad.lisp18
-rw-r--r--src/interp/util.lisp11
-rw-r--r--src/interp/wi1.boot1250
-rw-r--r--src/interp/wi2.boot1132
-rw-r--r--src/share/doc/msgs/s2-us.msgs5
12 files changed, 23 insertions, 5539 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index ac99608e..5ab6497f 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,21 @@
+2011-03-16 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * interp/i-syscmd.boot (compileSpad2Cmd): Remove experimental
+ support for Spad to Aldor translation.
+ (convertSpasToAsFile): Remove.
+ * interp/mark.boot: Remove.
+ * interp/nspadux.lisp: Likewise.
+ * interp/pspad1.boot: Likewise.
+ * interp/pspad2.boot: Likewise.
+ * interp/wi1.boot: Likewise.
+ * interp/wi2.boot: Likewise.
+ * interp/spad.lisp: Don't register removed formatters.
+ * interp/util.lisp: (TRANSLATE-FUNCTIONS): Remove.
+ (BUILD-INTERPSYS): Now take only one argument.
+ * src/share/doc/msgs/s2-us.msgs: Remove diagnostic S2IZ0085.
+ * interp/Makefile.in: Remove rules for building wi1.boot,
+ wi2.boot, mark.boot, pspad1.boot pspad2.boot.
+
2011-03-12 Gabriel Dos Reis <gdr@cs.tamu.edu>
* src/algebra/: Systematically use not zero? when comparing for
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index c751e8d3..8ee22543 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -155,13 +155,6 @@ BROBJS= bc-matrix.$(FASLEXT) \
autoload_objects += $(BFOBJS)
-# Translator from `old Spad' to `new spad (Aldor)' code.
-# FIXME: is this still relevant?
-TRANOBJS= ${AUTO}/wi1.$(FASLEXT) ${AUTO}/wi2.$(FASLEXT) ${AUTO}/pspad1.$(FASLEXT) \
- ${AUTO}/pspad2.$(FASLEXT) ${AUTO}/mark.$(FASLEXT) ${AUTO}/nspadaux.$(FASLEXT)
-
-autoload_objects += $(TRANOBJS)
-
ASCOMP= as.$(FASLEXT) axext_l.$(FASLEXT)
ASAUTO= ${AUTO}/ax.$(FASLEXT)
@@ -231,7 +224,7 @@ makeint.lisp: Makefile
@ echo '(in-package "BOOT")' >> makeint.lisp
@ touch ${TIMESTAMP}
@ echo '${YEARWEEK}' >> makeint.lisp
- @ echo '(unless (or |$$StandardLinking| (|%basicSystemIsComplete|)) (build-interpsys (quote ($(patsubst %, "%", ${TRANOBJS}))) (quote ($(patsubst %, "%", ${ASAUTO}))))(|clearClams|))' >> makeint.lisp
+ @ echo '(unless (or |$$StandardLinking| (|%basicSystemIsComplete|)) (build-interpsys (quote ($(patsubst %, "%", ${ASAUTO}))))(|clearClams|))' >> makeint.lisp
@ echo '#+:akcl (setq compiler::*suppress-compiler-notes* t)' >> makeint.lisp
@ echo '#+:akcl (si::gbc-time 0)' >> makeint.lisp
@ echo '#+:GCL (si::gbc t)' >> makeint.lisp
@@ -239,7 +232,7 @@ makeint.lisp: Makefile
${SAVESYS}: database.date \
$(axiom_targetdir)/algebra/exposed.$(FASLEXT) \
$(axiom_target_datadir)/msgs/s2-us.msgs \
- $(ASAUTO) $(TRANOBJS) $(OBJS) makeint.$(LNKEXT)
+ $(ASAUTO) $(OBJS) makeint.$(LNKEXT)
$(DRIVER) --execpath=$(BOOTSYS) \
--syslib=$(axiom_target_libdir) \
--system="$(AXIOM)/" --system-algebra \
@@ -256,7 +249,7 @@ all-axiomsys: ${AXIOMSYS}
${AXIOMSYS}: database.date \
$(axiom_targetdir)/algebra/exposed.$(FASLEXT) \
$(axiom_target_datadir)/msgs/s2-us.msgs \
- $(ASAUTO) $(TRANOBJS) $(OBJS) makeint.$(LNKEXT)
+ $(ASAUTO) $(OBJS) makeint.$(LNKEXT)
$(DRIVER) --execpath=$(BOOTSYS) \
--syslib=$(axiom_target_libdir) \
--system="$(AXIOM)/" \
@@ -344,8 +337,6 @@ record.$(FASLEXT): nlib.$(FASLEXT) pathname.$(FASLEXT)
setvart.$(FASLEXT): macros.$(FASLEXT)
## OpenAxiom's compiler
-wi2.$(FASLEXT): macros.$(FASLEXT) define.$(FASLEXT)
-wi1.$(FASLEXT): macros.$(FASLEXT)
compiler.$(FASLEXT): msgdb.$(FASLEXT) pathname.$(FASLEXT) define.$(FASLEXT)
nrunfast.$(FASLEXT): c-util.$(FASLEXT)
nruncomp.$(FASLEXT): profile.$(FASLEXT) simpbool.$(FASLEXT) functor.$(FASLEXT)
@@ -386,7 +377,6 @@ server.$(FASLEXT): macros.$(FASLEXT)
## The old parser component roughtly is:
##
spad-parser.$(FASLEXT): parse.$(FASLEXT)
-mark.$(FASLEXT): macros.$(FASLEXT)
parse.$(FASLEXT): metalex.$(FASLEXT) postpar.$(FASLEXT)
packtran.$(FASLEXT): sys-macros.$(FASLEXT)
postpar.$(FASLEXT): macros.$(FASLEXT)
@@ -430,7 +420,6 @@ debug.$(FASLEXT): macros.$(FASLEXT) parsing.$(FASLEXT)
spad.$(FASLEXT): bootlex.$(FASLEXT) postpar.$(FASLEXT) debug.$(FASLEXT)
monitor.$(FASLEXT): macros.$(FASLEXT)
property.$(FASLEXT): sys-macros.$(FASLEXT)
-nspadaux.$(FASLEXT): sys-macros.$(FASLEXT)
sfsfun-l.$(FASLEXT): sys-macros.$(FASLEXT)
trace.$(FASLEXT): debug.$(FASLEXT)
termrw.$(FASLEXT): macros.$(FASLEXT)
@@ -447,8 +436,6 @@ g-error.$(FASLEXT): diagnostics.$(FASLEXT) g-util.$(FASLEXT)
c-util.$(FASLEXT): g-opt.$(FASLEXT)
pathname.$(FASLEXT): nlib.$(FASLEXT)
hashcode.$(FASLEXT): g-util.$(FASLEXT)
-pspad2.$(FASLEXT): pspad1.$(FASLEXT)
-pspad1.$(FASLEXT): macros.$(FASLEXT)
g-util.$(FASLEXT): ggreater.$(FASLEXT) macros.$(FASLEXT) sys-utility.$(FASLEXT)
g-cndata.$(FASLEXT): sys-macros.$(FASLEXT)
msg.$(FASLEXT): sys-macros.$(FASLEXT) astr.$(FASLEXT)
diff --git a/src/interp/i-syscmd.boot b/src/interp/i-syscmd.boot
index b3afc62a..527dc5ae 100644
--- a/src/interp/i-syscmd.boot
+++ b/src/interp/i-syscmd.boot
@@ -783,8 +783,6 @@ compileSpad2Cmd args ==
report
)
- translateOldToNew := nil
-
$scanIfTrue : local := false
$compileOnlyCertainItems : local := nil
$f : local := nil -- compiler
@@ -803,7 +801,6 @@ compileSpad2Cmd args ==
fullopt = 'new => error "Internal error: compileSpad2Cmd got )new"
fullopt = 'old => NIL -- no opt
- fullopt = 'translate => translateOldToNew := true
fullopt = 'library => fun.1 := 'lib
fullopt = 'nolibrary => fun.1 := 'nolib
@@ -836,11 +833,7 @@ compileSpad2Cmd args ==
$InteractiveMode : local := nil
-- avoid Boolean semantics transformations based on syntax only
$normalizeTree: local := false
- if translateOldToNew then
- spad2AsTranslatorAutoloadOnceTrigger()
- sayKeyedMsg("S2IZ0085", nil)
- convertSpadToAsFile path
- else if $compileOnlyCertainItems then
+ if $compileOnlyCertainItems then
null constructor => sayKeyedMsg("S2IZ0040",NIL)
compilerDoitWithScreenedLisplib(constructor, fun)
else
@@ -851,36 +844,6 @@ compileSpad2Cmd args ==
-- reset compiler optimization options
setCompilerOptimizations 0
-convertSpadToAsFile path ==
- -- can assume path has type = .spad
- $globalMacroStack : local := nil -- for spad -> as translator
- $abbreviationStack: local := nil -- for spad -> as translator
- $macrosAlreadyPrinted: local := nil -- for spad -> as translator
- $abbreviationsAlreadyPrinted: local := nil -- for spad -> as translator
- $convertingSpadFile : local := true
- $options: local := '((nolib)) -- translator shouldn't create nrlibs
- SETQ(HT,hashTable 'EQUAL)
-
- newName := fnameMake(pathnameDirectory path, pathnameName path, '"as")
- canDoIt := true
- if not fnameWritable? newName then
- sayKeyedMsg("S2IZ0086", [NAMESTRING newName])
- newName := fnameMake('".", pathnameName path, '"as")
- if not fnameWritable? newName then
- sayKeyedMsg("S2IZ0087", [NAMESTRING newName])
- canDoIt := false
- not canDoIt => 'failure
-
- sayKeyedMsg("S2IZ0088", [NAMESTRING newName])
-
- $outStream :local := MAKE_-OUTSTREAM newName
- markSay('"#include _"axiom.as_"")
- markTerpri()
- CATCH($SpadReaderTag,compiler [path])
- SHUT $outStream
- mkCheck()
- 'done
-
compilerDoit(constructor, fun) ==
$byConstructors : local := []
$constructorsSeen : local := []
diff --git a/src/interp/mark.boot b/src/interp/mark.boot
deleted file mode 100644
index 6915b4d8..00000000
--- a/src/interp/mark.boot
+++ /dev/null
@@ -1,1543 +0,0 @@
--- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
--- All rights reserved.
--- Copyright (C) 2007-2011, 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.
-
-
--- HOW THE TRANSLATOR WORKS
-
--- Unit of code is markedUp as follows (unit= item in a capsule pile, e.g.)
--- (WI/.. a b) means source code a --> markedUpCode b
--- (REPPER/.. . . a) means source code for a ---> (rep a) or (per a)
--- Source code is extracted, modified from markedUpCode, and stacked
--- Entire constructor is then assembled and prettyprinted
-
-
-import macros
-namespace BOOT
-
-REMPROP("and",'parseTran)
-REMPROP("or",'parseTran)
-REMPROP("not",'parseTran)
-property("and",'special) := 'compAnd
-property("or",'special) := 'compOr
-property("not",'special) := 'compNot
-SETQ($monitorWI,nil)
-SETQ($monitorCoerce,nil)
-SETQ($markPrimitiveNumbers,nil) -- '(Integer SmallInteger))
-SETQ($markNumberTypes,'(Integer SmallInteger PositiveInteger NonNegativeInteger))
-
---======================================================================
--- Master Markup Function
---======================================================================
-
-
-WI(a,b) == b
-
-mkWi(fn,:r) ==
--- if $monitorWI and r isnt ['WI,:.] and not (r is ['AUTOSUBSET,p,.,y] and(MEMQ(KAR p,'(NonNegativeInteger PositiveInteger)) or y='_$fromCoerceable_$)) then
--- if $monitorWI and r isnt ['WI,:.] then
--- sayBrightlyNT ['"From ",fn,'": "]
--- pp r
- r is ['WI,a,b] =>
- a = b => a --don't bother
- b is ['WI,=a,.] => b
- r
- r
-
---======================================================================
--- Capsule Function Transformations
---======================================================================
-tcheck T ==
- if T isnt [.,.,.] then systemError 'tcheck
- T
-
-markComp(x,T) == --for comp
- tcheck T
- x ~= first T => [mkWi('comp,'WI,x,first T),:rest T]
- T
-
-markAny(key,x,T) ==
- tcheck T
- x ~= first T => [mkWi(key,'WI,x,first T),:rest T]
- T
-
-markConstruct(x,T) ==
- tcheck T
- markComp(x,T)
-
-markParts(x,T) == --x is ['PART,n,y] --for compNoStacking
- tcheck T
- [mkWi('makeParts,'WI,x,first T),:rest T]
-
-yumyum kind == kind
-markCoerce(T,T',kind) == --for coerce
- tcheck T
- tcheck T'
- if kind = 'AUTOSUBSET then yumyum(kind)
- string? T.mode and T'.mode = '(String) => T'
- markKillAll T.mode = T'.mode => T'
- -- reduce (AUTOSUBSET a b (WI c (AUTOSUBSET b a c))) ==> c
- u :=
- $partExpression is [.,.,y] and T.expr = y => ['WI,y,$partExpression]
- T.expr
- res := [markCoerceChk mkWi('coerce,kind,T.mode,T'.mode,
- mkWi('coerce,'WI,u,T'.expr)),:rest T']
- res
-
-markCoerceChk x ==
- x is ['AUTOSUBSET,a,b,['WI,c,['AUTOSUBSET,=b, =a, =c]]] => c
- x
-
-markMultipleExplicit(nameList, valList, T) ==
- tcheck T
- [mkWi('setqMultipleExplicit, 'WI,
- ["%LET", ["%Comma",:nameList], ["%Comma",:valList]],
- T.expr), :rest T]
-
-markRetract(x,T) ==
- tcheck T
- [mkWi('smallIntegerStep,'RETRACT,nil,['REPLACE,['retract,x]],T.expr),:rest T]
-
-markSimpleReduce(x,T) ==
- tcheck T
- [mkWi('compreduce,'LAMBDA, nil, ["REPLACE",x], T.expr), :rest T]
-
-markCompAtom(x,T) == --for compAtom
- tcheck T
- $convert2NewCompiler =>
- [mkWi('compAtom,'ATOM,nil,['REPLACE,[x]],T.expr),:rest T]
- T
-
-markCase(x, tag, T) ==
- tcheck T
- [mkWi('compCase1, 'LAMBDA, nil, ["REPLACE",["case",x,tag]], T.expr),
- :rest T]
-
-markCaseWas(x,T) ==
- tcheck T
- [mkWi('compCase1,'WI,x,T.expr),:rest T]
-
-markAutoWas(x,T) ==
- tcheck T
- [mkWi('autoCoerce,'WI,x,T.expr),:rest T]
-
-markCallCoerce(x,m,T) ==
- tcheck T
- [mkWi('%call,'WI,["::",x,m], T.expr),: rest T]
-
-markCoerceByModemap(x,source,target,T, killColonColon?) ==
- tcheck T
- source is ["Union",:l] and member(target,l) =>
- tag := genCaseTag(target, l, 1) or return nil
- markAutoCoerceDown(x, tag, markAutoWas(x,T), killColonColon?)
- target is ["Union",:l] and member(source,l) =>
- markAutoCoerceUp(x,markAutoWas(x, T))
- [mkWi('markCoerceByModemap,'WI,x,T.expr),:rest T]
-
-markAutoCoerceDown(x,tag,T,killColonColon?) ==
- tcheck T
- patch := ["dot",getSourceWI x,tag]
- if killColonColon? then patch := ["REPLACE",["UNCOERCE",patch]]
- [mkWi('coerceExtraHard,'LAMBDA, nil,patch,T.expr), :rest T]
-
-markAutoCoerceUp(x,T) ==
--- y := getSourceWI x
--- y :=
--- string? y => makeSymbol y
--- y
- tcheck T
- [mkWi('coerceExtraHard,'LAMBDA, nil,["REPLACE",['construct, "##1"]],T.expr),
- -----want to capture by ##1 what is there ------11/2/94
- :rest T]
-
-markCompSymbol(x,T) == --for compSymbol
- tcheck T
- [mkWi('compSymbol,'ATOM,nil,['REPLACE,["@",x,$Symbol]],T.expr),:rest T]
-
-markStepSI(ostep,nstep) == --for compIterator
- ['STEP,:r] := ostep
- ['ISTEP,i,:s] := nstep
---$localLoopVariables := insert(i,$localLoopVariables)
- markImport 'SmallInteger
- mkWi('markStepSI,'WI,ostep,['ISTEP,
- mkWi('markStep,'FREESI,nil,['REPLACE, ['PAREN,['free,i]]],i),:s])
--- i],i),:s])
-markStep(i) == mkWi('markStep,'FREE,nil,['REPLACE, ['PAREN,['free,i]]],i)
--- i],i)
-
-markPretend(T,T') ==
- tcheck T
- tcheck T'
- [mkWi('pretend,'COLON,"pretend",T.mode,T.expr),:rest T']
-
-markAt(T) ==
- tcheck T
- [mkWi('compAtom,'COLON,"@",T.mode,T.expr),:rest T]
-
-markCompColonInside(op,T) == --for compColonInside
- tcheck T
- $convert2NewCompiler =>
- [mkWi('compColonInside,'COLON,op,T.mode,T.expr),:rest T]
- T
-
-markLisp(T,m) == --for compForm1
- tcheck T
- $convert2NewCompiler =>
- [mkWi('compForm1,'COLON,'Lisp,T.mode,T.expr),:rest T]
- T
-
-markLambda(vl,body,mode,T) == --for compWithMappingMode
- tcheck T
- if mode isnt ['Mapping,:ml] then error '"markLambda"
- args := [[":",$PerCentVariableList.i,t] for i in 0.. for t in rest ml]
- left := [":",['PAREN,:args],first ml]
- fun := ['_+_-_>,left,SUBLISLIS($PerCentVariableList,vl,body)]
- [mkWi('compWithMappingMode,'LAMBDA,nil,['REPLACE,fun],T.expr),:rest T]
-
-markMacro(before,after) == --for compMacro
- $convert2NewCompiler =>
- if before is [x] then before := x
- $def := ['MDEF,before,'(NIL),'(NIL),after]
- if $insideFunctorIfTrue
- then $localMacroStack := [[before,:after],:$localMacroStack]
- else $globalMacroStack:= [[before,:after],:$globalMacroStack]
- mkWi('macroExpand,'MI,before,after)
- after
-
-markInValue(y ,e) ==
- y1 := markKillAll y
- [y', m, e] := T := comp(y1, $EmptyMode, e) or return nil
- markImport m
- m = "$" and LASSOC('value,getProplist('Rep,e)) is [a,:.] and
- opOf a in '(List Vector) => [markRepper('rep, y'), 'Rep, e]
- T
-
-markReduceIn(it, pr) == markReduceIterator("in",it,pr)
-markReduceStep(it, pr) == markReduceIterator("step", it, pr)
-markReduceWhile(it, pr) == markReduceIterator("while", it, pr)
-markReduceUntil(it, pr) == markReduceIterator("until", it, pr)
-markReduceSuchthat(it, pr) == markReduceIterator("suchthat", it, pr)
-markReduceIterator(kind, it, pr) == [mkWi(kind, 'WI, it, first pr), :rest pr]
-markReduceBody(body,T) ==
- tcheck T
- [mkWi("reduceBody",'WI,body,first T), :rest T]
-markReduce(form, T) ==
- tcheck T
- [SETQ($funk,mkWi("reduce", 'WI,form,first T)), :rest T]
-
-markRepeatBody(body,T) ==
- tcheck T
- [mkWi("repeatBody",'WI,body,first T), :rest T]
-
-markRepeat(form, T) ==
- tcheck T
- [mkWi("repeat", 'WI,form,first T), :rest T]
-
-markTran(form,form',[dc,:sig],env) == --from compElt/compFormWithModemap
- dc ~= 'Rep or not ('_$ in sig) => mkWi('markTran,'WI,form,['%call,:form'])
- argl := [u for t in rest sig for arg in rest form'] where u() ==
- t='_$ =>
- argSource := getSourceWI arg
- IDENTP argSource and getmode(argSource,env) = 'Rep => arg
- markRepper('rep,arg)
- arg
- form' := ['%call,first form',:argl]
- wi := mkWi('markTran,'WI,form,form')
- first sig = '_$ => markRepper('per,wi)
- wi
-
-markRepper(key,form) == ['REPPER,nil,key,form]
-
-markDeclaredImport d == markImport(d,true)
-
-markImport(d,:option) == --from compFormWithModemap/genDeltaEntry/compImport
- if CONTAINED('PART,d) then pause d
- declared? := IFCAR option
- null d or d = $Representation => nil
- d is [op,:.] and op in '(Boolean Mapping Void Segment UniversalSegment) => nil
- string? d or (IDENTP d and stringchar(symbolName d,0) = char '_#) => nil
- d in '(_$ _$NoValueMode _$EmptyMode Void) => nil
--------=======+> WHY DOESN'T THIS WORK????????????
---if (d' := macroExpand(d,$e)) ~= d then markImport(d',declared?)
- dom := markMacroTran d
---if IDENTP dom and dom = d and not getmode(dom,$e) then dom := ['MyENUM, d]
- categoryForm? dom => nil
- $insideCapsuleFunctionIfTrue =>
- $localImportStack := insert(dom,$localImportStack)
- if IFCAR option then $localDeclareStack := insert(dom,$localDeclareStack)
- if $globalImportStack then
- $globalImportStack := insert(dom,$globalImportStack)
- if IFCAR option then $globalDeclareStack := insert(dom,$globalDeclareStack)
-
-markMacroTran name == --called by markImport
- atom name => name
- u := or/[x for [x,:y] in $globalMacroStack | y = name] => u
- u := or/[x for [x,:y] in $localMacroStack | y = name] => u
- [op,:argl] := name
- op in '(Record Union) =>
--- pp ['"Cannot find: ",name]
- name
- [op,:[markMacroTran x for x in argl]]
-
-markSetq(originalLet,T) == --for compSetq
- $convert2NewCompiler =>
- $coerceList : local := nil
- ["%LET",form,originalBody] := originalLet
- id := markLhs form
- not $insideCapsuleFunctionIfTrue =>
- $from : local := '"Setq"
- code := T.expr
- markEncodeChanges(code,nil)
- noriginalLet := markSpliceInChanges originalBody
- if IDENTP id then $domainLevelVariableList := insert(id,$domainLevelVariableList)
- nlet := ["%LET",id,noriginalLet]
- entry := [originalLet,:nlet]
- $importStack := [nil,:$importStack]
- $freeStack := [nil,:$freeStack]
- capsuleStack('"Setq", entry)
--- [markKillMI T.expr,:rest T]
- [code,:rest T]
- if MEMQ(id,$domainLevelVariableList) then
- $markFreeStack := insert(id,$markFreeStack)
- T
- T
-
-markCapsuleExpression(originalExpr, T) ==
- $coerceList: local := nil
- $from: local := '"Capsule expression"
- code := T.expr
- markEncodeChanges(code, nil)
- noriginal := markSpliceInChanges originalExpr
- nexpr := noriginal
- entry := [originalExpr,:nexpr]
- $importStack := [nil,:$importStack]
- $freeStack := [nil,:$freeStack]
- capsuleStack('"capsuleExpression", entry)
- [code,:rest T]
-
-markLhs x ==
- x is [":",a,.] => a
- atom x => x
- x --ignore
-
-capsuleStack(name,entry) ==
--- if $monitorWI then
--- sayBrightlyNT ['"Stacking ",name,'": "]
--- pp entry
- $capsuleStack := [COPY entry,:$capsuleStack]
- $predicateStack := [$predl, :$predicateStack]
- signature :=
- $insideCapsuleFunctionIfTrue => $signatureOfForm
- nil
- $signatureStack := [signature, :$signatureStack]
-
-foobar(x) == x
-
-foobum(x) == x --from doIT
-
-
---======================================================================
--- Capsule Function Transformations
---======================================================================
---called from compDefineCapsuleFunction
-markChanges(originalDef,T,sig) ==
- $convert2NewCompiler =>
- if $insideCategoryIfTrue and $insideFunctorIfTrue then
- originalDef := markCatsub(originalDef)
- T := [markCatsub(T.expr),
- markCatsub(T.mode),T.env]
- sig := markCatsub(sig)
- $importStack := markCatsub($importStack)
--- T := coerce(T,first sig) ---> needed to wrap a "per" around a Rep type
- code := T.expr
- $e : local := T.env
- $coerceList : local := nil
- $hoho := code
- ['DEF,form,.,.,originalBody] := originalDef
- signature := markFindOriginalSignature(form,sig)
- $from : local := '"compDefineFunctor1"
- markEncodeChanges(code,nil)
- frees :=
- null $markFreeStack => nil
- [['free,:mySort removeDuplicates $markFreeStack]]
- noriginalBody := markSpliceInChanges originalBody
- nbody := augmentBodyByLoopDecls noriginalBody
- ndef := ['DEF,form,signature,[nil for x in form],nbody]
- $freeStack := [frees,:$freeStack]
- --------------------> import code <------------------
- imports := $localImportStack
- subtractions := union($localDeclareStack,union($globalDeclareStack,
- union($globalImportStack,signature)))
- if $insideCategoryIfTrue and $insideFunctorIfTrue then
- imports := markCatsub imports
- subtractions := markCatsub subtractions
- imports := [markMacroTran d for d in imports]
- subtractions := [markMacroTran d for d in subtractions]
- subtractions := union(subtractions, getImpliedImports imports)
- $importStack := [reduceImports SETDIFFERENCE(imports,subtractions),:$importStack]
- -------------------> import code <------------------
- entry := [originalDef,:ndef]
- capsuleStack('"Def",entry)
- nil
-
-reduceImports x ==
- [k, o] := reduceImports1 x
- SETDIFFERENCE(o,k)
-
-reduceImports1 x ==
- kills := nil
- others:= nil
- for y in x repeat
- y is ['List,a] =>
- [k,o] := reduceImports1 [a]
- kills := union(y,union(k,kills))
- others:= union(o, others)
- rassoc(y,$globalImportDefAlist) => kills := insert(y,kills)
- others := insert(y, others)
- [kills, others]
-
-getImpliedImports x ==
- x is [[op,:r],:y] =>
- op in '(List Enumeration) => union(r, getImpliedImports y)
- getImpliedImports y
- nil
-
-augmentBodyByLoopDecls body ==
- null $localLoopVariables => body
- lhs :=
- $localLoopVariables is [.] => first $localLoopVariables
- ['LISTOF,:$localLoopVariables]
- form := [":",lhs,$SmallInteger]
- body is ['SEQ,:r] => ['SEQ,form,:r]
- ['SEQ,form,['exit,1,body]]
-
-markFindOriginalSignature(form,sig) ==
- target := $originalTarget
- id := opOf form
- n := #form
- cat :=
- target is ['Join,:.,u] => u
- target
- target isnt ['CATEGORY,.,:v] => sig
- or/[sig' for x in v | x is ['SIGNATURE,=id,sig'] and #sig' = n
- and markFindCompare(sig',sig)] or sig
-
-markFindCompare(sig',sig) ==
- macroExpand(sig',$e) = sig
-
---======================================================================
--- Capsule Function: Encode Changes on $coerceList
---======================================================================
---(WI a b) mean Was a Is b
---(WI c (WI d e) b) means Was d Is b
---(AUTOxxx p q (WI a b)) means a::q for reason xxx=SUBSET or HARD
---(ATOM nil (REPLACE (x)) y) means replace y by x
---(COLON :: A B) means rewrite as A :: B (or A @ B or A : B)
---(LAMBDA nil (REPLACE fn) y)means replace y by fn
---(REPPER nil per form) means replace form by per(form)
---(FREESI nil (REPLACE decl) y) means replace y by fn
-
-markEncodeChanges(x,s) ==
---x is a piece of target code
---s is a stack [a, b, ..., c] such that a < b < ...
---calls ..markPath.. to find the location of i in a in c (the orig expression),
--- where i is derived from x (it is the source component of x);
--- if markPath fails to find a path for i in c, then x is wrong!
-
---first time only: put ORIGNAME on property list of operators with a ; in name
- if null s then markOrigName x
- x is [fn,a,b,c] and MEMQ(fn,$markChoices) =>
- x is ['ATOM,.,['REPLACE,[y],:.],:.] and y in '(false true) => 'skip
- ----------------------------------------------------------------------
- if c then ----> special case: DON'T STACK A nil!!!!
- i := getSourceWI c
- t := getTargetWI c
- -- sayBrightly ['"=> ",i,'" ---> "]
- -- sayBrightly ['" from ",a,'" to ",b]
- s := [i,:s]
--- pp '"==========="
--- pp x
- markRecord(a,b,s)
- markEncodeChanges(t,s)
- x is ['WI,p,q] or x is ['MI,p,q] =>
- i := getSourceWI p
- r := getTargetWI q
- r is [fn,a,b,c] and MEMQ(fn,$markChoices) =>
- t := getTargetWI c
--- sayBrightly ['"==> ",i,'" ---> "]
--- sayBrightly ['" from ",a,'" to ",b]
- s := [i,:s]
- markRecord(a,b,s)
- markEncodeChanges(t,s)
- i is [fn,:.] and fn in '(REPEAT COLLECT) => markEncodeLoop(i,r,s)
- t := getTargetWI r
- markEncodeChanges(t,[i,:s])
- x is ['PROGN,a,:.] and s is [[op,:.],:.] and op in '(REPEAT COLLECT) =>
- markEncodeChanges(a,s)
- x is ['TAGGEDreturn,a,[y,:.]] => markEncodeChanges(y,s)
- x is ['CATCH,a,y] => markEncodeChanges(y,s)
- atom x => nil
--- first x = IFCAR IFCAR s =>
--- for y in x for r in first s repeat markEncodeChanges(y,[r,:s])
- for y in x repeat markEncodeChanges(y,s)
-
-markOrigName x ==
- x is [op,:r] =>
- op = 'TAGGEDreturn and x is [.,a,[y,:.]] => markOrigName y
- for y in r repeat markOrigName y
- IDENTP op =>
- s := symbolName op
- k := charPosition(char '_;, s, 0)
- k > MAXINDEX s => nil
- origName := makeSymbol subString(s, k + 1)
- property(op, 'ORIGNAME) := origName
- REMPROP(op,'PNAME)
- markOrigName op
- nil
-
-markEncodeLoop(i, r, s) ==
- [.,:itl1, b1] := i --op is REPEAT or COLLECT
- if r is ["%LET",.,a] then r := a
- r is [op1,:itl2,b2] and op1 in '(REPEAT COLLECT) =>
- for it1 in itl1 for it2 in itl2 repeat markEncodeChanges(it2,[it1,:s])
- markEncodeChanges(b2, [b1,:s])
- markEncodeChanges(r, [i,:s])
-
-getSourceWI x ==
---Subfunction of markEncodeChanges
- x is ['WI,a,b] or x is ['MI,a,b] =>
- a is ['WI,:.] or a is ['MI,:.] => getSourceWI a
- markRemove a
- markRemove x
-
-markRemove x ==
- atom x => x
- x is ['WI,a,b] or x is ['MI,a,b] => markRemove a
- x is [fn,a,b,c] and MEMQ(fn,$markChoices) =>
- markRemove c
---x is ['TAGGEDreturn,:.] => x
- x is ['TAGGEDreturn,a,[x,m,t]] => ['TAGGEDreturn,a,[markRemove x,m,t]]
- [markRemove y for y in x]
-
-getTargetWI x ==
---Subfunction of markEncodeChanges
- x is ['WI,a,b] or x is ['MI,a,b] => getTargetWI b
- x is ['PART,.,a] => getTargetWI a
- x
-
-$shout1 := false
-$shout2 := false
-
-markRecord(source,target,u) ==
---Record changes on $coerceList
- if source='_$ and target='Rep then
- target := 'rep
- if source='Rep and target='_$ then
- target := 'per
- item := first u
- integer? item or item = $One or item = $Zero => nil
- item is ["-",a] and (integer? a or a = $One or a = $Zero) => nil
- string? item => nil
- item is [op,.,t] and op in '( _:_: _@ _pretend)
- and macroExpand(t,$e) = target => nil
- $source: local := source
- $target: local := target
- path := markPath u or return nil -----> early exit
- path :=
- path = 0 => nil --wrap the WHOLE thing
- path
- if $shout2 then
- pp '"========="
- pp path
- ipath := reverse path
- for x in u repeat
- pp x
- ipath =>
- pp first ipath
- ipath := rest ipath
- entry := [source,target,:path]
- if $monitorCoerce then
- sayBrightlyNT ['"From ",$from,'": "]
- pp entry
- $coerceList := [COPY entry,:$coerceList]
-
---======================================================================
--- Capsule Function: Find dewey decimal path across a list
---======================================================================
-markPath u == --u has nested structure: u0 < u1 < u2 ...
- whole := last u
- part := first u
- $path := u
- u is [.] => 0 --means THE WHOLE THING
- v := reverse markPath1 u
--- pp '"======mark path======"
--- foobar v
--- pp v
--- pp markKillAll part
--- pp markKillAll whole
--- pp $source
--- pp $target
- null v => nil
- $pathStack := [[v,:u],:$pathStack]
--- pp '"----------------------------"
--- ppFull v
--- pp '"----------------------------"
- v
-
-markPath1 u ==
--- u is a list [a, b, ... c]
--- This function calls markGetPath(a,b) to find the location of a in b, etc.
--- The result is the successful path from a to c
--- A error printout occurs if no such path can be found
- u is [a,b,:r] => -- a < b < ...
- a = b => markPath1 rest u ---> allow duplicates on path
- path := markGetPath(a,b) or return nil -----> early exit
- if $shout1 then
- pp '"========="
- pp path
- pp a
- pp b
- [:first path,:markPath1 rest u]
- nil
-
-$pathErrorStack := nil
-
-markGetPath(x,y) == -- x < y ---> find its location
- u := markGetPaths(x,y)
- u is [w] => u
- $amb := [u,x,y]
- key :=
- null u => '"no match"
- '"ambiguous"
- sayBrightly ['"-----",key,'"--------"]
- $pathErrorStack := [$path,:$pathErrorStack]
- pp "CAUTION: this can cause RPLAC errors"
- pp "Paths are: "
- pp u
- for p in $path for i in 1..3 repeat pp p
- $x: local := x
- $y: local := y
- pp '"---------------------"
- pp x
- pp y
- foobar key
--- pp [key, $amb]
- null u => [1729] --return something that will surely fail if no path
- [first u]
-
-markTryPaths() == markGetPaths($x,$y)
-
-markPaths(x,y,s) == --x < y; find location s of x in y (initially s=nil)
---NOTES: This location is what it will be in the source program with
--- all PART information removed.
- if $shout then
- pp '"-----"
- pp x
- pp y
- pp s
- x = y => s --found it! exit
- markPathsEqual(x,y) => s
- y is [['elt,.,op],:r] and (u := markPaths(x,[op,:r],s)) => u
- x is ['elt,:r] and (u := markPaths(r,y,s)) => u
- y is ['elt,:r] and (u := markPaths(x,r,s)) => u
- x is [op,:u] and op in '(LIST VECTOR) and y is ['construct,:v] and
- (p := markPaths(['construct,:u],y,s)) => p
- atom y => nil
- y is ["%LET",a,b] and IDENTP a =>
- markPaths(x,b,markCons(2,s)) --and IDENTP x
- y is ["%LET",a,b] and GENSYMP a => markPaths(x,b,s) --for loops
- y is ['IF,a,b,:.] and GENSYMP a => markPaths(x,b,s) --for loops
- y is ['IF,a,b,c] and (p := (markPathsEqual(x,b) => 2;
- markPathsEqual(x,c) => 3;
- nil)) => markCons(p,s)
--- x is ['exit,a,b] and y is ['exit,a,c] and (p := mymy markPathsEqual(b,c)) =>
--- markCons(p,s)
- y is ['%call,:r] => markPaths(x,r,s) --for loops
- y is [fn,m,y1] and fn in '(PART CATCH THROW) => markPaths(x,y1,s) or
- append/[markPaths(x,u,markCons(i,s)) for u in y1 for i in 0..]
- append/[markPaths(x,u,markCons(i,s)) for u in y for i in 0..]
-
-mymy x == x
-
-markCons(i,s) == [[i,:x] for x in s]
-
-markPathsEqual(x,y) ==
- x = y => true
- x is ["::",.,a] and y is ["::",.,b] and
- a = $Integer and b = $NonNegativeInteger => true
- y is [fn,.,z] and fn in '(PART CATCH THROW) and markPathsEqual(x,z) => true
- y is ["%LET",a,b] and GENSYMP a and markPathsEqual(x,b) => true
- y is ['IF,a,b,:.] and GENSYMP a => markPathsEqual(x,b) -------> ???
- y is ['%call,:r] => markPathsEqual(IFCDR x,r)
- x is ['REDUCE,.,.,c,:.] and c is ['COLLECT,:u] and
- y is ['PROGN,.,repeet,:.] and repeet is ['REPEAT,:v] => markPathsEqual(u,v)
- atom y or atom x =>
- IDENTP y and IDENTP x and y = GETL(x,'ORIGNAME) => true --> see
--- IDENTP y and IDENTP x and anySubstring?(symbolName y,symbolName x,0) => true
- IDENTP y and (z := markPathsMacro y) => markPathsEqual(x,z)
- false
- "and"/[markPathsEqual(u,v) for u in x for v in y]
-
-markPathsMacro y ==
- LASSOC(y,$localMacroStack) or LASSOC(y,$globalMacroStack)
---======================================================================
--- Capsule Function: DO the transformations
---======================================================================
---called by markChanges (inside capsule), markSetq (outside capsule)
-$hohum := false
-markSpliceInChanges body ==
--- pp '"before---->"
--- pp $coerceList
- $coerceList := reverse SORTBY('CDDR,$coerceList)
--- pp '"after----->"
--- pp $coerceList
- $cl := $coerceList
---if CONTAINED('REPLACE,$cl) then hoho $cl
- body :=
- body is ['WI,:.] =>
--- hehe body
- markKillAll body
- markKillAll body
---NOTE!! Important that $coerceList be processed in this order
---since it must operate from the inside out. For example, a progression
---u --> u::Rep --> u :: Rep :: $ can only be correct. Here successive
---entries can have duplicate codes
- for [code,target,:loc] in $coerceList repeat
- $data: local := [code, target, loc]
- if $hohum then
- pp '"---------->>>>>"
- pp $data
- pp body
- pp '"-------------------------->"
- body := markInsertNextChange body
- body
-
---pause() == 12
-markInsertNextChange body ==
--- if BOUNDP '$sayChanges and $sayChanges then
--- sayBrightlyNT '"Inserting change: "
--- pp $data
--- pp body
--- pause()
- [code, target, loc] := $data
- markInsertChanges(code,body,target,loc)
-
-markInsertChanges(code,form,t,loc) ==
---RePLACe x at location "loc" in form as follows:
--- t is ['REPLACE,r]: by r
--- t is 'rep/per: by (rep x) or (per x)
--- code is @ : :: by (@ x t) (: x t) (:: x t)
--- code is Lisp by (pretend form t)
--- otherwise by (:: form t)
- loc is [i,:r] =>
- x := form
- for j in 0..(i-1) repeat
- if cons? x then x := rest x
- atom x =>
- pp '"Translator RPLACA error"
- pp $data
- foobum form
- form
- if $hohum then pp [i, '" >>> ", x]
- SETQ($CHANGE,COPY x)
- if x is ['elt,:y] and r then x := y
- x.first := markInsertChanges(code,first x,t,rest loc)
- chk(x,100)
- form
--- pp ['"Making change: ",code,form,t]
- t is ['REPLACE,r] => SUBST(form,"##1",r)
- form is ['SEQ,:y,['exit,1,z]] =>
- ['SEQ,:[markInsertSeq(code,x,t) for x in y],
- ['exit,1,markInsertChanges(code,z,t,nil)]]
- code = '_pretend or code = '_: =>
- form is [op,a,.] and op in '(_@ _: _:_: _pretend) => ['_pretend,a,t]
- [code,form,t]
- code in '(_@ _:_: _pretend) =>
- form is [op,a,b] and op in '(_@ _: _:_: _pretend) =>
- op in '(_: _pretend) => form
- op = code and b = t => form
- markNumCheck(code,form,t)
- integer? form and MEMQ(opOf t,$markPrimitiveNumbers) => ['_@,form,t]
- [code,form,t]
- code in '(_@ _:_: _:) and form is [op,a] and
- (op='rep and t = 'Rep or op='per and t = "$") => form
- code = 'Lisp =>
- t = $EmptyMode => form
- ["pretend",form,t]
- t in '(rep per) =>
- t = 'rep and form is ["per",:.] => second form
- t = 'per and form is ["rep",:.] => second form
- [t,form]
- code is [op,x,t1] and op in '(_@ _: _:_: _pretend) and t1 = t => form
- integer? form and MEMQ(opOf t,$markPrimitiveNumbers) => ['_@,form,t]
- markNumCheck("::",form,t)
-
-markNumCheck(op,form,t) ==
- op = "::" and opOf t in '(Integer) =>
- s := form = $One and 1 or form = $Zero and 0 => ['DOLLAR, s , t]
- integer? form => ["@", form, t]
- form is ["-", =$One] => ['DOLLAR, -1, t]
- form is ["-", n] and integer? n => ["@", MINUS n, t]
- [op, form, t]
- [op,form,t]
-
-markInsertSeq(code,x,t) ==
- x is ['exit,y] => ['exit,markInsertChanges(code,y,t,nil)]
- atom x => x
- [markInsertSeq(code,y,t) for y in x]
---======================================================================
--- Prettyprint of translated program
---======================================================================
-markFinish(body,T) ==
---called by compDefineCategory2, compDefineFunctor1 (early jumpout)
- SETQ($cs,$capsuleStack)
- SETQ($ps,$predicateStack)
- SETQ($ss,$signatureStack)
- SETQ($os,$originalTarget)
- SETQ($gis,$globalImportStack)
- SETQ($gds,$globalDeclareStack)
- SETQ($gms,$globalMacroStack)
- SETQ($as, $abbreviationStack)
- SETQ($lms,$localMacroStack)
- SETQ($map,$macrosAlreadyPrinted)
- SETQ($gs,$importStack)
- SETQ($fs,$freeStack)
- SETQ($b,body)
- SETQ($t,T)
- SETQ($e,T.env)
---if $categoryTranForm then SETQ($t,$categoryTranForm . 1)
- atom CDDR T => systemError()
- T.rest.rest.first := $EmptyEnvironment
- chk(CDDR T,101)
- markFinish1()
- T
-
-reFinish() ==
- $importStack := $gs
- $freeStack := $fs
- $capsuleStack := $cs
- $predicateStack := $ps
- $signatureStack := $ss
- $originalTarget := $os
- $globalMacroStack := $gms
- $abbreviationStack:= $as
- $globalImportStack := $gis
- $globalDeclareStack := $gds
- $localMacroStack := $lms
- $macrosAlreadyPrinted := $map
- $abbreviationsAlreadyPrinted := nil
- markFinish1()
-
-markFinish1() ==
- body := $b
- T := $t
- $predGensymAlist: local := nil
---$capsuleStack := $cs
---$predicateStack := $ps
- form := T. expr
- ['Mapping,:sig] := T.mode
- if $insideCategoryIfTrue and $insideFunctorIfTrue then
- $importStack := [delete($categoryNameForDollar,x) for x in $importStack]
- $globalImportStack := delete($categoryNameForDollar,$globalImportStack)
- $commonImports : local := getCommonImports()
- globalImports :=
- reverse orderByContainment removeDuplicates [:$commonImports,:$globalImportStack]
- $finalImports: local := SETDIFFERENCE(globalImports,$globalDeclareStack)
- $capsuleStack :=
- [mkNewCapsuleItem(freepart,imports,x) for freepart in $freeStack
- for imports in $importStack for x in $capsuleStack]
- $extraDefinitions := combineDefinitions()
- addDomain := nil
- initbody :=
- $b is ['add,a,b] =>
- addDomain := a
- b
- $b is [op,:.] and constructor? op =>
- addDomain := $b
- nil
- $b
- body := markFinishBody initbody
- importCode := [['import,x] for x in $finalImports]
- leadingMacros := markExtractLeadingMacros(globalImports,body)
- body := markRemImportsAndLeadingMacros(leadingMacros,body)
- initcapsule :=
- body => ['CAPSULE,:leadingMacros,:importCode,:body]
- nil
- capsule :=
--- null initcapsule => addDomain
- addDomain => ['add,addDomain,initcapsule]
- initcapsule
- nsig :=
- $categoryPart => sig
- ['Type,:rest sig]
- for x in reverse $abbreviationStack |not member(x,$abbreviationsAlreadyPrinted) repeat
- markPrintAbbreviation x
- $abbreviationsAlreadyPrinted := insert(x,$abbreviationsAlreadyPrinted)
- for x in reverse $globalMacroStack|not member(x,$macrosAlreadyPrinted) repeat
- $def := ['MDEF,first x,'(NIL),'(NIL),rest x]
- markPrint(true)
- $macrosAlreadyPrinted := insert(x,$macrosAlreadyPrinted)
- if $insideCategoryIfTrue and not $insideFunctorIfTrue then
- markPrintAttributes $b
- $def := ['DEF,form,nsig,[nil for x in form],capsule]
- markPrint()
-
-stop x == x
-
-getNumberTypesInScope() ==
- union([y for x in $localImportStack | MEMQ(y := opOf x,$markNumberTypes)],
- [y for x in $globalImportStack| MEMQ(y := opOf x,$markNumberTypes)])
-
-getCommonImports() ==
- importList := [x for x in $importStack for y in $capsuleStack |
- KAR KAR y = 'DEF]
- hash := hashTable 'EQUAL
- for x in importList repeat
- for y in x repeat HPUT(hash,y,1 + (HGET(hash,y) or 0))
- threshold := FLOOR (.5 * #importList)
- [x for x in HKEYS hash | HGET(hash,x) >= threshold]
-
-markPrintAttributes addForm ==
- capsule :=
- addForm is ['add,a,:.] =>
- a is ['CATEGORY,:.] => a
- a is ['Join,:.] => first lastNode a
- first lastNode addForm
- addForm
- if capsule is ['CAPSULE,:r] then
- capsule := first lastNode r
- capsule isnt ['CATEGORY,.,:lst] => nil
- for x in lst | x is ['ATTRIBUTE,att] repeat
- markSay(form2String att)
- markSay('": Category == with")
- markTerpri()
- markTerpri()
-
-getCommons u ==
- common := KAR u
- while common and u is [x,:u] repeat common := intersection(x,common)
- common
-
-markExtractLeadingMacros(globalImports,body) ==
- [x for x in body | x is ['MDEF,[a],:.] and member(a,globalImports)]
-
-markRemImportsAndLeadingMacros(leadingMacros,body) ==
- [x for x in body | x isnt ['import,:.] and not member(x,leadingMacros)]
-
-mkNewCapsuleItem(frees,i,x) ==
- [originalDef,:ndef] := x
- imports := reverse orderByContainment removeDuplicates SETDIFFERENCE(i,$finalImports)
- importPart := [["import",d] for d in imports]
- nbody :=
- ndef is ["%LET",.,x] => x
- ndef is ['DEF,.,.,.,x] => x
- ndef
- newerBody :=
- newPart := [:frees,:importPart] =>
- nbody is ['SEQ,:y] => ['SEQ,:newPart,:y]
- ['SEQ,:newPart,['exit,1,nbody]]
- nbody
- newerDef :=
- ndef is ["%LET",a,x] => ["%LET",a,newerBody]
- ndef is ['DEF,a,b,c,x] => ['DEF,a,b,c,newerBody]
- newerBody
- entry := [originalDef,:newerDef]
- entry
-
-markFinishBody capsuleBody ==
- capsuleBody is ['CAPSULE,:itemlist] =>
- if $insideCategoryIfTrue and $insideFunctorIfTrue then
- itemlist := markCatsub itemlist
- [:[markFinishItem x for x in itemlist],:$extraDefinitions]
- nil
-
-markCatsub x == SUBST("$",$categoryNameForDollar,x)
-
-markFinishItem x ==
- $macroAlist : local := [:$localMacroStack,:$globalMacroStack]
- if $insideCategoryIfTrue and $insideFunctorIfTrue then
- $macroAlist := [["$",:$categoryNameForDollar],:$macroAlist]
- x is ['DEF,form,.,.,body] =>
- "or"/[new for [old,:new] in $capsuleStack |
- old is ['DEF,oform,.,.,obody]
- and markCompare(form,oform) and markCompare(body,obody)] or
- pp '"------------MISSING----------------"
- $f := form
- $b := body
- newform := "or"/[x for [old,:new] in $capsuleStack |
- old is ['DEF,oform,.,.,obody] and oform = $f]
- $ob:= (newform => obody; nil)
- pp $f
- pp $b
- pp $ob
- foobum x
- pp x
- x
- x is ["%LET",lhs,rhs] =>
- "or"/[new for [old,:new] in $capsuleStack |
- old is ["%LET",olhs,orhs]
- and markCompare(lhs,olhs) and markCompare(rhs,orhs)]
- or x
- x is ['IF,p,a,b] => ['IF,p,markFinishItem a,markFinishItem b]
- x is ['SEQ,:l,['exit,n,a]] =>
- ['SEQ,:[markFinishItem y for y in l],['exit,n,markFinishItem a]]
- "or"/[new for [old,:new] in $capsuleStack | markCompare(x,old)] =>
- new
- x
-
-markCompare(x,y) ==
- markKillAll(SUBLIS($macroAlist,x)) = markKillAll(SUBLIS($macroAlist,y))
-
-diffCompare(x,y) == diff(SUBLIS($macroAlist,x),markKillAll(SUBLIS($macroAlist,y)))
-
---======================================================================
--- Print functions
---======================================================================
-markPrint(:options) == --print $def
- noTrailingSemicolonIfTrue := IFCAR options
---$insideCategoryIfTrue and $insideFunctorIfTrue => nil
- $DEFdepth : local := 0
- [op,form,sig,sclist,body] := markKillAll $def
- if $insideCategoryIfTrue then
- if op = 'DEF and $insideFunctorIfTrue then
- T := $categoryTranForm . 1
- form := T . expr
- sig := rest (T . mode)
- form := SUBLISLIS(rest markConstructorForm opOf form,
- $TriangleVariableList,form)
- sig := SUBLISLIS(rest markConstructorForm opOf form,
- $TriangleVariableList,sig)
- nbody := body
- if $insideCategoryIfTrue then
- if $insideFunctorIfTrue then
- nbody := replaceCapsulePart body
- nbody :=
- $catAddForm => ['withDefault, $catAddForm, nbody]
- nbody
- else
- ['add,a,:r] := $originalBody
- xtraLines :=
- "append"/[[strconc(name,'": Category == with"),'""]
- for name in markCheckForAttributes a]
- nbody :=
- $originalBody is ['add,a,b] =>
- b isnt ['CAPSULE,:c] => error(false)
- [:l,x] := c
- [:markTranCategory a,['default,['SEQ,:l,['exit,1,x]]]]
- markTranCategory $originalBody
- signature :=
- $insideFunctorIfTrue => [markTranJoin $originalTarget,:rest sig]
- $insideCategoryIfTrue => ['Category,:rest sig]
- '(NIL)
- $bootForm:=
- op = 'MDEF => [op,form,signature,sclist,body]
- [op,form,signature,sclist,nbody]
- bootLines:= lisp2Boot $bootForm
- $bootLines:= [:xtraLines,:bootLines]
- moveAroundLines()
- markSay $bootLines
- markTerpri()
- 'done
-
-replaceCapsulePart body ==
- body isnt ['add,['CAPSULE,:c]] => body
- $categoryTranForm . 0 isnt ['add,exports,['CAPSULE,:.]] => error(false)
- [:l,x] := c
- [:markTranCategory exports,['default,['SEQ,:l,['exit,1,x]]]]
-
-foo(:x) ==
- arg := IFCAR x or $bootForm
- markSay lisp2Boot arg
-
-markPrintAbbreviation [kind,a,:b] ==
- markSay '"--)abbrev "
- markSay kind
- markSay '" "
- markSay a
- markSay '" "
- markSay b
- markTerpri()
-
-markSay s ==
- cons? s =>
- for x in s repeat
- (markSay(lispStringList2String x); markTerpri())
- PRINTEXP s
- if $outStream then PRINTEXP(s,$outStream)
-
-markTerpri() ==
- TERPRI()
- if $outStream then TERPRI($outStream)
-
-markTranJoin u == --subfunction of markPrint
- u is ['Join,:.] => markTranCategory u
- u
-
-markTranCategory cat ==
- cat is ['CATEGORY,:.] => cat
- cat is ['Join,:r] =>
- r is [:s,b] and b is ['CATEGORY,k,:t] => ['CATEGORY,k,:s,:markSigTran t]
- ['CATEGORY,'domain,:markSigTran r]
- ['CATEGORY,'domain,cat]
-
-markSigTran t == [markElt2Apply x for x in t]
-
-markElt2Apply x ==
- x is ["SIGNATURE", "elt", :r] => ['SIGNATURE, 'apply, :r]
- x
-
-markCheckForAttributes cat == --subfunction of markPrint
- cat is ['Join,:r] => markCheckForAttributes last r
- cat is ['CATEGORY,.,:r] => [u for x in r | u := fn(x)] where fn(x) ==
- x is ['ATTRIBUTE,form,:.] =>
- name := opOf form
- MEMQ(name,$knownAttributes) => nil
- $knownAttributes := [name,:$knownAttributes]
- name
- nil
- nil
-
---======================================================================
--- Put in PARTs in code
---======================================================================
-$partChoices := '(construct IF)
-$partSkips := '(CAPSULE with add)
-unpart x ==
- x is ['PART,.,y] => y
- x
-
-markInsertParts df ==
- $partNumber := 0
- ["DEF",form,a,b,body] := df
---if form is [op,:r] and (u := LASSOC(op,$opRenameAlist))
--- then form := [u,:r]
- ['DEF,form,a,b,markInsertBodyParts body]
-
-markInsertBodyParts u ==
- u is ['Join,:.] or u is ['CATEGORY,:.] => u
- u is ['DEF,f,a,b,body] => ['DEF,f,a,b,markInsertBodyParts body]
- u is ['SEQ,:l,['exit,n,x]] =>
- ['SEQ,:[markInsertBodyParts y for y in l],
- ['exit,n,markInsertBodyParts x]]
- u is [op,:l] and op in '(REPEAT COLLECT) => markInsertRepeat u
- u is ["%LET",["%Comma",:s],b] =>
- ["%LET",["%Comma",:[markWrapPart x for x in s]],markInsertBodyParts b]
---u is ["%LET",a,b] and constructor? opOf b => u
- u is ["%LET",a,b] and a is [op,:.] =>
- ["%LET",[markWrapPart x for x in a],markInsertBodyParts b]
- u is [op,a,b] and op in '(add with IN %LET) =>
- [op,markInsertBodyParts a,markInsertBodyParts b]
- u is [op,a,b] and op in '(_: _:_: pretend _@) =>
- [op,markInsertBodyParts a,b]
- u is [op,a,:x] and op in '(STEP _return _leave exit reduce) =>
- [op,a,:[markInsertBodyParts y for y in x]]
- u is [op,:x] and markPartOp? op => [op,:[markWrapPart y for y in x]]
- u is [op,:.] and constructor? op => u
- atom u => markWrapPart u
- ------------ <--------------94/10/11
- [markInsertBodyParts x for x in u]
-
-markPartOp? op ==
- MEMQ(op,$partChoices) => true
- MEMQ(op,$partSkips) => false
- if op is ['elt,.,o] then op := o
- GETL(op,'special) => false
- true
-
-markWrapPart y ==
-----------------new definition----------94/10/11
- atom y =>
- y = '%noBranch => y
- GETL(y, 'SPECIAL) => y
- $partNumber := $partNumber + 1
- ['PART,$partNumber, y]
- ['PART,$partNumber := $partNumber + 1,markInsertBodyParts y]
-
-markInsertRepeat [op,:itl,body] ==
- nitl := [markInsertIterator x for x in itl]
- nbody :=
---->IDENTP body => markWrapPart body
-----------------new definition----------94/10/11
- markInsertBodyParts body
- [op,:nitl,nbody]
-
-markInsertIterator x ==
- x is ['STEP,k,:r] => ['STEP,markWrapPart k,:[markWrapPart x for x in r]]
- x is ['IN,p,q] => ['IN,markWrapPart p,markWrapPart q]
- x is ["|",p] => ["|",markWrapPart p]
- x is ['WHILE,p] => ['WHILE,markWrapPart p]
- x is ['UNTIL,p] => ['UNTIL,markWrapPart p]
- systemError()
-
---======================================================================
--- Kill Function: MarkedUpCode --> Code
---======================================================================
-
-markKillExpr m == --used to kill all but PART information for compilation
- m is [op,:.] =>
- op in '(MI WI) => markKillExpr third m
- op in '(AUTOHARD AUTOSUBSET AUTOREP) => markKillExpr fourth m
- m is ['TAGGEDreturn,a,[x,m,e]] => ['TAGGEDreturn, a, [markKillExpr x,m,e]]
- [markKillExpr x for x in m]
- m
-
-markKillButIfs m == --used to kill all but PART information for compilation
- m is [op,:.] =>
- op = 'IF => m
- op = 'PART => markKillButIfs third m
- op in '(MI WI) => markKillButIfs third m
- op in '(AUTOHARD AUTOSUBSET AUTOREP) => markKillButIfs fourth m
- m is ['TAGGEDreturn,a,[x,m,e]] => ['TAGGEDreturn, a, [markKillButIfs x,m,e]]
- [markKillButIfs x for x in m]
- m
-
-markKillAll m == --used to prepare code for compilation
- m is [op,:.] =>
- op = 'PART => markKillAll third m
- op in '(MI WI) => markKillAll third m
- op in '(AUTOHARD AUTOSUBSET AUTOREP) => markKillAll fourth m
- m is ['TAGGEDreturn,a,[x,m,e]] => ['TAGGEDreturn, a, [markKillAll x,m,e]]
- [markKillAll x for x in m]
- m
-
---======================================================================
--- Moving lines up/down
---======================================================================
-moveAroundLines() ==
- changeToEqualEqual $bootLines
- $bootLines := moveImportsAfterDefinitions $bootLines
-
-changeToEqualEqual lines ==
---rewrite A := B as A == B whenever A is an identifier and
--- B is a constructor name (after macro exp.)
- origLines := lines
- while lines is [x, :lines] repeat
- N := MAXINDEX x
- (n := charPosition($blank, x, 8)) > N => nil
- n = 0 => nil
- not alphabetic? (x . (n - 1)) => nil
- not substring?('":= ", x, n+1) => nil
- m := n + 3
- while (m := m + 1) <= N and alphabetic? (x . m) repeat nil
- m = n + 2 => nil
- not upperCase? (x . (n + 4)) => nil
- word := makeSymbol subString(x, n + 4, m - n - 4)
- expandedWord := macroExpand(word,$e)
- not (word in '(Record Union Mapping)
- or getConstructorFormFromDB opOf expandedWord) => nil
- sayMessage '"Converting input line:"
- sayMessage ['"WAS: ", x]
- x . (n + 1) := char '_= ;
- sayMessage ['"IS: ", x]
- TERPRI()
- origLines
-
-sayMessage x ==
- u :=
- atom x => ['">> ", x]
- ['">> ",: x]
- sayBrightly u
-
-moveImportsAfterDefinitions lines ==
- al := nil
- for x in lines for i in 0.. repeat
- N := MAXINDEX x
- m := firstNonBlankPosition x
- m < 0 => nil
- ((n := charPosition($blank ,x,1 + m)) < N) and
- substring?('"== ", x, n+1) =>
- name := subString(x, m, n - m)
- defineAlist := [[name, :i], :defineAlist]
- (k := leadingSubstring?('"import from ",x, 0)) =>
- importAlist := [[subString(x,k + 12), :i], :importAlist]
--- pp defineAlist
--- pp importAlist
- for [name, :i] in defineAlist repeat
- or/[fn for [imp, :j] in importAlist] where fn() ==
- substring?(name,imp,0) =>
- moveAlist := [[i,:j], :moveAlist]
- nil
- null moveAlist => lines
- moveLinesAfter(mySort moveAlist, lines)
-
-leadingSubstring?(part, whole, :options) ==
- after := IFCAR options or 0
- substring?(part, whole, k := firstNonBlankPosition(whole, after)) => k
- false
-
-stringIsWordOf?(s, t, startpos) ==
- maxindex := MAXINDEX t
- (n := stringPosition(s, t, startpos)) > maxindex => nil
- wordDelimiter? t . (n - 1)
- n = maxindex or wordDelimiter? t . (n + #s)
-
-wordDelimiter? c == or/[CHAR_=(c,('"() ,;").i) for i in 0..4]
-
-moveLinesAfter(alist, lines) ==
- n := #lines
- acc := nil
- for i in 0..(n - 1) for x in lines repeat
- (p := ASSOC(i, alist)) and string? rest p => acc := [rest p, x, :acc]
- (p := lookupRight(i, alist)) and (first p) > i => p.rest := x
- acc := [x, :acc]
- reverse acc
-
-lookupRight(x, al) ==
- al is [p, :al] =>
- x = rest p => p
- lookupRight(x, al)
- nil
-
---======================================================================
--- Utility Functions
---======================================================================
-
-ppEnv [ce,:.] ==
- for env in ce repeat
- for contour in env repeat
- pp contour
-
-diff(x,y) ==
- for [p,q] in (r := diff1(x,y)) repeat
- pp '"------------"
- pp p
- pp q
- #r
-
-diff1(x,y) ==
- x = y => nil
- atom x or atom y => [[x,y]]
- #x ~= #y => [x,y]
- append/[diff1(u,v) for u in x for v in y]
-
-markConstructorForm name == --------> same as getConstructorForm
- name = 'Union => '(Union (_: a A) (_: b B))
- name = 'UntaggedUnion => '(Union A B)
- name = 'Record => '(Record (_: a A) (_: b B))
- name = 'Mapping => '(Mapping T S)
- getConstructorFromDB name
-
---======================================================================
--- new path functions
---======================================================================
-
-$newPaths := false
-
-markGetPaths(x,y) ==
- $newPaths =>
--- res := reverseDown mkGetPaths(x, y)
- res := mkGetPaths(x, y)
--- oldRes := markPaths(x,y,[nil])
--- if res ~= oldRes then $badStack := [[x, :y], :$badStack]
--- oldRes
- markPaths(x,y,[nil])
-
-mkCheck() ==
- for [x, :y] in removeDuplicates $badStack repeat
- pp '"!!-------------------------------!!"
- res := mkGetPaths(x, y)
- oldRes := markPaths(x, y, [nil])
- pp x
- pp y
- sayBrightlyNT '"new: "
- pp res
- sayBrightlyNT '"old: "
- pp oldRes
-
-reverseDown u == [reverse x for x in u]
-
-mkCheckRun() ==
- for [x, :y] in removeDuplicates $badStack repeat
- pp mkGetPaths(x,y)
-
-mkGetPaths(x,y) ==
- u := removeDuplicates mkPaths(x,y) => getLocationsOf(u,y,nil)
- nil
-
-mkPaths(x,y) == --x < y; find location s of x in y (initially s=nil)
- markPathsEqual(x,y) => [y]
- atom y => nil
- x is [op, :u] and op in '(LIST VECTOR) and y is ['construct,:v]
- and markPathsEqual(['construct,:u],y) => [y]
- (y is ["%LET",a,b] or y is ['IF,a,b,:.]) and GENSYMP a and markPathsEqual(x,b) => [y]
- y is ['%call,:r] =>
--- markPathsEqual(x,y1) => [y]
- mkPaths(x,r) => [y]
- y is ['PART,.,y1] => mkPaths(x,y1)
- y is [fn,.,y1] and fn in '(CATCH THROW) =>
--- markPathsEqual(x,y1) => [y]
- mkPaths(x,y1) => [y]
- y is [['elt,.,op],:r] and (u := mkPaths(x,[op,:r])) => u
- x is ['elt,:r] and (u := mkPaths(r,y)) => u
- y is ['elt,:r] and (u := mkPaths(x,r)) => u
- append/[u for z in y | u := mkPaths(x,z)]
-
-getLocationsOf(u,y,s) == [getLocOf(x,y,s) for x in u]
-
-getLocOf(x,y,s) ==
- x = y or x is ['elt,:r] and r = y => s
- y is ['PART,.,y1] => getLocOf(x,y1,s)
- if y is ['elt,:r] then y := r
- atom y => nil
- or/[getLocOf(x,z,[i, :s]) for i in 0.. for z in y]
-
-
---======================================================================
--- Combine Multiple Definitions Into One
---======================================================================
-
-combineDefinitions() ==
---$capsuleStack has form (def1 def2 ..)
---$signatureStack has form (sig1 sig2 ..) where sigI = nil if not a def
---$predicateStack has form (pred1 pred2 ..)
---record in $hash: alist of form [[sig, [predl, :body],...],...] under each op
- $hash := MAKE_-HASH_-TABLE()
- for defs in $capsuleStack
- for sig in $signatureStack
- for predl in $predicateStack | sig repeat
--- pp [defs, sig, predl]
- [["DEF",form,:.],:.] := defs
- item := [predl, :defs]
- op := opOf form
- oldAlist := HGET($hash,opOf form)
- pair := ASSOC(sig, oldAlist) => pair.rest := [item,:rest pair]
- HPUT($hash, op, [[sig, item], :oldAlist])
---extract and combine multiple definitions
- Xdeflist := nil
- for op in HKEYS $hash repeat
- $acc: local := nil
- for [sig,:items] in HGET($hash,op) | (k := #items) > 1 repeat
- for i in 1.. for item in items repeat
- [predl,.,:def] := item
- ['DEF, form, :.] := def
- ops := PNAME op
- opName := makeSymbol(strconc(ops,'"X",STRINGIMAGE i))
- form.first := opName
--- rplacaSubst(op, opName, def)
- $acc := [[form,:predl], :$acc]
- Xdeflist := [buildNewDefinition(op,sig,$acc),:Xdeflist]
- reverse Xdeflist
-
-rplacaSubst(x, y, u) == (fn(x, y, u); u) where fn(x,y,u) ==
- atom u => nil
- while u is [p, :q] repeat
- if EQ(p, x) then u.first := y
- if cons? p then fn(x, y, p)
- u := q
-
-buildNewDefinition(op,theSig,formPredAlist) ==
- newAlist := [fn for item in formPredAlist] where fn() ==
- [form,:predl] := item
- pred :=
- null predl => 'T
- boolBin simpHasPred markKillAll MKPF(predl,"and")
- [pred, :form]
- --make sure that T comes as last predicate
- outerPred := boolBin simpHasPred MKPF(ASSOCLEFT newAlist,"or")
- theForm := CDAR newAlist
- alist := moveTruePred2End newAlist
- theArgl := rest theForm
- theAlist := [[pred, first form, :theArgl] for [pred,:form] in alist]
- theNils := [nil for x in theForm]
- thePred :=
- outerPred in '(T %true) => nil
- outerPred
- def := ['DEF, theForm, theSig, theNils, ifize theAlist]
- value :=
- thePred => ['IF, thePred, def, '%noBranch]
- def
- stop value
- value
-
-boolBin x ==
- x is [op,:argl] =>
- op in '(AND OR) and argl is [a, b, :c] and c => boolBin [op, boolBin [op, a, b], :c]
- [boolBin y for y in x]
- x
-
-ifize [[pred,:value],:r] ==
- null r => value
- ['IF, pred, value, ifize r]
-
-moveTruePred2End alist ==
- truthPair := or/[pair for pair in alist | pair is ["T",:.]] =>
- [:delete(truthPair, alist), truthPair]
- [:a, [lastPair, lastValue]] := alist
- [:a, ["T", lastValue]]
-
-PE e ==
- for x in CAAR e for i in 1.. repeat
- ppf [i, :x]
-
-ppf x ==
- _*PRETTYPRINT_* : local := true
- PRINT_-FULL x
-
-
---%
-for x in [["%LET", :"compSetq"],_
- ["Join", :"compJoin"],_
- ["Record", :"compCat"],_
- ["Union", :"compCat"],_
- ["_:", :"compColon"],_
- ["_:_:", :"compCoerce"],_
- ["CAPSULE", :"compCapsule"],_
- ["has", :"compHas"],_
- ["is", :"compIs"],_
- ["add", :"compAdd"],_
- ["CONS", :"compCons"],_
- ["IF", :"compIf"],_
- ["exit", :"compExit"],_
- ["return", :"compReturn"],_
- ["return", :"compLeave"],_
- ["elt", :"compElt"],_
- ["DEF", :"compDefine"],_
- ["MDEF", :"compMacro"],_
- ["SubsetCategory", :"compSubsetCategory"],_
- ["SubDomain", :"compSubDomain"],_
- ["case", :"compCase"],_
- ["RecordCategory", :"compConstructorCategory"],_
- ["ListCategory", :"compConstructorCategory"],_
- ["VectorCategory", :"compConstructorCategory"],_
- ["UnionCategory", :"compConstructorCategory"],_
- ["CATEGORY", :"compCategory"],_
- ["COLLECT", :"compRepeatOrCollect"],_
- ["COLLECTV", :"compCollectV"],_
- ["REPEAT", :"compRepeatOrCollect"],_
- ["REDUCE", :"compReduce"],_
- ["where", :"compWhere"],_
- ["_|", :"compSuchthat"],_
- ["construct", "compConstruct"],_
- ["SEQ", :"compSeq"],_
- ["SETQ", :"compSetq"],_
- ["VECTOR", :"compVector"]] repeat
- property(first x, 'special) := rest x
diff --git a/src/interp/nspadaux.lisp b/src/interp/nspadaux.lisp
deleted file mode 100644
index 99f7dd50..00000000
--- a/src/interp/nspadaux.lisp
+++ /dev/null
@@ -1,119 +0,0 @@
-;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-;; All rights reserved.
-;; Copyright (C) 2007-2008, 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 "sys-macros")
-(in-package "BOOT")
-
-(defvar |$DEFdepth| 0)
-(defvar |$localMacroStack| nil)
-(defvar |$globalMacroStack| nil)
-(defvar |$abbreviationStack| nil)
-(defvar |$knownAttributes| nil "cumulative list of known attributes of a file")
-
-(defparameter |$underscoreChar| (|char| '_))
-(defvar |$back| nil)
-
-(defparameter |$markChoices| '(ATOM COLON LAMBDA AUTOSUBSET AUTOHARD AUTOREP REPPER FREESI RETRACT))
-(defparameter |$convert2NewCompiler| 'T)
-(defparameter |$AnalyzeOnly| NIL)
-(defparameter |$categoryPart| 'T)
-(defparameter |$insideCAPSULE| nil)
-(defparameter |$insideEXPORTS| nil)
-(defparameter |$originalSignature| nil)
-(defparameter |$insideDEF| nil)
-(defparameter |$insideTypeExpression| nil)
-(defparameter |$spadTightList| '(\.\. \# \' \:\ \: \:\:))
-
-(defparameter |$PerCentVariableList| '(%1 %2 %3 %4 %5 %6 %7 %8 %9 %10))
-
-(mapcar #'(lambda (X) (MAKEPROP (CAR X) 'SPECIAL (CADR X)))
- '((PART |compPART|)
- (WI |compWI|)
- (MI |compWI|)))
-
-(mapcar #'(lambda (X) (MAKEPROP (CAR X) 'PSPAD (CADR X)))
- '((|default| |formatDefault|)
- (|local| |formatLocal|)
- (COMMENT |formatCOMMENT|)
- (CAPSULE |formatCAPSULE|)
- (LISTOF |formatPAREN|)
- (DEF |formatDEF|)
- (SEQ |formatSEQ|)
- (LET |formatLET|)
- (\: |formatColon|)
- (ELT |formatELT|)
- (QUOTE |formatQUOTE|)
- (SEGMENT |formatSEGMENT|)
- (DOLLAR |formatDOLLAR|)
- (BRACE |formatBrace|)
- (|dot| |formatDot|)
- (MDEF |formatMDEF|)
- (|free| |formatFree|)
- (|elt| |formatElt|)
- (PAREN |formatPAREN|)
- (PROGN |formatPROGN|)
- (|exit| |formatExit|)
- (|leave| |formatLeave|)
- (|void| |formatvoid|)
- (MI |formatMI|)
- (IF |formatIF|)
- (\=\> |formatFATARROW|)
- (\+\-\> |formatMap|)
- (|Enumeration| |formatEnumeration|)
- (|import| |formatImport|)
- (UNCOERCE |formatUNCOERCE|)
- (CATEGORY |formatCATEGORY|)
- (SIGNATURE |formatSIGNATURE|)
- (|where| |formatWHERE|)
- (COLLECT |formatCOLLECT|)
- (|MyENUM| |formatENUM|)
- (REDUCE |formatREDUCE|)
- (REPEAT |formatREPEAT|)
- (ATTRIBUTE |formatATTRIBUTE|)
- (CONS |formatCONS|)
- (|construct| |formatConstruct|)
- (|Union| |formatUnion|)
- (|Record| |formatRecord|)
- (|Mapping| |formatMapping|)
- (|Tuple| |formatTuple|)
- (|with| |formatWith|)
- (|withDefault| |formatWithDefault|)
- (|defaultDefs| |formatDefaultDefs|)
- (|add| |formatAdd|)))
-
-(remprop 'cons '|Led|)
-(remprop 'append 'format)
-(remprop 'cons 'format)
-
-
diff --git a/src/interp/pspad1.boot b/src/interp/pspad1.boot
deleted file mode 100644
index cd3a08dd..00000000
--- a/src/interp/pspad1.boot
+++ /dev/null
@@ -1,745 +0,0 @@
--- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
--- All rights reserved.
--- Copyright (C) 2007-2011, 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 macros
-namespace BOOT
-
-$escapeWords := ["always", "assert", "but", "define",
- "delay", "do", "except", "export", "extend", "fix", "fluid",
- "from", "generate", "goto", "import", "inline", "never", "select",
- "try", "yield"]
-$pileStyle := false
-$commentIndentation := 8
-$braceIndentation := 8
-$doNotResetMarginIfTrue := true
-$marginStack := nil
-$numberOfSpills := 0
-$lineFragmentBuffer:= nil
-$pspadRelationAlist := '((_= . _~_=) (_< . _>_=) (_<_= . _>)(_~_= . _=)(_>_= . _<) (_> . _<_=))
-$lineBuffer := nil
-$formatForcePren := nil
-$underScore := char ('__)
-$rightBraceFlag := nil
-$semicolonFlag := nil
-$newLineWritten := nil
-$comments := nil
-$noColonDeclaration := false
-$renameAlist := '(
- (SmallInteger . SingleInteger)
- (SmallFloat . DoubleFloat)
- (Void . _(_))
- (xquo . exquo)
- (setelt . set_!)
- (_$ . _%)
- (_$_$ . _$)
- (_*_* . _^)
- (_^_= . _~_=)
- (_^ . _~))
-
---$opRenameAlist := '(
--- (and . AND)
--- (or . OR)
--- (not . NOT))
-
-
---======================================================================
--- Main Translator Function
---======================================================================
---% lisp-fragment to boot-fragment functions
-lisp2Boot x ==
- --entry function
- $fieldNames := nil
- $pilesAreOkHere: local:= true
- $commentsToPrint: local:= nil
- $lineBuffer: local := nil
- $braceStack: local := nil
- $marginStack: local:= [0]
- --$autoLine is true except when inside a try---if true, lines are allowed to break
- $autoLine:= true
- $lineFragmentBuffer:= nil
- $bc:=0 --brace count
- $m:= 0
- $c:= $m
- $numberOfSpills:= 0
- $lineLength:= 80
- format x
- formatOutput reverse $lineFragmentBuffer
- [fragmentsToLine y for y in reverse $lineBuffer]
-
-fragmentsToLine fragments ==
- string:= lispStringList2String fragments
- line:= GETSTR 240
- for i in 0..MAXINDEX string repeat line:= SUFFIX(string.i,line)
- line
-
-lispStringList2String x ==
- null x => '""
- atom x => STRINGIMAGE x
- rest x => apply(function strconc,MAPCAR(function lispStringList2String,x))
- lispStringList2String first x
-
---% routines for buffer and margin adjustment
-
-formatOutput x ==
- for [currentColumn,start,end,stack] in reverse $commentsToPrint repeat
- startY:= rest start
- for [loc,comment] in stack repeat
- commentY:= rest loc
- gap:= startY-commentY
- gap>0 => before:= [[commentY,first loc,gap,comment],:before]
- gap=0 => same:= [[startY,1,gap,comment],:same]
- true => after:= [[startY,first loc,-gap,comment],:after]
- if before then putOut before
- if same then
- [y,:extraLines]:= "append"/[mkCommentLines u for u in orderList same]
- line:= fragmentsToLine x
- x:=
- #line+#y>$lineLength =>
- (y:= strconc(nBlanks $m,y); extraLines:= [y,:extraLines]; x)
- [line,y]
- consLineBuffer x
- for y in extraLines repeat consLineBuffer [y]
- if after then putOut after
- $commentsToPrint:= nil
-
-consLineBuffer x == $lineBuffer := [x,:$lineBuffer]
-
-putOut x ==
- eject ("min"/[gap for [.,.,gap,:.] in x])
- for u in orderList x repeat addComment u
-
-eject n == for i in 2..n repeat consLineBuffer nil
-
-addComment u ==
- for x in mkCommentLines u repeat consLineBuffer [x]
-
-mkCommentLines [.,n,.,s] ==
- lines:= breakComments s
- lines1:= [fragmentsToLine [nBlanks n,"_{",first lines],:rest lines]
- [:l,last]:= lines1
- [:l,fragmentsToLine [last,"_}"]]
-
-breakComments s ==
- n:= containsString(s,PNAME "ENDOFLINECHR") =>
- #s>n+12 => [subString(s,0,n),:breakComments subString(s,n+12)]
- [subString(s,0,n)]
- [s]
-
-containsString(x,y) ==
- --if string x contains string y, return start index
- for i in 0..MAXINDEX x-MAXINDEX y repeat
- and/[x.(i+j)=y.j for j in 0..MAXINDEX y] => return i
-
---======================================================================
--- Character/String Buffer Functions
---======================================================================
-consBuffer item ==
- if item = '"failed" then item := 'failed
- n:=
- string? item => 2+#item
- IDENTP item => #symbolName item
- #STRINGIMAGE item
- columnsLeft:= $lineLength-$c
- if columnsLeft <= 0 and isCloseDelimiter item then $lineLength := $lineLength + 2
- columnsLeft:= $lineLength-$c
- --cheat for semicolons, strings, and delimiters: they are NEVER too long
- not isSpecialBufferItem item and (n>columnsLeft or columnsLeft < 0) =>
- $autoLine =>
- --is true except within try
- formatOutput reverse $lineFragmentBuffer
- $c:= ($m+2*($numberOfSpills:= $numberOfSpills+1)) rem $lineLength
- $lineFragmentBuffer:= [nBlanks $c]
- consBuffer item
- nil
- $lineFragmentBuffer:=
- null item or IDENTP item => [symbolName item,:$lineFragmentBuffer]
- integer? item or CHARP item => [STRINGIMAGE item,:$lineFragmentBuffer]
- string? item => ["_"",string2PrintImage item,"_"",:$lineFragmentBuffer]
- sayBrightly ['"Unexpected line buffer item: ", STRINGIMAGE item]
- $lineFragmentBuffer
- $rightBraceFlag := item = "}"
- $semicolonFlag := item = "; " --prevents consecutive semicolons
- $c:= $c+n
-
-isSpecialBufferItem item ==
- item = "; " or string? item => true
- false
-
-isCloseDelimiter item ==
- item = ")" or item = "]" or item = "}"
-
---======================================================================
--- Formatting/Line Control Functions
---======================================================================
-newLine() ==
- null $autoLine => nil
- $newLineWritten := true
- formatOutput reverse $lineFragmentBuffer
- $lineFragmentBuffer:= [nBlanks $m]
- $c:= $m
-
-optNewLine() ==
- $newLineWritten => newLine()
- $c
-
-spillLine() ==
- null $autoLine => nil
- formatOutput reverse $lineFragmentBuffer
- $c:= $m+2*($numberOfSpills:= $numberOfSpills+1)
- $lineFragmentBuffer:= [nBlanks $c]
- $c
-
-indent() ==
- $m:= $m+2*($numberOfSpills+1)
- $marginStack:= [$m,:$marginStack]
- $numberOfSpills:= 0
- $m
-
-undent() ==
--- $doNotResetMarginIfTrue=true =>
--- pp '"hoho"
--- $c
- $marginStack is [m,:r] =>
- $marginStack := r
- $m := m
- 0
-
-spill(fn,a) ==
- u := tryLine FUNCALL(fn,a) => u
- (nearMargin() or spillLine()) and FUNCALL(fn,a)
-
-formatSpill(fn,a) ==
- u := tryLine FUNCALL(fn,a) => u
- v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,a)
- w := stay or undent()
- v and w
-
-formatSpill2(fn,f,a) ==
- u := tryLine FUNCALL(fn,f,a) => u
- v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,f,a)
- w := stay or undent()
- v and w
-
-nearMargin() ==
- $c=$m or $c=$m+1 => $c
-
---======================================================================
--- Main Formatting Functions
---======================================================================
-format(x,:options) ==
- oldC:= $c
- qualification := IFCAR options
- newCOrNil:=
- x is [op,:argl] =>
- if op = "return" then argl := rest argl
- n := #argl
- op is ['elt,y,"construct"] => formatDollar(y,'construct,argl)
- op is ['elt,name,p] and upperCase? STRINGIMAGE(opOf name).0 =>
- formatDollar(name,p,argl)
- op = 'elt and upperCase? STRINGIMAGE(opOf first argl).0 =>
- formatDollar1(first argl,second argl)
- fn:= GETL(op,"PSPAD") => formatFn(fn,x,$m,$c)
- if op in '(AND OR NOT) then op:= DOWNCASE op
- n=1 and GETL(op,'Nud) and (lbp:= formatOpBindingPower(op,"Nud","left")) =>
- formatPrefix(op,first argl,lbp,formatOpBindingPower(op,"Nud","right"),qualification)
- n=2 and (op = '_$ or getOp(op,'Led)) and (lbp:= formatOpBindingPower(op,"Led","left")) =>
- formatInfix(op,argl,lbp,formatOpBindingPower(op,"Led","right"),qualification)
- formatForm x
- formatAtom x
- null newCOrNil => ($c:= oldC; nil)
- not integer? newCOrNil => error()
- $c:= newCOrNil
-
-
-getOp(op,kind) ==
- kind = 'Led =>
- op in '(_div _exquo) => nil
- GETL(op,'Led)
- GETL(op,'Nud)
-
-formatDollar(name,p,argl) ==
- name := markMacroTran name
- n := #argl
- kind := (n=1 => "Nud"; "Led")
- IDENTP name and GETL(p,kind) => format([p,:argl],name)
- formatForcePren [p,:argl] and
- (tryLine (format "$$" and formatForcePren name)
- or (indent() and format "$__" and formatForcePren name and undent()))
-
-formatMacroCheck name ==
- atom name => name
- u := or/[x for [x,:y] in $globalMacroStack | y = name] => u
- u := or/[x for [x,:y] in $localMacroStack | y = name] => u
- [op,:argl] := name
- op in '(Record Union) =>
- pp ['"Cannot find: ",name]
- name
- [op,:[formatMacroCheck x for x in argl]]
-
-formatDOLLAR ['DOLLAR,x,y] == formatDollar1(y, x)
-
-formatDollar1(name,arg) ==
- id :=
- IDENTP name => name
- name is [p] and GETL(p,"NILADIC") => p
- name
- format arg and format "$$" and formatForcePren id
-
-
-formatForcePren x ==
- $formatForcePren: local := true
- format x
-
-formatAtom(x,:options) ==
- if u := LASSOC(x,$renameAlist) then x := u
- null x or isIdentifier x =>
- if MEMQ(x,$escapeWords) then
- consBuffer $underScore
- consBuffer ident2PrintImage PNAME x
- consBuffer x
-
-formatFn(fn,x,$m,$c) == FUNCALL(fn,x)
-
-formatFree(['free,:u]) ==
- format 'free and format " " and formatComma u
-
-formatUnion(['Union,:r]) ==
- $count : local := 0
- formatFormNoColonDecl formatTestForPartial ['Union,:[fn x for x in r]] where fn x ==
- x is [":",y,'Branch] => fn STRINGIMAGE y
- string? x => [":", makeSymbol x, ['Enumeration,x]]
- x is [":",:.] => x
- tag := makeSymbol strconc('"value",STRINGIMAGE ($count := $count + 1))
- [":", tag, x]
-
-formatTestForPartial u ==
- u is ['Union,a,b] and b is [":","failed",:.] and a is [":",.,S] =>
- ['Partial, S]
- u
-
-formatEnumeration(y is ['Enumeration,:r]) ==
- r is [x] => format "'" and format makeSymbol STRINGIMAGE x and format "'"
- formatForm y
-
-formatRecord(u) == formatFormNoColonDecl u
-
-formatFormNoColonDecl u ==
- $noColonDeclaration: local := true
- formatForm u
-
-formatElt(u) ==
- u is ["elt",a,b] => formatApplication rest u
- formatForm u
-
-formatForm (u) ==
- [op,:argl] := u
- if op in '(Record Union) then
- $fieldNames := union(getFieldNames argl,$fieldNames)
- op in '(true %true) => format "true"
- op in '(false nil) => format op
- u=$Zero => format 0
- u=$One => format 1
- 1=#argl => formatApplication u
- formatFunctionCall u
-
-formatFunctionCall u ==
- $pilesAreOkHere: local
- spill("formatFunctionCall1",u)
-
-formatFunctionCall1 [op,:argl] ==
---null argl and getConstructorProperty(op,'niladic) => formatOp op
- null argl =>
- GETL(op,"NILADIC") => formatOp op
- formatOp op and format "()"
- formatOp op and formatFunctionCallTail argl
-
-formatFunctionCallTail argl == format "_(" and formatComma argl and format "_)"
-
-formatComma argl ==
- format first argl and (and/[format "," and formatCut x for x in rest argl]) and $c
-
-formatOp op ==
- atom op => formatAtom op
- formatPren op
-
-formatApplication u ==
- [op,a] := u
- MEMQ(a, $fieldNames) => formatSelection u
- atom op =>
- formatHasDotLeadOp a => formatOpPren(op,a)
- formatApplication0 u
- formatSelection u
-
-formatHasDotLeadOp u ==
- u is [op,:.] and (op = "." or cons? op)
-
-formatApplication0 u ==
---format as f(x) as f x if possible
- $pilesAreOkHere: local
- formatSpill("formatApplication1",u)
-
-formatApplication1 u ==
- [op,x] := u
- formatHasDollarOp x or $formatForcePren or
- pspadBindingPowerOf("left",x) < 1000 => formatOpPren(op,x)
- tryLine (formatOp op and format " ") and
- (tryLine formatApplication2 x or
- format "(" and formatApplication2 x and format ")")
-
-formatHasDollarOp x ==
- x is ["elt",a,b] and isTypeProbably? a
-
-isTypeProbably? x ==
- IDENTP x and upperCase? stringChar(symbolName x,0)
-
-formatOpPren(op,x) == formatOp op and formatPren x
-
-formatApplication2 x ==
- leadOp :=
- x is [['elt,.,y],:.] => y
- opOf x
- leadOp in '(COLLECT LIST construct) or
- pspadBindingPowerOf("left",x)<1000 => formatPren x
- format x
-
-formatDot ["dot",a,x] ==
- tryLine (formatOp a and format ".") and
- atom x => format x
- formatPren x
-
-formatSelection u ==
- $pilesAreOkHere: local
- formatSpill("formatSelection1",u)
-
-formatSelection1 [f,x] == formatSelectionOp f and format "." and
- atom x => format x
- formatPren x
-
-formatSelectionOp op ==
- op is [f,.] and not GETL(f,'Nud) or
- 1000 < pspadBindingPowerOf("right",op) => formatSelectionOp1 op
- formatPren1("formatSelectionOp1",op)
-
-formatSelectionOp1 f ==
- f is [op,:argl] =>
- argl is [a] =>
- cons? op and atom a => formatSelection1 [op,a]
- formatPren f
- format f
- formatOp f
-
-formatPren a ==
- $pilesAreOkHere: local
- formatSpill("formatPrenAux",a)
-
-formatPrenAux a == format "_(" and format a and format "_)"
-
-formatPren1(f,a) ==
- $pilesAreOkHere: local
- formatSpill2("formatPren1Aux",f,a)
-
-formatPren1Aux(f,a) == format "_(" and FUNCALL(f,a) and format "_)"
-
-formatLeft(fn,x,op,key) ==
- lbp:= formatOpBindingPower(op,key,"left")
- formatOpBindingPower(opOf x,key,"right")<lbp => formatPren1(fn,x)
- FUNCALL(fn,x)
-
-formatRight(fn,x,op,key) ==
- --are there exceptional cases where piles are ok?
- x is ["%LET",:.] => FUNCALL(fn,x)
- --decide on basis of binding power whether prens are needed
- rbp := formatOpBindingPower(op,key,"right")
- lbp := formatOpBindingPower(opOf x,key,"left")
- lbp < rbp => formatPren1(fn,x)
- FUNCALL(fn,x)
-
-formatCut a == formatSpill("format",a)
-
---======================================================================
--- Prefix/Infix Operators
---======================================================================
-formatPrefix(op,arg,lbp,rbp,:options) ==
- qualification := IFCAR options
- $pilesAreOkHere: local
- formatPrefixOp(op,qualification) and
- (rbp>formatGetBindingPowerOf("left",arg) => formatPren arg; format arg)
-
-formatPrefixOp(op,:options) ==
- qualification := IFCAR options
- op = char " " => format " ="
- qualification or GETL(op,"Nud") and not MEMQ(op,$spadTightList) =>
- formatQual(op,qualification) and format " "
- format op
-
-formatQual(op,D) ==
- null D => format op
- format op and format "$$" and format D
-
-formatInfix(op,[a,b],lbp,rbp,:options) ==
- qualification := IFCAR options
- $pilesAreOkHere: local
- (if formatGetBindingPowerOf("right",a)<lbp then formatPren a else format a) and
- formatInfixOp(op,qualification) and (if rbp>formatGetBindingPowerOf("left",b)
- then formatPren b else format b)
-
-formatGetBindingPowerOf(leftOrRight,x) ==
--- this function is nearly identical with getBindingPowerOf
--- leftOrRight = "left" => 0
--- 1
- pspadBindingPowerOf(leftOrRight,x)
-
-pspadBindingPowerOf(key,x) ==
- --binding powers can be found in file NEWAUX LISP
- x is ['REDUCE,:.] => (key='left => 130; key='right => 0)
- x is ["REPEAT",:.] => (key="left" => 130; key="right" => 0)
- x is ['%when,:.] => (key="left" => 130; key="right" => 0)
- x is [op,:argl] =>
- if op is [a,:.] then op:= a
- op = 'SLASH => pspadBindingPowerOf(key,["/",:argl]) - 1
- op = 'OVER => pspadBindingPowerOf(key,["/",:argl])
- (n:= #argl)=1 =>
- key="left" and (m:= pspadOpBindingPower(op,"Nud","left")) => m
- key="right" and (m:= pspadOpBindingPower(op,"Nud","right")) => m
- 1000
- n>1 =>
- key="left" and (m:= pspadOpBindingPower(op,"Led","left")) => m
- key="right" and (m:= pspadOpBindingPower(op,"Led","right")) => m
- op="ELT" => 1002
- 1000
- 1000
- 1002
-
-pspadOpBindingPower(op,LedOrNud,leftOrRight) ==
- if op in '(SLASH OVER) then op := "/"
- op in '(_:) and LedOrNud = 'Led =>
- leftOrRight = 'left => 195
- 196
- exception:=
- leftOrRight="left" => 0
- 105
- bp:=
- leftOrRight="left" => leftBindingPowerOf(op,LedOrNud)
- rightBindingPowerOf(op,LedOrNud)
- bp ~= exception => bp
- 1000
-
-formatOpBindingPower(op,key,leftOrRight) ==
- if op in '(SLASH OVER) then op := "/"
- op = '_$ => 1002
- op in '(_:) and key = 'Led =>
- leftOrRight = 'left => 195
- 196
- op in '(_~_= _>_=) => 400
- op = "not" and key = "Nud" =>
- leftOrRight = 'left => 1000
- 1001
- GETL(op,key) is [.,.,:r] =>
- leftOrRight = 'left => KAR r or 0
- KAR KDR r or 1
- 1000
-
-formatInfixOp(op,:options) ==
- qualification := IFCAR options
- qualification or
- (op ~= '_$) and not MEMQ(op,$spadTightList) => format " " and formatQual(op,qualification) and format " "
- format op
-
---======================================================================
--- Special Handlers: DEF forms
---======================================================================
-
-formatDEF def == formatDEF0(def,$DEFdepth + 1)
-
-formatDEF0(["DEF",form,tlist,sclist,body],$DEFdepth) ==
- if not (KAR form in '(Exports Implementation)) then
- $form :=
- form is [":",a,:.] => a
- form
- con := opOf $form
- $comments: local := SUBST('_$,'_%,getConstructorDocumentationFromDB con)
- $abb :local := getConstructorAbbreviationFromDB opOf $form
- if $DEFdepth < 2 then
- condoc := (u := LASSOC('constructor,$comments)) and KDR KAR u or ['""]
- $numberOfSpills := -1
- consComments(condoc,'"+++ ")
- form := formatDeftranForm(form,tlist)
- u := ["DEF",form,tlist,sclist,body]
- v := formatDEF1 u => v
- $insideDEF: local := $DEFdepth > 1
- $DEFdepth = 1 =>
- exname := 'Exports
- impname := 'Implementation
- form is [":",.,=exname] or body = impname => nil
- exports :=
- form is [":",a,b] =>
- form := a
- [["MDEF",exname,'(NIL),'(NIL),b]]
- nil
- [op,:argl] := form
--- decls := [x for x in argl | x is [":",:.]]
--- form := [op,:[(a is [":",b,t] => b; a) for a in argl]]
--- $DEFdepth := $DEFdepth - 1
- formatWHERE(["where",
- ["DEF",[":",form,exname],[nil for x in form],sclist,impname],
- ['PROGN,:exports,["MDEF",impname,'(NIL),'(NIL),body]]])
- $insideTypeExpression: local := true
- body := formatDeftran(body,false)
- body is ["add",a,:b] => formatAddDef(form,a,b)
---body is ["with",a,:b] => formatWithDef(form,a,b)
- tryBreakNB(format form and format " == ",body,"==","Led")
-
-formatDEF1 ["DEF",form,tlist,b,body] ==
- $insideDEF: local := $DEFdepth > 1
- $insideEXPORTS: local := form = 'Exports
- $insideTypeExpression: local := true
- form := formatDeftran(form,false)
- body := formatDeftran(body,false)
- ---------> terrible, hideous, but temporary, hack
- if not $insideDEF and body is ['SEQ,:.] then body := ["add", body]
- prefix := (opOf tlist = 'Category => "define "; nil)
- body is ["add",a,b] => formatAddDef(form,a,b)
- body is ["with",a,:b] => formatWithDef(form,a,b,"==",prefix)
- prefix =>
- tryBreak(format prefix and format form and format " == ",body,"==","Led")
- tryBreak(format form and format " == ",body,"==","Led")
-
-formatDefForm(form,:options) ==
- prefix := IFCAR options
- $insideTypeExpression : local := true
- form is [":",form1,["with",a,:b]] => formatWithDef(form1,a,b,":",prefix)
- prefix => format prefix and format form
- format form
-
-formatAddDef(form,a,b) ==
- $insideCAPSULE : local := true
- $insideDEF : local := false
- formatDefForm form or return nil
- $marginStack := [0]
- $m := $c := 0
- $insideTypeExpression : local := false
- cap := (b => b; "")
- tryBreakNB(newLine() and format "== " and formatLeft("format",a,"add","Led")
- and format " add ", cap,"add","Led")
-
-formatWithDef(form,a,b,separator,:options) ==
- prefix := IFCAR options
- $insideEXPORTS : local := true
- $insideCAPSULE : local := true
- $insideDEF : local := false
- $insideTypeExpression : local := false
- a1 := formatWithKillSEQ a
- b => tryBreakNB(formatDefForm(form,prefix) and format separator and format " with " and formatLeft("format",a,"with","Led")
- and format " with ",first b,"with","Led")
- tryBreak(formatDefForm(form,prefix) and format separator and format " with ",a1,"with","Nud")
-
-formatWithKillSEQ x ==
- x is ['SEQ,['exit,.,y]] => ['BRACE, y]
- x
-
-formatBrace ['BRACE, x] == format "{" and format x and format "}"
-
-formatWith ["with",a,:b] ==
- $pilesAreOkHere: local := true
- b =>
- tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led")
- tryBreak(format "with ",a,"with","Nud")
-
-formatWithDefault ["withDefault",a,b] ==
- if a is ['with,:init,["SEQ",:items,["exit",.,x]]] then
- part2 := ["SEQ",:items,x,["exit", nil,["defaultDefs", b]]]
- if IFCAR init then
- a:= IFCAR init
- b:= [part2]
- else
- a := part2
- b := nil
- $pilesAreOkHere: local := true
- b =>
- tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led")
- tryBreak(format "with ",a,"with","Nud")
-
-formatDefaultDefs ["default",a, :b] ==
- $insideCAPSULE : local := true
- $insideDEF : local := false
- $insideTypeExpression : local := false
- b =>
- tryBreak(formatLeft("format",a,"default","Led") and
- format " default ", first b,"default","Led")
- tryBreak(format "default ",a,"default","Nud")
---format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace
-
-formatAdd ["add",a,:b] ==
- $insideCAPSULE : local := true
- $insideDEF : local := false
- $insideTypeExpression : local := false
- b =>
- tryBreakNB(formatLeft("format",a,"and","Led") and
- format " and ", first b,"and","Led")
- tryBreakNB(format "add ",a,"and","Nud")
---format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace
-
-formatMDEF ["MDEF",form,.,.,body] ==
- form is '(Rep) => formatDEF ["DEF",form,nil,nil,body]
- $insideEXPORTS: local := form = 'Exports
- $insideTypeExpression: local := true
- body := formatDeftran(body,false)
- name := opOf form
- tryBreakNB(format name and format " ==> ",body,"==","Led")
- and ($insideCAPSULE and $c or format(";"))
-
-insideCat() == $insideCategoryIfTrue and not $insideFunctorIfTrue
- or $noColonDeclaration
-
-formatImport ["import",a] ==
- addFieldNames a
- addFieldNames macroExpand(a,$e)
- format "import from " and formatLocal1 a
-
-addFieldNames a ==
- a is [op,:r] and op in '(Record Union) =>
- $fieldNames := union(getFieldNames r,$fieldNames)
- a is ['List,:b] => addFieldNames b
- nil
-
-getFieldNames r ==
- r is [[":",a,b],:r] => [a,:getFieldNames r]
- nil
-
-formatLocal ["local",a] == format "local " and formatLocal1 a
-
-formatLocal1 a ==
- $insideTypeExpression: local := true
- format a
-
diff --git a/src/interp/pspad2.boot b/src/interp/pspad2.boot
deleted file mode 100644
index b0a0250a..00000000
--- a/src/interp/pspad2.boot
+++ /dev/null
@@ -1,663 +0,0 @@
--- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
--- All rights reserved.
--- Copyright (C) 2007-2011, 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 pspad1
-namespace BOOT
-
---======================================================================
--- Constructor Transformation Functions
---======================================================================
-formatDeftranForm(form,tlist) ==
- [ttype,:atypeList] := tlist
- if form is [":",f,t] then
- form := f
- ttype := t
- if form is ['elt,a,b] then ----> a.b ====> apply(b,a)
- form :=
- isTypeProbably? a =>
- atypeList := reverse atypeList
- ["$$", b, a]
- ["apply",a, b]
- op := KAR form
- argl := KDR form
- if or/[t for t in atypeList] then
- form := [op,:[(t => [":",a,t]; a) for a in argl for t in atypeList]]
- if ttype then form := [":",form,ttype]
- form
-
-formatDeftran(u,SEQflag) ==
- u is ['Join,:x] => formatDeftranJoin(u,SEQflag)
- u is ['CATEGORY,kind,:l,x] => formatDeftran(['with,['SEQ,:l,['exit,n,x]]],SEQflag)
- u is ['CAPSULE,:l,x] => formatDeftranCapsule(l,x,SEQflag)
- u is [op,:.] and op in '(rep per) => formatDeftranRepper(u,SEQflag)
- u is [op,:.] and op in '(_: _:_: _pretend _@) =>
- formatDeftranColon(u,SEQflag)
- u is ['PROGN,:l,x] => formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag)
- u is ['SEQ,:l,[.,n,x]] =>
- v := [:l,x]
- a := append/[formatDeftranSEQ(x,true) for x in l]
- b := formatDeftranSEQ(x,false)
- if b is [:.,c] and c = '(void) then b := DROP(-1, b)
- [:m,y] := [:a,:b]
- ['SEQ,:m,['exit,n,y]]
--- u is ['not,arg] and (op := LASSOC(KAR arg,'((_= . _~_=) (_< . _>_=)))) =>
--- formatDeftran([op,:rest arg],nil)
- u is ["^",a] => formatDeftran(['not,a],SEQflag)
- u is ["exquo",a,b] => formatDeftran(['xquo,a,b],SEQflag)
- u is ['IF,a,b,c] =>
- a := formatDeftran(a,nil)
- b := formatDeftran(b,nil)
- c := formatDeftran(c,nil)
- null SEQflag and $insideDEF =>
- [:y,last] := formatDeftranIf(a,b,c)
- ['SEQ,:y,['exit,1,last]]
- ['IF,a,b,c]
- u is ['Union,:argl] =>
- ['Union,:[x for a in argl
- | x := (string? a => [":",makeSymbol a,'Branch]; formatDeftran(a,nil))]]
- u is [op,:itl,body] and op in '(REPEAT COLLECT) and
- ([nitl,:nbody] := formatDeftranREPEAT(itl,body)) =>
- formatDeftran([op,:nitl,nbody],SEQflag)
- u is [":",a,b] => [":",formatDeftran(a,nil),formatDeftran(markMacroTran(b),nil)]
- u is ["DEF",:.] => formatCapsuleFunction(u)
- u is [op,:argl]=>[formatDeftran(op,nil),:[formatDeftran(x,nil) for x in argl]]
- u = 'nil => 'empty
- u
-
-formatCapsuleFunction ["DEF",form,tlist,b,body] ==
- $insideDEF : local := true
- ["DEF", formatDeftran(form,nil),tlist,b,formatDeftran(body,nil)]
-
-formatDeftranCapsule(l,x,SEQflag) ==
- $insideCAPSULE: local := true
- formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag)
-
-formatDeftranRepper([op,a],SEQflag) ==
- a is [op1,b] and op1 in '(rep per) =>
- op = op1 => formatDeftran(a,SEQflag)
- formatDeftran(b,SEQflag)
- a is ["::",b,t] =>
- b := formatDeftran(b,SEQflag)
- t := formatDeftran(t,SEQflag)
- a := ["::",b,t]
- op = "per" and t = "$" or op = "rep" and t = "Rep" => a
- [op,a]
- a is ['SEQ,:r] => ['SEQ,:[formatSeqRepper(op,x) for x in r]]
- a is ['IF,p,b,c] =>
- formatDeftran(['IF,p,[op,b],[op, c]], SEQflag)
- a is ["%LET",a,b] => formatDeftran(["%LET",a,[op,b]],SEQflag)
- a is ['not,[op,a,b]] and (op1 := LASSOC(op,$pspadRelationAlist)) =>
- formatDeftran([op1,a,b],SEQflag)
- a is ["return",n,r] =>
- opOf r in '(true false) => a
- ["return",n,[op,formatDeftran(r,SEQflag)]]
- a is ['error,:.] => a
- [op,formatDeftran(a,SEQflag)]
-
-formatDeftranColon([op,a,t],SEQflag) == --op is one of : :: pretend @
- a := formatDeftran(a,SEQflag)
- t := formatDeftran(t,SEQflag)
- a is ["UNCOERCE",b] => b
- a is [op1,b,t1] and t1 = t and op in '(_: _:_: _pretend _@) =>
- op1 = "pretend" or op = "pretend" => ["pretend",b,t]
- null SEQflag and op1 = ":" or op = ":" => ["pretend",b,t]
- a
- a is [=op,b,t1] =>
- t1 = t => a
- [op,b,t]
- t = "$" =>
- a is ['rep,b] => b
- a is ['per,b] => a
- [op,a,t]
- t = "Rep" =>
- a is ['per,b] => b
- a is ['rep,b] => a
- [op,a,t]
- [op,a,t]
-
-formatSeqRepper(op,x) ==
- x is ['exit,n,y] => ['exit,n,[op,formatDeftran(y,nil)]]
- x is ["=>",a,b] => ["=>",formatDeftran(a,nil),[op,formatDeftran(b,nil)]]
- atom x => x
- [formatSeqRepper(op,y) for y in x]
-
-formatDeftranJoin(u,SEQflag) ==
- ['Join,:cats,lastcat] := u
- lastcat is ['CATEGORY,kind,:l,x] =>
- cat :=
- rest cats => ['Join,:cats]
- first cats
- formatDeftran(['with,cat,['SEQ,:l,['exit,1,x]]],SEQflag)
- u
-
-formatENUM ['MyENUM, x] == format "'" and format x and format "'"
-
-formatDeftranREPEAT(itl,body) ==
---do nothing unless "itl" contains UNTIL statements
- u := [x for x in itl | x is ["UNTIL",p]] or return nil
- nitl := SETDIFFERENCE(itl,u)
- pred := MKPF([p for ['UNTIL,p] in u],'or)
- cond := ['IF,pred,["leave",n,nil],'%noBranch]
- nbody :=
- body is ['SEQ,:l,[.,n,x]] => ['SEQ,:l,x,['exit,n,cond]]
- ['SEQ,body,['exit,n,cond]]
- [nitl,:nbody]
-
-formatDeftranSEQ(x,flag) ==
- u := formatDeftran(x,flag)
- u is ['SEQ,:.] => rest u
- [u]
-
-formatDeftranIf(a,b,c) ==
- b = '%noBranch =>
- a is [op,:r] and (al := '((_= . _~_=) (_< . _>_=) (_> . _<_=));
- iop := LASSOC(op, al) or rassoc(op, al)) =>
- [["=>",[iop, :r],c]]
- a is [op,r] and op in '(NOT not NULL null) =>
- [["=>", r, c]]
- [["=>", ['not, a], c]]
- post :=
- c = '%noBranch => nil
- c is ['SEQ,:.] => rest c
- [c]
- [["=>",a,b],:post]
-
-formatWHERE ["where",a,b] ==
- $insideTypeExpression: local := nil
- $insideCAPSULE: local := false
- tryBreak(formatLeft("format",a,"where","Led") and format " where ",b,"where","Led")
-
---======================================================================
--- Special Handlers: Categories
---======================================================================
-formatATTRIBUTE ['ATTRIBUTE,att] == format att
-
-formatDeftranCategory ['CATEGORY,kind,:items,item] == ["SEQ",:items,["exit",1,item]]
-
-formatCategory ['Category] == format " " and format "Category"
-
-formatCATEGORY cat ==
- con := opOf $form
- $comments: local := SUBST('_$,'_%,getConstructorDocumentationFromDB con)
- $insideEXPORTS : local := true
- format ["with",formatDeftranCategory cat]
-
-formatSIGNATURE ['SIGNATURE,op,types,:r] ==
- 'constant in r => format op and format ": " and (u := format first types) and
- formatSC() and formatComments(u,op,types)
- format op and format ": " and (u := format ['Mapping,:types]) and formatSC() and
- formatComments(u,op,types)
-
-formatDefault ["default",a] ==
- $insideCategoryIfTrue : local := false
- $insideCAPSULE: local := true
- $insideTypeExpression: local := false
- tryBreak(format "default ",a,"with","Nud")
---======================================================================
--- Special Handlers: Control Structures
---======================================================================
-formatUNCOERCE ['UNCOERCE,x] == format x
-
-formatIF ['IF,a,b,c] ==
- c = '%noBranch => formatIF2(a,b,"if ")
- b = '%noBranch => formatIF ['IF,['not,a],c,'%noBranch]
- formatIF2(a,b,"if ") and newLine() and formatIF3 c
-
-formatIF2(a,b,prefix) ==
- tryBreakNB(format prefix and format a and format " then ",b,"then","Nud")
-
-formatIF3 x ==
- x is ['IF,a,b,c] =>
- c = '%noBranch => tryBreak(format "else if "
- and format a and format " then ",b,"then","Nud")
- formatIF2(a,b,"else if ") and newLine() and formatIF3 c
- tryBreak(format "else ",x,"else","Nud")
-
-formatBlock(l,x) ==
- null l => format x
- $pilesAreOkHere: local
- format "{ " and format first l and
- (and/[formatSC() and format y for y in rest l])
- and formatSC() and format x and format " }"
-
-formatExit ["exit",.,u] == format u
-
-formatvoid ["void"] == format "()"
-
-formatLeave ["leave",.,u] == format "break"
-
-formatCOLLECT u == formatSpill("formatCOLLECT1",u)
-
-formatCOLLECT1 ["COLLECT",:iteratorList,body] ==
- $pilesAreOkHere: local
- format "[" and format body and format " " and
- formatSpill("formatIteratorTail",iteratorList)
-
-formatIteratorTail iteratorList ==
- formatIterator first iteratorList and
- (and/[format " " and formatIterator x for x in rest iteratorList]) and format "]"
-
---======================================================================
--- Special Handlers: Keywords
---======================================================================
-
-formatColon [":",a,b] ==
- b is ['with,c,:d] => formatColonWith(a,c,d)
- if not $insideTypeExpression then
- insideCat() => nil
- format
- $insideDEF => "local "
- "default "
- op :=
- $insideCAPSULE and not $insideDEF => ": "
- insideCat() => ": "
- ":"
- b := (atom b => b; markMacroTran b)
- a is ['LISTOF,:c] => formatComma c and format ": " and formatLocal1 b
- formatInfix(op,[a, b],formatOpBindingPower(":","Led","left"),
- formatOpBindingPower(":","Led","right"))
-
-formatColonWith(form,a,b) ==
- con := opOf $form
- $comments: local := SUBST('_$,'_%,getConstructorDocumentationFromDB con)
- $insideEXPORTS : local := true
- $pilesAreOkHere: local := true
- $insideTypeExpression : local := false
- b => tryBreak(formatDefForm form and format ": "
- and format a and format " with ",first b,"with","Led")
- tryBreak(formatDefForm form and format ": with ",a,"with","Nud")
-
-formatCOND ['%when,:l] ==
- originalC:= $c
- and/[x is [a,[.,.,b]] for x in l] =>
- (originalC=$m or indent() and newLine()) and first l is [a,[.,.,b]] and
- formatIfExit(a,b) and
- (and/[newLine() and formatIfExit(a,b) for [a,[.,.,b]] in rest l]) and (originalC=$m or undent()) and originalC
- formatIfThenElse l
-
-formatPROGN ["PROGN",:l] ==
- l is [:u,x] => formatPiles(u,x)
- error '"formatPROGN"
-
-formatELT ["ELT",a,b] == formatApplication [a,b]
-
-formatCONS ["CONS",a,b] ==
- $pilesAreOkHere: local
- format "[" and formatConstructItem a and formatTail b
-
-formatTail x ==
- null x => format "]"
- format "," and formatTail1 x
-
-formatTail1 x ==
- x is ["CONS",a,b] => formatConstructItem a and formatTail b
- x is ["APPEND",a,b] =>
- null b => formatConstructItem a and format "]"
- format ":" and formatConstructItem a and formatTail b
- format ":" and formatConstructItem x and format "]"
-
-formatConstructItem x == format x
-
-formatLET ["%LET",a,b] ==
- $insideTypeExpression: local := true
- a = "Rep" or atom a and constructor? opOf b =>
- tryBreakNB(formatAtom a and format " == ",b,":=","Led")
- tryBreakNB((IDENTP a => formatAtom a; format a) and format " := ",b,":=","Led")
-
-formatIfExit(a,b) ==
- --called from SCOND or COND only
- $numberOfSpills: local:= 0
- curMargin:= $m
- curMarginStack:= $currentMarginStack
- $doNotResetMarginIfTrue:= true
- format a and format " => " and formatRight("formatCut",b,"=>","Led") =>
- ($currentMarginStack:= curMarginStack; $m:= curMargin)
-
-formatIfThenElse x == formatSpill("formatIf1",x)
-
-formatIf1 x ==
- x is [[a,:r],:c] and null c =>
- b:=
- r is [:l,s] and l => ['SEQ,:l,['exit,nil,s]]
- first r
- isTrue a => format b
- format "if " and format a and format " then " and format b
- format "if " and format a and
- (tryLine
- (format " then " and format b and format " else "
- and formatIfThenElse c) or spillLine()
- and format " then " and format b and
--- ($c:= $m:= $m+6) and
- ($numberOfSpills:= $numberOfSpills-1)
- and spillLine() and format " else " and formatIfThenElse c)
-
-formatQUOTE ["QUOTE",x] == format "('" and format x and format ")"
-
-formatMI ["MI",a,b] == format a
-
-formatMapping ['Mapping,target,:sources] ==
- $noColonDeclaration: local := true
- formatTuple ['Tuple,:sources] and format " -> " and format target
-
-formatTuple ['Tuple,:types] ==
- null types => format "()"
- null rest types => format first types
- formatFunctionCallTail types
-
-formatConstruct(['construct,:u]) ==
- format "[" and (null u or format first u and
- "and"/[format "," and formatCut x for x in rest u]) and format "]"
-
-formatNextConstructItem x ==
- tryLine format x or ($m := $m + 2) and newLine() and format x
-
-formatREPEAT ["REPEAT",:iteratorList,body] ==
- tryBreakNB(null iteratorList or (formatIterator first iteratorList and
- (and/[format " " and formatIterator x for x in rest iteratorList]) and format " ")
- and format "repeat ",body,"repeat","Led")
-
-formatFATARROW ["=>",a,b] == tryBreak(format a and format " => ",b,"=>","Led")
-
-formatMap ["+->",a,b] ==
- $noColonDeclaration: local := true
- tryBreak(format a and format " +-> ", b, "+->","Led")
-
-formatREDUCE ["REDUCE",op,.,u] == formatReduce1(op,u)
-
-formatreduce ["reduce",op,u] == formatReduce1(op,u)
-
-formatReduce1(op,u) ==
- if string? op then op := makeSymbol op
- id := LASSOC(op,
- '((_+ Zero)(_* One)(append . NIL)(gcd Zero) (lcm One) (strconc . "")(lcm One)))
- formatFunctionCall
- id => ['reduce,op,u,id]
- ['reduce,op,u]
-
-formatIterator u ==
- $noColonDeclaration : local := true
- u is ["IN",x,y] =>
- format "for " and formatLeft("format",x,"in","Led") and format " in " and
- formatRight("format",y,"in","Led")
- u is ["WHILE",x] => format "while " and formatRight("format",x,"while","Nud")
- u is ["UNTIL",x] => format "until " and formatRight("format",x,"until","Nud")
- u is ["|",x] => format "| " and formatRight("format",x,"|","Led")
- u is ["STEP",i,init,step,:v] =>
- final := IFCAR v
- format "for " and formatLeft("format",i,"in","Led") and format " in " and
- (seg := ['SEGMENT,init,final]) and (formatStepOne? step => format seg; formatBy ['by,seg,step])
- error "formatIterator"
-
-formatStepOne? step ==
- step = 1 or step = '(One) => true
- step is [op,n,.] and op in '(_:_: _@) => n = 1 or n = '(One)
- false
-
-formatBy ['by,seg,step] == format seg and format " by " and format step
-
-formatSCOND ["SCOND",:l] ==
- $pilesAreOkHere =>
- --called from formatPileLine or formatBlock
- --if from formatPileLine
- initialC:= $c
- and/[x is [a,["exit",.,b]] for x in l] =>
- first l is [a,["exit",.,b]] and formatIfExit(a,b) and
- (and/[newLine() and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and initialC
- formatIfThenElse l and initialC
- and/[x is [a,["exit",.,b]] for x in l] =>
- first l is [a,["exit",.,b]] and formatIfExit(a,b) and
- (and/[format "; " and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and $c
- --warning: and/(...) returns T if there are no entries
- formatIfThenElse l
-
-formatSEGMENT ["SEGMENT",a,b] ==
- $pilesAreOkHere: local
- (if pspadBindingPowerOf("right",a)<750 then formatPren a else format a) and
- formatInfixOp ".." and
- (null b and $c or
- (if 750>pspadBindingPowerOf("left",b) then formatPren b else format b))
-
-formatSexpr x ==
- atom x =>
- null x or IDENTP x => consBuffer ident2PrintImage symbolName x
- consBuffer x
- spill("formatNonAtom",x)
-
-formatNonAtom x ==
- format "_(" and formatSexpr first x and
- (and/[format " " and formatSexpr y for y in rest x])
- and (y:= LASTATOM x => format " . "
- and formatSexpr y; true) and format "_)"
-
-formatCAPSULE ['CAPSULE,:l,x] ==
- $insideCAPSULE: local := true
- tryLine formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x)
-
-formatPAREN [.,:argl] == formatFunctionCallTail argl
-
-formatSEQ ["SEQ",:l,[.,.,x]] ==
- tryLine formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x)
-
---======================================================================
--- Comment Handlers
---======================================================================
-formatCOMMENT ["COMMENT",x,marg,startXY,endXY,commentStack] ==
- $commentsToPrint:= [[marg,startXY,endXY,commentStack],:$commentsToPrint]
- format x
-
-formatComments(u,op,types) ==
- $numberOfSpills :local := $commentIndentation/2 - 1
- not $insideEXPORTS => u
- alist := LASSOC(op,$comments) or
- sayBrightly ['"No documentation for ",op]
- return u
- ftypes := SUBLISLIS($FormalMapVariableList,rest $form,types)
- consComments(LASSOC(ftypes,alist),'"++ ")
- u
-
-consComments(s,plusPlus) ==
- s is [word,:r] and cons? r => consComments(r, plusPlus)
- s := first s
- null s => nil
- s := consCommentsTran s
- indent() and newLine() or return nil
- columnsLeft := $lineLength - $m - 2
- while (m := MAXINDEX s) >= columnsLeft repeat
- k := or/[i for i in (columnsLeft - 1)..1 by -1 | s.i = $charBlank]
- k := (k => k + 1; columnsLeft)
- piece := subString(s,0,k)
- formatDoCommentLine [plusPlus,piece]
- s := subString(s,k)
- formatDoCommentLine [plusPlus,s]
- undent()
- $m
-
-consCommentsTran s ==
- m := MAXINDEX s
- k := or/[i for i in 0..(m - 7) | substring?('"\spad{",s,i)] =>
- r := charPosition(char '_},s,k + 6)
- r = m + 1 => s
- strconc(subString(s,0,k),'"`",subString(s,k+6,r-k-6),'"'",consCommentsTran subString(s,r+1))
- s
-
-formatDoCommentLine line ==
- $lineBuffer := consLineBuffer [nBlanks $c,:line]
- $c := $m+2*$numberOfSpills
-
---======================================================================
--- Pile Handlers
---======================================================================
-formatPreferPile y ==
- y is ["SEQ",:l,[.,.,x]] =>
- (u:= formatPiles(l,x)) => u
- formatSpill("format",y)
- formatSpill("format",y)
-
-formatPiles(l,x) ==
- $insideTypeExpression : local := false
- not $pilesAreOkHere => nil
- originalC:= $c
- lines:= [:l,x]
- --piles must begin at margin
- originalC=$m or indent() and newLine() or return nil
- null (formatPileLine($m,first lines,false)) => nil
- not (and/[formatPileLine($m,y,true) for y in rest lines]) => nil
- (originalC=$m or undent()) and originalC --==> brace
-
-formatPileLine($m,x,newLineIfTrue) ==
- if newLineIfTrue then newLine() or return nil
- $numberOfSpills: local:= 0
- $newLineWritten := nil
- format x and (x is ['SIGNATURE,:.] or $rightBraceFlag => $c; formatSC())
- and (x is ['DEF,:.] and optNewLine() or $c)
-
---======================================================================
--- Utility Functions
---======================================================================
-nBlanks m == strconc/['" " for i in 1..m]
-
-isNewspadOperator op == GETL(op,"Led") or GETL(op,"Nud")
-
-isTrue x == x="true" or x = '%true
-
-nary2Binary(u,op) ==
- u is [a,b,:t] => (t => nary2Binary([[op,a,b],:t],op); [op,a,b])
- errhuh()
-
-string2PrintImage s ==
- u:= GETSTR (2*# s)
- for i in 0..MAXINDEX s repeat
- (if s.i in '(_( _{ _) _} _! _") then
- SUFFIX('__,u); u:= SUFFIX(s.i,u))
- u
-
-ident2PrintImage s ==
- m := MAXINDEX s
- if m > 1 and s.(m - 1) = $underScore then s := strconc(subString(s,0,m-1),s.m)
- u:= GETSTR (2*# s)
- if not (alphabetic? s.0 or s.0 = char "$") then SUFFIX('__,u)
- u:= SUFFIX(s.0,u)
- for i in 1..MAXINDEX s repeat
- if not (digit? s.i or alphabetic? s.i or ((c := s.i) = char '?)
- or (c = char '_!)) then SUFFIX('__,u)
- u:= SUFFIX(s.i,u)
- makeSymbol u
-
-isIdentifier x ==
- IDENTP x =>
- s:= symbolName x
- #s = 0 => nil
- alphabetic? s.0 => and/[s.i ~= char " " for i in 1..MAXINDEX s]
- #s>1 =>
- or/[alphabetic? s.i for i in 1..(m:= MAXINDEX s)] =>
- and/[s.i ~= char " " for i in 1..m] => true
-
-isGensym x ==
- s := STRINGIMAGE x
- n := MAXINDEX s
- s.0 = char '_G and and/[digit? s.i for i in 1..n]
-
---======================================================================
--- Macro Helpers
---======================================================================
-tryToFit(s,x) ==
---% try to format on current line; see macro tryLine in file PSPADAUX LISP
- --returns nil if unable to format stuff in x on a single line
- x => ($back:= rest $back; $c)
- restoreState()
- nil
-
-restoreState(:options) ==
- back := IFCAR options or $back
- [
- [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth,
- $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :back]
- := back
- if null options then $back := back
- [$newLineWritten, $autoLine, $rightBraceFlag,
- $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere,
- $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue,
- $doNotResetMarginIfTrue,$noColonDeclaration]
- := flags
- nil
-
-saveState(:options) ==
- flags :=
- [$newLineWritten, $autoLine, $rightBraceFlag,
- $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere,
- $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue,
- $doNotResetMarginIfTrue,$noColonDeclaration]
- newState :=
- [
- [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth,
- $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :$back]
- if not KAR options then $back := newState
- newState
-
-formatSC() ==
- $pileStyle or $semicolonFlag => $c
- format "; "
-
-wrapBraces(x,y,z) == y
-
-formatLB() ==
- $pileStyle => $c
- $numberOfSpills :=
- $c > $lineLength / 2 => $braceIndentation/3 - 1
- $braceIndentation/2 - 1
- format "{"
-
-restoreC() == --used by macro "embrace"
- originalC := first $braceStack
- $braceStack := rest $braceStack
- formatRB originalC
-
-saveC() == --used by macro "embrace"
- $braceStack := [$c,:$braceStack]
-
-saveD() == --used by macro "embrace"
- $braceStack := [$c,:$braceStack]
-
-restoreD() == --used by macro "indentNB"
- originalC := CAR $braceStack
- $braceStack := rest $braceStack
- originalC
-
-formatRB(originalC) == --called only by restoreC
- while $marginStack and $m > originalC repeat undent()
- if $m < originalC then $marginStack := [originalC,:$marginStack]
- $m := originalC
- $pileStyle => $m
- newLine() and format "}" and $m --==> brace
-
diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp
index 8410f52e..2c2a01ee 100644
--- a/src/interp/spad.lisp
+++ b/src/interp/spad.lisp
@@ -325,24 +325,6 @@
(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|)))
-
(defun SETELTFIRST (A B C) (declare (ignore b)) (RPLACA A C))
(defun SETELTREST (A B C) (declare (ignore b)) (RPLACD A C))
diff --git a/src/interp/util.lisp b/src/interp/util.lisp
index dac184e8..9ba4839e 100644
--- a/src/interp/util.lisp
+++ b/src/interp/util.lisp
@@ -243,14 +243,6 @@
;; directory from the current {\bf AXIOM} shell variable.
(defvar $relative-library-directory-list '("/algebra/"))
-;; This is a little used subsystem to generate {\bf ALDOR} code
-;; from {\bf Spad} code. Frankly, I'd be amazed if it worked.
-(defparameter 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
@@ -356,7 +348,7 @@
;; 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 (translate-files asauto-files)
+(defun build-interpsys (asauto-files)
(reroot)
(|resetWorkspaceVariables|)
(|AxiomCore|::|%sysInit|)
@@ -368,7 +360,6 @@
(create-initializers)
(|start| :fin)
(setq *load-verbose* nil)
- (|setBootAutloadProperties| translate-functions translate-files)
(|setBootAutloadProperties| asauto-functions asauto-files)
(|fillDatabasesInCore|) ; the databases into core, then close the streams
(|closeAllDatabaseStreams|)
diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot
deleted file mode 100644
index a584b351..00000000
--- a/src/interp/wi1.boot
+++ /dev/null
@@ -1,1250 +0,0 @@
--- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
--- All rights reserved.
--- Copyright (C) 2007-2011, 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 macros
-namespace BOOT
-
--- !! do not delete the next function !
-
-spad2AsTranslatorAutoloadOnceTrigger() == nil
-
---======================================================================
--- Temporary definitions---for tracing and debugging
---======================================================================
-$convertingSpadFile := false
-tr fn ==
- $convertingSpadFile : local := true
- $options: local := nil
- sfn := STRINGIMAGE fn
- newname := strconc(sfn,'".as")
- $outStream :local := MAKE_-OUTSTREAM newname
- markSay '"#pile"
- markSay('"#include _"axiom.as_"")
- markTerpri()
- CATCH($SpadReaderTag,compiler [makeSymbol sfn])
- SHUT $outStream
-
-ppFull x ==
- SETQ(_*PRINT_-LEVEL_*,nil)
- SETQ(_*PRINT_-LENGTH_*,nil)
- pp x
-
-put(x,prop,val,e) ==
---if prop = 'mode and CONTAINED('PART,val) then foobar val
- $InteractiveMode and not EQ(e,$CategoryFrame) =>
- putIntSymTab(x,prop,val,e)
- --e must never be $CapsuleModemapFrame
- cons? x => put(first x,prop,val,e)
- newProplist:= augProplistOf(x,prop,val,e)
- prop="modemap" and $insideCapsuleFunctionIfTrue=true =>
- SAY ["**** modemap PUT on CapsuleModemapFrame: ",val]
- $CapsuleModemapFrame:=
- addBinding(x,augProplistOf(x,"modemap",val,$CapsuleModemapFrame),
- $CapsuleModemapFrame)
- e
- addBinding(x,newProplist,e)
-
-addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) ==
---if CONTAINED('PART,proplist) then foobar proplist
- EQ(proplist,getProplist(var,e)) => e
- $InteractiveMode => addBindingInteractive(var,proplist,e)
- if curContour is [[ =var,:.],:.] then curContour:= rest curContour
- --Previous line should save some space
- [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist]
-
-
-pmatch(s,p) == pmatchWithSl(s,p,"ok")
-
-pmatchWithSl(s,p,al) ==
- s=$EmptyMode => nil
- s=p => al
- v:= assoc(p,al) => s=rest v or al
- MEMQ(p,$PatternVariableList) => [[p,:s],:al]
- cons? p and cons? s and (al':= pmatchWithSl(first s,first p,al)) and
- pmatchWithSl(rest s,rest p,al')
-
---======================================================================
--- From define.boot
---======================================================================
-compJoin(["Join",:argl],m,e) ==
- catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl]
- catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil)
- catList':=
- [extract for x in catList] where
- extract() ==
- x := markKillAll x
- isCategoryForm(x,e) =>
- parameters:=
- union("append"/[getParms(y,e) for y in rest x],parameters)
- where getParms(y,e) ==
- atom y =>
- isDomainForm(y,e) => [y]
- nil
- y is ['LENGTH,y'] => [y,y']
- LIST y
- x
- x is ["DomainSubstitutionMacro",pl,body] =>
- (parameters:= union(pl,parameters); body)
- x is ["mkCategory",:.] => x
- atom x and getmode(x,e)=$Category => x
- stackSemanticError(["invalid argument to Join: ",x],nil)
- x
- T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e]
- convert(T,m)
-
-
-compDefineFunctor(dfOriginal,m,e,prefix,fal) ==
- df := markInsertParts dfOriginal
- $domainShell: local -- holds the category of the object being compiled
- $profileCompiler: local := true
- $profileAlist: local := nil
- $LISPLIB => compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1)
- compDefineFunctor1(df,m,e,prefix,fal)
-
-compDefineLisplib(df,m,e,prefix,fal,fn) ==
- ["DEF",[op,:.],:.] := df
- --fn= compDefineCategory OR compDefineFunctor
- sayMSG fillerSpaces(72,'"-")
- $LISPLIB: local := 'T
- $op: local := op
- $lisplibAttributes: local := NIL
- $lisplibPredicates: local := NIL -- set by makePredicateBitVector
- $lisplibForm: local := NIL
- $lisplibKind: local := NIL
- $lisplibModemap: local := NIL
- $lisplibModemapAlist: local := NIL
- $lisplibSlot1 : local := NIL -- used by NRT mechanisms
- $lisplibOperationAlist: local := NIL
- $lisplibSuperDomain: local := NIL
- $libFile: local := NIL
- $lisplibVariableAlist: local := NIL
- $lisplibRelatedDomains: local := NIL --from ++ Related Domains: see c-doc
- $lisplibCategory: local := nil
- --for categories, is rhs of definition; otherwise, is target of functor
- --will eventually become the "constructorCategory" property in lisplib
- --set in compDefineCategory if category, otherwise in finalizeLisplib
- libName := getConstructorAbbreviation op
- $compileDocumentation => compileDocumentation libName
- sayMSG ['" initializing ",$spadLibFT,:bright libName,
- '"for",:bright op]
- initializeLisplib libName
- sayMSG ['" compiling into ",$spadLibFT,:bright libName]
- res:= FUNCALL(fn,df,m,e,prefix,fal)
- sayMSG ['" finalizing ",$spadLibFT,:bright libName]
---finalizeLisplib libName
- FRESH_-LINE $algebraOutputStream
- sayMSG fillerSpaces(72,'"-")
- unloadOneConstructor(op,libName)
- res
-
-compTopLevel(x,m,e) ==
---+ signals that target is derived from lhs-- see NRTmakeSlot1Info
- $NRTderivedTargetIfTrue: local := false
- $killOptimizeIfTrue: local:= false
- $forceAdd: local:= false
- -- The next line allows the new compiler to be tested interactively.
- compFun := 'compOrCroak
- if x is ["where",:.] then x := markWhereTran x
- def :=
- x is ["where",a,:.] => a
- x
- $originalTarget : local :=
- def is ["DEF",.,[target,:.],:.] => target
- 'sorry
- x is ["DEF",:.] or x is ["where",["DEF",:.],:.] =>
- ([val,mode,.]:= FUNCALL(compFun,x,m,e); [val,mode,e])
- --keep old environment after top level function defs
- FUNCALL(compFun,x,m,e)
-
-markWhereTran ["where",["DEF",form,sig,clist,body],:tail] ==
- items :=
- tail is [['SEQ,:l,['exit,n,x]]] => [:l,x]
- [first tail]
- [op,:argl] := form
- [target,:atypeList] := sig
- decls := [[":",a,b] for a in argl for b in atypeList | b]
--- not (and/[null x for x in atypeList]) =>
--- systemError ['"unexpected WHERE argument list: ",:atypeList]
- for x in items repeat
- x is [":",a,b] =>
- a is ['LISTOF,:r] =>
- for y in r repeat decls := [[":",y,b],:decls]
- decls := [x,:decls]
- x is [key,fn,p,q,bd] and key in '(DEF MDEF) and p='(NIL) and q='(NIL) =>
- fn = target or fn is [=target] => ttype := bd
- fn = body or fn is [=body] => body := bd
- macros := [x,:macros]
- systemError ['"unexpected WHERE item: ",x]
- nargtypes := [p for arg in argl |
- p := or/[t for d in decls | d is [.,=arg,t]] or
- systemError ['"Missing WHERE declaration for :", arg]]
- nform := form
- ntarget := ttype or target
- ndef := ['DEF,nform,[ntarget,:nargtypes],clist,body]
- result :=
- reverse macros is [:m,e] =>
- mpart :=
- m => ['SEQ,:m,['exit,1,e]]
- e
- ['where,ndef,mpart]
- ndef
- result
-
-compPART(u,m,e) ==
---------new------------------------------------------94/10/11
- ['PART,.,x] := u
- T := comp(x,m,e) => markAny('compPART,u, T)
- nil
-
-xxxxx x == x
-
-qt(n,T) ==
- null T => nil
- if null getProplist('R,T.env) then xxxxx n
- T
-
-qe(n,e) ==
- if null getProplist('R,e) then xxxxx n
- e
-
-comp(x,m,e) ==
- qe(7,e)
- T := qt(8,comp0(x,m,e)) => qt(9,markComp(x,T))
---T := m = "$" and comp(x,$EmptyMode,e) => coerce(T, m)
- --------------------------------------------------------94/11/10
- nil
-
-comp0(x,m,e) ==
- qe(8,e)
---version of comp which skips the marking (see compReduce1)
- T:= compNoStacking(x,m,e) =>
- $compStack:= nil
- qt(10,T)
- $compStack:= [[x,m,e,$exitModeStack],:$compStack]
- nil
-
-compNoStacking(xOrig,m,e) ==
- $partExpression: local := nil
- xOrig := markKillAllRecursive xOrig
--->xOrig is ['PART,n,x] => compNoStackingAux(xOrig,m,e)
-----------------------------------------------------------94/10/11
- qt(11,compNoStacking0(xOrig,m,e))
-
-markKillAllRecursive x ==
- x is [op,:r] =>
---->op = 'PART => markKillAllRecursive second r
- op = 'PART => ['PART, first r, markKillAllRecursive second r]
-----------------------------------------------------------94/10/11
- constructor? op => markKillAll x
- op = 'elt and constructor? opOf first r =>
- ['elt,markKillAllRecursive first r,second r]
- x
- x
-
-compNoStackingAux($partExpression,m,e) ==
------------------not used---------------------94/10/11
- x := third $partExpression
- T := compNoStacking0(x,m,e) or return nil
- markParts($partExpression,T)
-
-compNoStacking0(x,m,e) ==
- qe(1,e)
- T := compNoStacking01(x,m,qe(51,e))
- qt(52,T)
-
-compNoStacking01(x,m,e) ==
---compNoStacking0(x,m,e) ==
- if CONTAINED('MI,m) then m := markKillAll(m)
- T:= comp2(x,m,e) =>
- (m=$EmptyMode and T.mode=IFCAR(get('Rep,'value,e)) =>
- [T.expr,"Rep",T.env]; qt(12,T))
- --$Representation is bound in compDefineFunctor, set by doIt
- --this hack says that when something is undeclared, $ is
- --preferred to the underlying representation -- RDJ 9/12/83
- T := compNoStacking1(x,m,e,$compStack)
- qt(13,T)
-
-compNoStacking1(x,m,e,$compStack) ==
- u:= get(if m="$" then "Rep" else m,"value",e) =>
- m1 := markKillAll u.expr
---------------------> new <-------------------------
- T:= comp2(x,m1,e) => coerce(T,m)
- nil
---------------------> new <-------------------------
- nil
-
-compWithMappingMode(x,m,oldE) ==
- ["Mapping",m',:sl] := m
- $killOptimizeIfTrue: local:= true
- e:= oldE
- x := markKillAll x
- ------------------
- m := markKillAll m
- ------------------
---if x is ['PART,.,y] then x := y
----------------------------------
- isFunctor x =>
- if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and
- (and/[extendsCategoryForm("$",s,mode) for mode in argModeList for s in sl]
- ) and extendsCategoryForm("$",target,m') then return [x,m,e]
- if string? x then x:= makeSymbol x
- for m in sl for v in (vl:= take(#sl,$FormalMapVariableList)) repeat
- [.,.,e]:= compMakeDeclaration(v,m,e)
- not null vl and not hasFormalMapVariable(x, vl) => return
- [u,.,.] := comp([x,:vl],m',e) or return nil
- extractCodeAndConstructTriple(u, m, oldE)
- null vl and (t := comp([x], m', e)) => return
- [u,.,.] := t
- extractCodeAndConstructTriple(u, m, oldE)
- [u,.,.]:= comp(x,m',e) or return nil
- originalFun := u
- if originalFun is ['WI,a,b] then u := b
- uu := ['LAMBDA,vl,u]
- T := [uu,m,oldE]
- originalFun is ['WI,a,b] => markLambda(vl,a,m,T)
- markLambda(vl,originalFun,m,T)
-
-compAtom(x,m,e) ==
- T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => markCompAtom(x,T)
- x="nil" =>
- T:=
- modeIsAggregateOf('List,m,e) is [.,R]=> compList(x,['List,R],e)
- modeIsAggregateOf('Vector,m,e) is [.,R]=> compVector(x,['Vector,R],e)
- T => convert(T,m)
--->
- integer? x and opOf m in '(Integer NonNegativeInteger PositiveInteger SmallInteger) => markAt [x,m,e]
--- integer? x and (T := [x, $Integer,e]) and (T' := convert(T,m)) => markAt(T, T')
- t:=
- IDENTP x => compSymbol(x,m,e) or return nil
- m = $OutputForm and primitiveType x => [x,m,e]
- string? x =>
- x ~= '"failed" and (member($Symbol, $localImportStack) or
- member($Symbol, $globalImportStack)) => markAt [x, '(String), e]
- [x, x, e]
- [x,primitiveType x or return nil,e]
- convert(t,m)
-
-extractCodeAndConstructTriple(u, m, oldE) ==
- u := markKillAll u
- u is ['%call,fn,:.] =>
- if fn is ["applyFun",a] then fn := a
- [fn,m,oldE]
- [op,:.,env] := u
- [["CONS",["function",op],env],m,oldE]
-
-compSymbol(s,m,e) ==
- s="$NoValue" => ["$NoValue",$NoValueMode,e]
- isFluid s => [s,getmode(s,e) or return nil,e]
- s="true" => ['%true,$Boolean,e]
- s="false" => ['%false,$Boolean,e]
- s=m or isLiteral(s,e) => [["QUOTE",s],s,e]
- v:= get(s,"value",e) =>
---+
- MEMQ(s,$functorLocalParameters) =>
- NRTgetLocalIndex s
- [s,v.mode,e] --s will be replaced by an ELT form in beforeCompile
- [s,v.mode,e] --s has been SETQd
- m':= getmode(s,e) =>
- if not MEMQ(s,$formalArgList) and not MEMQ(s,$FormalMapVariableList) and
- not isFunction(s,e) and null ($compForModeIfTrue=true) then errorRef s
- [s,m',e] --s is a declared argument
- MEMQ(s,$FormalMapVariableList) => stackMessage ["no mode found for",s]
---->
- m = $Symbol or m = $OutputForm => [['QUOTE,s],m,e]
- ---> was ['QUOTE, s]
- not isFunction(s,e) => errorRef s
-
-compForm(form,m,e) ==
- if form is [['PART,.,op],:r] then form := [op,:r]
- ----------------------------------------------------- 94/10/16
- T:=
- compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return
- stackMessageIfNone ["cannot compile","%b",form,"%d"]
- T
-
-compForm1(form,m,e) ==
- [op,:argl] := form
- op="error" =>
- [[op,:[([.,.,e]:=outputComp(x,e)).expr
- for x in argl]],m,e]
- op is ['MI,a,b] => compForm1([markKillExpr b,:argl],m,e)
- op is ["elt",domain,op'] =>
- domain := markKillAll domain
- domain="Lisp" =>
- --op'='QUOTE and null rest argl => [first argl,m,e]
- val := [op',:[([.,.,e]:= compOrCroak(x,$EmptyMode,e)).expr for x in argl]]
- markLisp([val,m,e],m)
--------> new <-------------
--- foobar domain
--- markImport(domain,true)
--------> new <-------------
- domain=$OutputForm and op'="construct" => compExpressionList(argl,m,e)
- (op'="COLLECT") and coerceable(domain,m,e) =>
- (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m))
--------> new <-------------
- domain= 'Rep and
- (ans := compForm2([op',:argl],SUBST('Rep,'_$,m),e:= addDomain(domain,e),
- [SUBST('Rep,'_$,x) for x in getFormModemaps([op',:argl],e)
- | x is [[ =domain,:.],:.]])) => ans
--------> new <-------------
- ans := compForm2([op',:argl],m,e:= addDomain(domain,e),
- [x for x in getFormModemaps([op',:argl],e) | x is [[ =domain,:.],:.]]) => ans
- (op'="construct") and coerceable(domain,m,e) =>
- (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m))
- nil
-
- e:= addDomain(m,e) --???unneccessary because of comp2's call???
- (mmList:= getFormModemaps(form,e)) and (T:= compForm2(form,m,e,mmList)) => T
- compToApply(op,argl,m,e)
-
---% WI and MI
-
-compForm3(form is [op,:argl],m,e,modemapList) ==
---order modemaps so that ones from Rep are moved to the front
- modemapList := compFormOrderModemaps(modemapList,m = "$")
- qe(22,e)
- T:=
- or/
- [compFormWithModemap(form,m,e,first (mml:= ml))
- for ml in tails modemapList] or return nil
- qt(14,T)
- result :=
- $compUniquelyIfTrue =>
- or/[compFormWithModemap(form,m,e,mm) for mm in rest mml] =>
- THROW("compUniquely",nil)
- qt(15,T)
- qt(16,T)
- qt(17,markAny('compForm3,form,result))
-
-compFormOrderModemaps(mml,targetIsDollar?) ==
---order modemaps so that ones from Rep are moved to the front
---exceptions: if $ is the target and there are 2 modemaps with
--- identical signatures, move the $ one ahead
- repMms := [mm for (mm:= [[dc,:.],:.]) in mml | dc = 'Rep]
- if repMms and targetIsDollar? then
- dollarMms := [mm for (mm := [[dc,:sig],:.]) in mml | dc = "$"
- and or/[mm1 for (mm1:= [[dc1,:sig1],:.]) in repMms | sig1 = sig]]
- repMms := [:dollarMms, :repMms]
- null repMms => mml
- [:repMms,:SETDIFFERENCE(mml,repMms)]
-
-compWI(["WI",a,b],m,E) ==
- u := comp(b,m,E)
- pp (u => "====> ok"; 'NO)
- u
-
-compMI(["MI",a,b],m,E) ==
- u := comp(b,m,E)
- pp (u => "====> ok"; 'NO)
- u
-
-compWhere([.,form,:exprList],m,eInit) ==
- $insideExpressionIfTrue: local:= false
- $insideWhereIfTrue: local:= true
--- if not $insideFunctorIfTrue then
--- $originalTarget :=
--- form is ['DEF,a,osig,:.] and osig is [otarget,:.] =>
--- exprList is [['SEQ,:l,['exit,n,y]]] and (u := [:l,y]) and
--- (ntarget := or/[def for x in u | x is [op,a',:.,def] and ([op,a',otarget]) and
--- op in '(DEF MDEF) and (a' = otarget or a' is [=otarget])]) =>
--- [ntarget,:rest osig]
--- osig
--- nil
--- foobum exprList
- e:= eInit
- u:=
- for item in exprList repeat
- [.,.,e]:= comp(item,$EmptyMode,e) or return "failed"
- u="failed" => return nil
- $insideWhereIfTrue:= false
- [x,m,eAfter]:= comp(macroExpand(form,eBefore:= e),m,e) or return nil
- eFinal:=
- del:= deltaContour(eAfter,eBefore) => addContour(del,eInit)
- eInit
- [x,m,eFinal]
-
-compMacro(form,m,e) ==
- $macroIfTrue: local:= true
- ["MDEF",lhs,signature,specialCases,rhs]:= form := markKillAll form
- firstForm := ["MDEF",first lhs,'(NIL),'(NIL),rhs]
- markMacro(first lhs,rhs)
- if $verbose then
- rhs :=
- rhs is ['CATEGORY,:.] => ['"-- the constructor category"]
- rhs is ['Join,:.] => ['"-- the constructor category"]
- rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"]
- rhs is ['add,:.] => ['"-- the constructor capsule"]
- formatUnabbreviated rhs
- sayBrightly ['" processing macro definition",'"%b",
- :formatUnabbreviated lhs,'" ==> ",:rhs,'"%d"]
- ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e)
- m=$EmptyMode or m=$NoValueMode =>
- ["/throwAway",$NoValueMode,putMacro(lhs.op,rhs,e)]
-
---compMacro(form,m,e) ==
--- $macroIfTrue: local:= true
--- ["MDEF",lhs,signature,specialCases,rhs]:= form
--- rhs :=
--- rhs is ['CATEGORY,:.] => ['"-- the constructor category"]
--- rhs is ['Join,:.] => ['"-- the constructor category"]
--- rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"]
--- rhs is ['add,:.] => ['"-- the constructor capsule"]
--- formatUnabbreviated rhs
--- sayBrightly ['" processing macro definition",'"%b",
--- :formatUnabbreviated lhs,'" ==> ",:rhs,'"%d"]
--- ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e)
--- m=$EmptyMode or m=$NoValueMode =>
--- rhs := markMacro(lhs,rhs)
--- ["/throwAway",$NoValueMode,putMacro(lhs.op,rhs,e)]
-
-compSetq(oform,m,E) ==
- ["%LET",form,val] := oform
- T := compSetq1(form,val,m,E) => markSetq(oform,T)
- nil
-
-compSetq1(oform,val,m,E) ==
- form := markKillAll oform
- IDENTP form => setqSingle(form,val,m,E)
- form is [":",x,y] =>
- [.,.,E']:= compMakeDeclaration(x,y,E)
- compSetq(["%LET",x,val],m,E')
- form is [op,:l] =>
- op="CONS" => setqMultiple(uncons form,val,m,E)
- op="%Comma" => setqMultiple(l,val,m,E)
- setqSetelt(oform,form,val,m,E)
-
-setqSetelt(oform,[v,:s],val,m,E) ==
- T:= comp0(["setelt",:oform,val],m,E) or return nil
----> -------
- markComp(oform,T)
-
-setqSingle(id,val,m,E) ==
- $insideSetqSingleIfTrue: local:= true
- --used for comping domain forms within functions
- currentProplist:= getProplist(id,E)
- m'':= get(id,'mode,E) or getmode(id,E) or
- (if m=$NoValueMode then $EmptyMode else m)
------------------------> new <-------------------------
- trialT := m'' = "$" and get("Rep",'value,E) and comp(val,'Rep,E)
------------------------> new <-------------------------
- T:=
- (trialT and coerce(trialT,m'')) or eval or return nil where
- eval() ==
- T:= comp(val,m'',E) => T
- not get(id,"mode",E) and m'' ~= (maxm'':=maximalSuperType m'') and
- (T:=comp(val,maxm'',E)) => T
- (T:= comp(val,$EmptyMode,E)) and getmode(T.mode,E) =>
- assignError(val,T.mode,id,m'')
- T':= [x,m',e']:= convert(T,m) or return nil
- if $profileCompiler = true then
- not IDENTP id => nil
- key :=
- MEMQ(id,rest $form) => 'arguments
- 'locals
- profileRecord(key,id,T.mode)
- newProplist:= consProplistOf(id,currentProplist,"value",markKillAll removeEnv T)
- e':= (cons? id => e'; addBinding(id,newProplist,e'))
- x1 := markKillAll x
- if isDomainForm(x1,e') then
- if isDomainInScope(id,e') then
- stackWarning ["domain valued variable","%b",id,"%d",
- "has been reassigned within its scope"]
- e':= augModemapsFromDomain1(id,x1,e')
- --all we do now is to allocate a slot number for lhs
- --e.g. the LET form below will be changed by putInLocalDomainReferences
---+
- if (k:=NRTassocIndex(id))
- then
- $markFreeStack := [id,:$markFreeStack]
- form:=['%store,['%tref,"$",k],x]
- else form:=
- ["%LET",id,x]
- [form,m',e']
-
-setqMultiple(nameList,val,m,e) ==
- val is ["CONS",:.] and m=$NoValueMode =>
- setqMultipleExplicit(nameList,uncons val,m,e)
- val is ["%Comma",:l] and m=$NoValueMode => setqMultipleExplicit(nameList,l,m,e)
- --1. create a gensym, %add to local environment, compile and assign rhs
- g:= genVariable()
- e:= addBinding(g,nil,e)
- T:= [.,m1,.]:= compSetq1(g,val,$EmptyMode,e) or return nil
- e:= put(g,"mode",m1,e)
- [x,m',e]:= convert(T,m) or return nil
- --1.1 exit if result is a list
- m1 is ["List",D] =>
- for y in nameList repeat e := giveVariableSomeValue(y,D,e)
- convert([["PROGN",x,["%LET",nameList,g],g],m',e],m)
- --2. verify that the #nameList = number of parts of right-hand-side
- selectorModePairs:=
- --list of modes
- decompose(m1,#nameList,e) or return nil where
- decompose(t,length,e) ==
- t is ["Record",:l] => [[name,:mode] for [":",name,mode] in l]
- comp(t,$EmptyMode,e) is [.,["RecordCategory",:l],.] =>
- [[name,:mode] for [":",name,mode] in l]
- stackMessage ["no multiple assigns to mode: ",t]
- #nameList ~= #selectorModePairs =>
- stackMessage [val," must decompose into ",#nameList," components"]
- -- 3.generate code; return
- assignList:=
- [([.,.,e]:= compSetq1(x,["elt",g,y],z,e) or return "failed").expr
- for x in nameList for [y,:z] in selectorModePairs]
- if assignList="failed" then NIL
- else [mkpf([x,:assignList,g],'PROGN),m',e]
-
-setqMultipleExplicit(nameList,valList,m,e) ==
- #nameList ~= #valList =>
- stackMessage ["Multiple assignment error; # of items in: ",nameList,
- "must = # in: ",valList]
- gensymList:= [genVariable() for name in nameList]
- for g in gensymList for name in nameList repeat
- e := put(g,"mode",get(name,"mode",e),e)
- assignList:=
- --should be fixed to declare genVar when possible
- [[.,.,e]:= compSetq1(g,val,$EmptyMode,e) or return "failed"
- for g in gensymList for val in valList for name in nameList]
- assignList="failed" => nil
- reAssignList:=
- [[.,.,e]:= compSetq1(name,g,$EmptyMode,e) or return "failed"
- for g in gensymList for name in nameList]
- reAssignList="failed" => nil
- T := [["PROGN",:[T.expr for T in assignList],
- :[T.expr for T in reAssignList]], $NoValueMode, (last reAssignList).env]
- markMultipleExplicit(nameList,valList,T)
-
-canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends
- atom expr => ValueFlag and level=exitCount
- (op:= first expr)="QUOTE" => ValueFlag and level=exitCount
- op in '(WI MI) => canReturn(third expr,level,count,ValueFlag)
- op="TAGGEDexit" =>
- expr is [.,count,data] => canReturn(data.expr,level,count,count=level)
- level=exitCount and not ValueFlag => nil
- op="SEQ" => or/[canReturn(u,level+1,exitCount,false) for u in rest expr]
- op="TAGGEDreturn" => nil
- op="CATCH" =>
- [.,gs,data]:= expr
- (findThrow(gs,data,level,exitCount,ValueFlag) => true) where
- findThrow(gs,expr,level,exitCount,ValueFlag) ==
- atom expr => nil
- expr is ["THROW", =gs,data] => true
- --this is pessimistic, but I know of no more accurate idea
- expr is ["SEQ",:l] =>
- or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l]
- or/[findThrow(gs,u,level,exitCount,ValueFlag) for u in rest expr]
- canReturn(data,level,exitCount,ValueFlag)
- op = '%when =>
- level = exitCount =>
- or/[canReturn(last u,level,exitCount,ValueFlag) for u in rest expr]
- or/[or/[canReturn(u,level,exitCount,ValueFlag) for u in v]
- for v in rest expr]
- op="IF" =>
- expr is [.,a,b,c]
- if not canReturn(a,0,0,true) and not $convert2NewCompiler then
- SAY "IF statement can not cause consequents to be executed"
- pp expr
- canReturn(a,level,exitCount,nil) or canReturn(b,level,exitCount,ValueFlag)
- or canReturn(c,level,exitCount,ValueFlag)
- --now we have an ordinary form
- atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr]
- op is ["XLAM",args,bods] =>
- and/[canReturn(u,level,exitCount,ValueFlag) for u in expr]
- systemErrorHere ["canReturn",expr] --for the time being
-
-compList(l,m is ["List",mUnder],e) ==
- markImport m
- markImport mUnder
- null l => [NIL,m,e]
- Tl:= [[.,mUnder,e]:=
- comp(x,mUnder,e) or return "failed" for i in 1.. for x in l]
- Tl="failed" => nil
- T:= [['%list,:[T.expr for T in Tl]],["List",mUnder],e]
-
-compVector(l,m is ["Vector",mUnder],e) ==
- markImport m
- markImport mUnder
- null l => [$EmptyVector,m,e]
- Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l]
- Tl="failed" => nil
- [["VECTOR",:[T.expr for T in Tl]],m,e]
-
-compColon([":",f,t],m,e) ==
- $insideExpressionIfTrue=true => compPretend(["pretend",f,t],m,e)
- --if inside an expression, ":" means to convert to m "on faith"
- f := markKillAll f
- $lhsOfColon: local:= f
- t:=
- t := markKillAll t
- atom t and (t':= ASSOC(t,getDomainsInScope e)) => t'
- isDomainForm(t,e) and not $insideCategoryIfTrue =>
- (if not member(t,getDomainsInScope e) then e:= addDomain(t,e); t)
- isDomainForm(t,e) or isCategoryForm(t,e) => t
- t is ["Mapping",m',:r] => t
- unknownTypeError t
- t
- if $insideCapsuleFunctionIfTrue then markDeclaredImport t
- f is ["LISTOF",:l] =>
- (for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T)
- e:=
- f is [op,:argl] and not (t is ["Mapping",:.]) =>
- --for MPOLY--replace parameters by formal arguments: RDJ 3/83
- newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList),
- [(x is [":",a,m] => a; x) for x in argl],t)
- signature:=
- ["Mapping",newTarget,:
- [(x is [":",a,m] => m;
- getmode(x,e) or systemErrorHere '"compColonOld") for x in argl]]
- put(op,"mode",signature,e)
- put(f,"mode",t,e)
- if not $bootStrapMode and $insideFunctorIfTrue and
- makeCategoryForm(t,e) is [catform,e] then
- e:= giveVariableSomeValue(f,t,e)
- ["/throwAway",getmode(f,e),e]
-
-compConstruct(form,m,e) == (T := compConstruct1(form,m,e)) and markConstruct(form,T)
-
-compConstruct1(form is ["construct",:l],m,e) ==
- y:= modeIsAggregateOf("List",m,e) =>
- T:= compList(l,["List",second y],e) => convert(T,m)
- y:= modeIsAggregateOf("Vector",m,e) =>
- T:= compVector(l,["Vector",second y],e) => convert(T,m)
- T:= compForm(form,m,e) => T
- for D in getDomainsInScope e repeat
- (y:=modeIsAggregateOf("List",D,e)) and
- (T:= compList(l,["List",second y],e)) and (T':= convert(T,m)) =>
- return T'
- (y:=modeIsAggregateOf("Vector",D,e)) and
- (T:= compVector(l,["Vector",second y],e)) and (T':= convert(T,m)) =>
- return T'
-
-compPretend(u := ["pretend",x,t],m,e) ==
- t := markKillAll t
- m := markKillAll m
- e:= addDomain(t,e)
- T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil
- if T.mode=t then warningMessage:= ["pretend",t," -- should replace by @"]
- T1:= [T.expr,t,T.env]
- t = "$" and m = "Rep" => markPretend(T1,T1) -->! WATCH OUT: correct? !<--
- T':= coerce(T1,m) =>
- warningMessage =>
- stackWarning warningMessage
- markCompColonInside("@",T')
- markPretend(T1,T')
- nil
-
-compAtSign(["@",x,m'],m,e) ==
- m' := markKillAll m'
- m := markKillAll m
- e:= addDomain(m',e)
- T:= comp(x,m',e) or return nil
- coerce(T,m)
-
-compColonInside(x,m,e,m') ==
- m' := markKillAll m'
- e:= addDomain(m',e)
- T:= comp(x,$EmptyMode,e) or return nil
- if T.mode=m' then warningMessage:= [":",m'," -- should replace by ::"]
- T:= [T.expr,m',T.env]
- m := markKillAll m
- T':= coerce(T,m) =>
- warningMessage =>
- stackWarning warningMessage
- markCompColonInside("@",T')
- stackWarning [":",m'," -- should replace by pretend"]
- markCompColonInside("pretend",T')
- nil
-
-resolve(min, mout) ==
- din := markKillAll min
- dout := markKillAll mout
- din=$NoValueMode or dout=$NoValueMode => $NoValueMode
- dout=$EmptyMode => din
- string? din and dout = $Symbol => dout ------> hack 8/14/94
- string? dout and din = $Symbol => din ------> hack 8/14/94
- din ~= dout and (string? din or string? dout) =>
- modeEqual(dout,$String) => dout
- modeEqual(din,$String) => nil
- mkUnion(din,dout)
- dout
-
-coerce(T,m) ==
- T := [T.expr,markKillAll T.mode,T.env]
- m := markKillAll m
- if not isLiteral(m,T.env) then markImport m
- $InteractiveMode =>
- keyedSystemError("S2GE0016",['"coerce",
- '"function coerce called from the interpreter."])
---==================> changes <======================
---The following line is inappropriate for our needs:::
---T.rest.first := substitute("$",$Rep,second T)
- T' := coerce0(T,m) => T'
- T := [T.expr,fullSubstitute("$",$Representation,T.mode),T.env]
---==================> changes <======================
- coerce0(T,m)
-
-coerce0(T,m) ==
- T':= coerceEasy(T,m) => T'
- T':= coerceSubset(T,m) => markCoerce(T,T','AUTOSUBSET)
- T':= coerceHard(T,m) => markCoerce(T,T','AUTOHARD)
- T':= coerceExtraHard(T,m) => T'
- T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil
- T' := coerceRep(T,m) => markCoerce(T,T','AUTOREP)
- stackMessage fn(T.expr,T.mode,m) where
- -- if from from coerceable, this coerce was just a trial coercion
- -- from compFormWithModemap to filter through the modemaps
- fn(x,m1,m2) ==
- ["Cannot coerce","%b",x,"%d","%l"," of mode","%b",m1,"%d","%l",
- " to mode","%b",m2,"%d"]
-
-coerceSubset(T := [x,m,e],m') ==
- m = $SmallInteger =>
- m' = $Integer => [x,m',e]
- m' = (r := get(x,'range,e)) or isSubset(r,m',e) => [x,r,e]
- nil
--- pp [m, m']
- isSubset(m,m',e) => [x,m',e]
- -- if m is a type variable, we can't know.
- (pred:= isSubset(m',m,e)) and integer? x and
- -- obviously this is temporary
- eval substitute(x,"#1",pred) => [x,m',e]
- nil
-
-coerceRep(T,m) ==
- md := T.mode
- atom md => nil
- CONTAINED('Rep,md) and SUBST('$,'Rep,md) = m or
- CONTAINED('Rep,m) and SUBST('$,'Rep,m) = md => T
- nil
-
---- GET rid of XLAMs
-spadCompileOrSetq form ==
- --bizarre hack to take account of the existence of "known" functions
- --good for performance (LISPLLIB size, BPI size, NILSEC)
- [nam,[lam,vl,body]] := form
- CONTAINED($ClearBodyToken,body) => sayBrightly ['" ",:bright nam,'" not compiled"]
- if vl is [:vl',E] and body is [nam',: =vl'] then
- LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam']
- sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam']
- else if (atom body or and/[atom x for x in body])
- and vl is [:vl',E] and not CONTAINED(E,body) then
- macform := ['XLAM,vl',body]
- LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ macform]
- sayBrightly ['" ",:bright nam,'"is replaced by",:bright body]
- $insideCapsuleFunctionIfTrue => first backendCompile [form]
- compileConstructor form
-
-coerceHard(T,m) ==
- $e: local:= T.env
- m':= T.mode
- string? m' and modeEqual(m,$String) => [T.expr,m,$e]
- modeEqual(m',m) or
- (get(m',"value",$e) is [m'',:.] or getmode(m',$e) is ["Mapping",m'']) and
- modeEqual(m'',m) or
- (get(m,"value",$e) is [m'',:.] or getmode(m,$e) is ["Mapping",m'']) and
- modeEqual(m'',m') => [T.expr,m,T.env]
- string? T.expr and T.expr=m => [T.expr,m,$e]
- isCategoryForm(m,$e) =>
- $bootStrapMode = true => [T.expr,m,$e]
- extendsCategoryForm(T.expr,T.mode,m) => [T.expr,m,$e]
- nil
- nil
-
-coerceExtraHard(T is [x,m',e],m) ==
- T':= autoCoerceByModemap(T,m) => T'
- unionLike?(m',e) is ['UnionCategory,:l] and (t:= hasType(x,e)) and
- member(t,l) and (T':= autoCoerceByModemap(T,t)) and
- (T'':= coerce(T',m)) => T''
- m' is ['Record,:.] and m = $OutputForm =>
- [['coerceRe2E,x,['ELT,COPY m',0]],m,e]
- nil
-
-compCoerce(u := ["::",x,m'],m,e) ==
- m' := markKillAll m'
- e:= addDomain(m',e)
- m := markKillAll m
---------------> new code <-------------------
- T:= compCoerce1(x,m',e) => coerce(T,m)
- T := comp(x,$EmptyMode,e) or return nil
- T.mode = $SmallInteger and
- opOf m in '(NonNegativeInteger PositiveInteger) =>
- compCoerce(["::",["::",x,$Integer],m'],m,e)
---------------> new code <-------------------
- getmode(m',e) is ["Mapping",["UnionCategory",:l]] =>
- l := [markKillAll x for x in l]
- T:= (or/[compCoerce1(x,m1,e) for m1 in l]) or return nil
- coerce([T.expr,m',T.env],m)
-
-compCoerce1(x,m',e) ==
- T:= comp(x,m',e)
- if null T then T := comp(x,$EmptyMode,e)
- null T => return nil
- m1:=
- string? T.mode => $String
- T.mode
- m':=resolve(m1,m')
- T:=[T.expr,m1,T.env]
- T':= coerce(T,m') => T'
- T':= coerceByModemap(T,m') => T'
- pred:=isSubset(m',T.mode,e) =>
- gg:=gensym()
- pred:= substitute(gg,"#1",pred)
- code:= ['PROG1,["%LET",gg,T.expr], ['check_-subtype,pred,MKQ m',gg]]
- [code,m',T.env]
-
-coerceByModemap([x,m,e],m') ==
---+ modified 6/27 for new runtime system
- u:=
- [modemap
- for (modemap:= [map,cexpr]) in getModemapList("coerce",1,e) | map is [.,t,
- s] and (modeEqual(t,m') or isSubset(t,m',e))
- and (modeEqual(s,m) or isSubset(m,s,e))] or return nil
- mm:=first u -- patch for non-trival conditons
- fn := genDeltaEntry(['coerce,:mm],e)
- T := [['%call,fn,x],m',e]
- markCoerceByModemap(x,m,m',markCallCoerce(x,m',T),nil)
-
-autoCoerceByModemap([x,source,e],target) ==
- u:=
- [cexpr
- for (modemap:= [map,cexpr]) in getModemapList("autoCoerce",1,e) | map is [
- .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil
- fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil
- markCoerceByModemap(x,source,target,[['%call,fn,x],target,e],true)
-
---======================================================================
--- From compiler.boot
---======================================================================
---comp3x(x,m,$e) ==
-
-comp3(x,m,$e) ==
- --returns a Triple or %else nil to signalcan't do'
- $e:= addDomain(m,$e)
- e:= $e --for debugging purposes
- m is ["Mapping",:.] => compWithMappingMode(x,m,e)
- m is ["QUOTE",a] => (x=a => [x,m,$e]; nil)
- string? m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil)
- null x or atom x => compAtom(x,m,e)
- op:= first x
- getmode(op,e) is ["Mapping",:ml] and (u:= applyMapping(x,m,e,ml)) => u
- op=":" => compColon(x,m,e)
- op="::" => compCoerce(x,m,e)
- not ($insideCompTypeOf=true) and stringPrefix?('"TypeOf",PNAME op) =>
- compTypeOf(x,m,e)
- ------------special jump out code for PART (don't want $insideExpressionIfTrue=true)--
- x is ['PART,:.] => compPART(x,m,e)
- ----------------------------------
- t:= qt(14,compExpression(x,m,e))
- t is [x',m',e'] and not member(m',getDomainsInScope e') =>
- qt(15,[x',m',addDomain(m',e')])
- qt(16,t)
-
-yyyyy x == x
-compExpression(x,m,e) ==
- $insideExpressionIfTrue: local:= true
- if x is ["%LET",['PART,.,w],[['elt,B,'new],['PART,.,["#",['PART,.,l]]],:.],:.] then yyyyy x
- x := compRenameOp x
- atom first x and (fn:= GETL(first x,"SPECIAL")) =>
- FUNCALL(fn,x,m,e)
- compForm(x,m,e)
-
-compRenameOp x == ----------> new 12/3/94
- x is [op,:r] and op is ['PART,.,op1] =>
- [op1,:r]
- x
-
-compCase(["case",x,m1],m,e) ==
- m' := markKillAll m1
- e:= addDomain(m',e)
- T:= compCase1(x,m',e) => coerce(T,m)
- nil
-
-compCase1(x,m,e) ==
- x1 :=
- x is ['PART,.,a] => a
- x
- [x',m',e']:= comp(x1,$EmptyMode,e) or return nil
- if m' = "$" then (m' := IFCAR get('Rep,'value,e)) and (switchMode := true)
- --------------------------------------------------------------------------
- m' isnt ['Union,:r] => nil
- mml := [mm for (mm := [map,cexpr]) in getModemapList("case",2,e')
- | map is [.,.,s,t] and modeEqual(t,m) and
- (modeEqual(s,m') or switchMode and modeEqual(s,"$"))]
- or return nil
- u := [cexpr for [.,cexpr] in mml]
- fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil
- tag := genCaseTag(m, r, 1) or return nil
- x1 :=
- switchMode => markRepper('rep, x)
- x
- markCase(x, tag, markCaseWas(x1,[['%call,fn,x'],$Boolean,e']))
-
-genCaseTag(t,l,n) ==
- l is [x, :l] =>
- x = t =>
- string? x => makeSymbol x
- makeSymbol strconc("value", STRINGIMAGE n)
- x is ["::",=t,:.] => t
- string? x => genCaseTag(t, l, n)
- genCaseTag(t, l, n + 1)
- nil
-
-compIf(["IF",aOrig,b,c],m,E) ==
- a := markKillButIfs aOrig
- [xa,ma,Ea,Einv]:= compBoolean(a,aOrig,$Boolean,E) or return nil
- [xb,mb,Eb]:= Tb:= compFromIf(b,m,Ea) or return nil
- [xc,mc,Ec]:= Tc:= compFromIf(c,resolve(mb,m),Einv) or return nil
- xb':= coerce(Tb,mc) or return nil
- x:= ["IF",xa,xb'.expr,xc]
- (returnEnv:= Env(xb'.env,Ec,xb'.expr,xc,E)) where
- Env(bEnv,cEnv,b,c,E) ==
- canReturn(b,0,0,true) =>
- (canReturn(c,0,0,true) => intersectionEnvironment(bEnv,cEnv); bEnv)
- canReturn(c,0,0,true) => cEnv
- E
- [x,mc,returnEnv]
-
-compBoolean(p,pWas,m,Einit) ==
- op := opOf p
- [p',m,E]:=
- fop := LASSOC(op,'((and . compAnd) (or . compOr) (not . compNot))) =>
- apply(fop,[p,pWas,m,Einit]) or return nil
- T := comp(p,m,Einit) or return nil
- markAny('compBoolean,pWas,T)
- [p',m,getSuccessEnvironment(markKillAll p,E),
- getInverseEnvironment(markKillAll p,E)]
-
-compAnd([op,:args], pWas, m, e) ==
---called ONLY from compBoolean
- cargs := [T.expr for x in args
- | [.,.,e,.] := T := compBoolean(x,x,$Boolean,e) or return nil]
- null cargs => nil
- coerce(markAny('compAnd,pWas,[["AND",:cargs],$Boolean,e]),m)
-
-compOr([op,:args], pWas, m, e) ==
---called ONLY from compBoolean
- cargs := [T.expr for x in args
- | [.,.,.,e] := T := compBoolean(x,x,$Boolean,e) or return nil]
- null cargs => nil
- coerce(markAny('compOr,pWas, [["OR",:cargs],$Boolean,e]),m)
-
-compNot([op,arg], pWas, m, e) ==
---called ONLY from compBoolean
- [x,m1,.,ei] := compBoolean(arg,arg,$Boolean,e) or return nil
- coerce(markAny('compNot, pWas, [["NOT",x],$Boolean,ei]),m)
-
-compDefine(form,m,e) ==
- $macroIfTrue: local
- ['DEF,.,originalSignature,.,body] := form
- if not $insideFunctorIfTrue then
- $originalBody := COPY body
- compDefine1(form,m,e)
-
-compDefine1(form,m,e) ==
- $insideExpressionIfTrue: local:= false
- --1. decompose after macro-expanding form
- ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e)
- $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode)
- => [lhs,m,putMacro(lhs.op,rhs,e)]
- null signature.target and not MEMQ(KAR rhs,$BuiltinConstructorNames) and
- (sig:= getSignatureFromMode(lhs,e)) =>
- -- here signature of lhs is determined by a previous declaration
- compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e)
- if signature.target=$Category then $insideCategoryIfTrue:= true
- if signature.target is ['Mapping,:map] then
- signature:= map
- form:= ['DEF,lhs,signature,specialCases,rhs]
-
-
--- RDJ (11/83): when argument and return types are all declared,
--- or arguments have types declared in the environment,
--- and there is no existing modemap for this signature, add
--- the modemap by a declaration, then strip off declarations and recurse
- e := compDefineAddSignature(lhs,signature,e)
--- 2. if signature list for arguments is not empty, replace ('DEF,..) by
--- ('where,('DEF,..),..) with an empty signature list;
--- otherwise, fill in all NILs in the signature
- not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e)
- signature.target=$Category =>
- compDefineCategory(form,m,e,nil,$formalArgList)
- isDomainForm(rhs,e) and not $insideFunctorIfTrue =>
- if null signature.target then signature:=
- [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),:
- rest signature]
- rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs)
- compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil,
- $formalArgList)
- null $form => stackAndThrow ['"bad == form ",form]
- newPrefix:=
- $prefix => makeSymbol strconc(encodeItem $prefix,'",",encodeItem $op)
- getAbbreviation($op,#rest $form)
- compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList)
-
-compDefineCategory(df,m,e,prefix,fal) ==
- $domainShell: local -- holds the category of the object being compiled
- $lisplibCategory: local
- not $insideFunctorIfTrue and $LISPLIB =>
- compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1)
- compDefineCategory1(df,m,e,prefix,fal)
-
-compDefineCategory1(df,m,e,prefix,fal) ==
- $DEFdepth : local := 0 --for conversion to new compiler 3/93
- $capsuleStack : local := nil --for conversion to new compiler 3/93
- $predicateStack:local := nil --for conversion to new compiler 3/93
- $signatureStack:local := nil --for conversion to new compiler 3/93
- $importStack : local := nil --for conversion to new compiler 3/93
- $globalImportStack : local := nil --for conversion to new compiler 3/93
- $catAddForm : local := nil --for conversion to new compiler 2/95
- $globalDeclareStack : local := nil
- $globalImportDefAlist: local:= nil
- $localMacroStack : local := nil --for conversion to new compiler 3/93
- $freeStack : local := nil --for conversion to new compiler 3/93
- $domainLevelVariableList: local := nil--for conversion to new compiler 3/93
- $categoryTranForm : local := nil --for conversion to new compiler 10/93
- ['DEF,form,sig,sc,body] := df
- body := markKillAll body --these parts will be replaced by compDefineLisplib
- categoryCapsule :=
---+
- body is ['add,cat,capsule] =>
- body := cat
- capsule
- nil
- [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal)
---+ next two lines
--- if $convertingSpadFile then nil
--- else
- if categoryCapsule and not $bootStrapMode then
- [.,.,e] :=
- $insideCategoryPackageIfTrue: local := true
- $categoryPredicateList: local :=
- makeCategoryPredicates(form,$lisplibCategory)
- defform := mkCategoryPackage(form,cat,categoryCapsule)
- ['DEF,[.,arg,:.],:.] := defform
- $categoryNameForDollar :local := arg
- compDefine1(defform,$EmptyMode,e)
- else
- [body,T] := $categoryTranForm
- markFinish(body,T)
-
- [d,m,e]
-
-compDefineCategory2(form,signature,specialCases,body,m,e,
- $prefix,$formalArgList) ==
- --1. bind global variables
- $insideCategoryIfTrue: local:= true
- $definition: local := nil
- --used by DomainSubstitutionFunction
- $form: local := nil
- $op: local := nil
- $extraParms: local := nil
- --Set in DomainSubstitutionFunction, used further down
--- 1.1 augment e to add declaration $: <form>
- [$op,:argl]:= $definition:= form
- e:= addBinding("$",[['mode,:$definition]],e)
-
--- 2. obtain signature
- signature':=
- [first signature,:[getArgumentModeOrMoan(a,$definition,e) for a in argl]]
- e:= giveFormalParametersValues(argl,e)
-
--- 3. replace arguments by $1,..., substitute into body,
--- and introduce declarations into environment
- sargl:= TAKE(# argl, $TriangleVariableList)
- $functorForm:= $form:= [$op,:sargl]
- $formalArgList:= [:sargl,:$formalArgList]
- aList:= [[a,:sa] for a in argl for sa in sargl]
- formalBody:= SUBLIS(aList,body)
- signature' := SUBLIS(aList,signature')
---Begin lines for category default definitions
- $functionStats: local:= [0,0]
- $functorStats: local:= [0,0]
- $getDomainCode: local := nil
- $addForm: local:= nil
- for x in sargl for t in rest signature' repeat
- [.,.,e]:= compMakeDeclaration(x,t,e)
-
--- 4. compile body in environment of %type declarations for arguments
- op':= $op
- -- following line causes cats with no with or Join to be fresh copies
- if opOf(formalBody) ~= 'Join and opOf(formalBody) ~= 'mkCategory then
- formalBody := ['Join, formalBody]
- T := compOrCroak(formalBody,signature'.target,e)
---------------------> new <-------------------
- $catAddForm :=
- $originalBody is ['add,y,:.] => y
- $originalBody
- $categoryTranForm := [$originalBody,[$form,['Mapping,:signature'],T.env]]
---------------------> new <-------------------
- body:= optFunctorBody markKillAll T.expr
- if $extraParms then
- formals:=actuals:=nil
- for u in $extraParms repeat
- formals:=[first u,:formals]
- actuals:=[MKQ rest u,:actuals]
- body := ['sublisV,['PAIR,['QUOTE,formals],['%list,:actuals]],body]
- if argl then body:= -- always subst for args after extraparms
- ['sublisV,['PAIR,['QUOTE,sargl],['%list,:
- [['devaluate,u] for u in sargl]]],body]
- body:=
- ['PROG1,["%LET",g:= gensym(),body],
- ['%store,['%tref,g,0],mkConstructor $functorForm]]
- fun:= compile [op',['LAM,sargl,body]]
-
--- 5. give operator a 'modemap property
- pairlis:= pairList(argl,$FormalMapVariableList)
- parSignature:= SUBLIS(pairlis,signature')
- parForm:= SUBLIS(pairlis,form)
----- lisplibWrite('"compilerInfo",
----- ['SETQ,'$CategoryFrame,
----- ['put,['QUOTE,op'],'
----- (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm,
----- MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile)
- --Equivalent to the following two lines, we hope
- if null sargl then
- evalAndRwriteLispForm('NILADIC,
- ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true])
-
--- 6. put modemaps into InteractiveModemapFrame
- $domainShell :=
- $convertingSpadFile => nil
- eval [op',:MAPCAR('MKQ,sargl)]
- $lisplibCategory:= formalBody
----- if $LISPLIB then
----- $lisplibForm:= form
----- $lisplibKind:= 'category
----- modemap:= [[parForm,:parSignature],[true,op']]
----- $lisplibModemap:= modemap
----- $lisplibCategory:= formalBody
----- form':=[op',:sargl]
----- augLisplibModemapsFromCategory(form',formalBody,signature')
- [fun,'(Category),e]
diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot
deleted file mode 100644
index 7330a4c5..00000000
--- a/src/interp/wi2.boot
+++ /dev/null
@@ -1,1132 +0,0 @@
--- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
--- All rights reserved.
--- Copyright (C) 2007-2011, 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 macros
-import define
-namespace BOOT
-
--- ??? turns off buggy code
-$NRTopt := false
-
-compDefineFunctor1(df, m,$e,$prefix,$formalArgList) ==
- ['DEF,form,signature,$functorSpecialCases,body] := df
- signature := markKillAll signature
--- 1. bind global variables
- $addForm: local := nil
- $functionStats: local:= [0,0]
- $functorStats: local:= [0,0]
- $DEFdepth : local := 0 --for conversion to new compiler 3/93
- $capsuleStack : local := nil --for conversion to new compiler 3/93
- $predicateStack:local := nil --for conversion to new compiler 3/93
- $signatureStack:local := nil --for conversion to new compiler 3/93
- $importStack : local := nil --for conversion to new compiler 3/93
- $globalImportStack : local := nil --for conversion to new compiler 3/93
- $globalDeclareStack : local := nil
- $globalImportDefAlist: local:= nil
- $localMacroStack : local := nil --for conversion to new compiler 3/93
- $freeStack : local := nil --for conversion to new compiler 3/93
- $domainLevelVariableList: local := nil--for conversion to new compiler 3/93
- $localLoopVariables: local := nil
- $pathStack : local := nil
- $form: local := nil
- $op: local := nil
- $signature: local := nil
- $functorTarget: local := nil
- $Representation: local := nil
- --Set in doIt, accessed in the compiler - compNoStacking
- $LocalDomainAlist: local --set in doIt, accessed in genDeltaEntry
- $LocalDomainAlist:= nil
- $functorForm: local := nil
- $functorLocalParameters: local := nil
- $CheckVectorList: local := nil
- --prevents CheckVector from printing out same message twice
- $getDomainCode: local -- code for getting views
- $insideFunctorIfTrue: local:= true
- $genSDVar: local:= 0
- originale:= $e
- [$op,:argl]:= form
- $formalArgList:= [:argl,:$formalArgList]
- $pairlis := pairList(argl,$FormalMapVariableList)
- $mutableDomain: local :=
- -- all defaulting packages should have caching turned off
- isCategoryPackageName $op or
- (if $mutableDomains then MEMQ($op,$mutableDomains)
- else false ) --true if domain has mutable state
- signature':=
- [first signature,:[getArgumentModeOrMoan(a,form,$e) for a in argl]]
- $functorForm:= $form:= [$op,:argl]
- $globalImportStack :=
- [markKillAll x for x in rest $functorForm for typ in rest signature'
- | getConstructorKindFromDB opOf typ = "category"]
- if null first signature' then signature':=
- modemap2Signature getModemap($form,$e)
- target:= first signature'
- $functorTarget:= target
- $e:= giveFormalParametersValues(argl,$e)
- [ds,.,$e]:= compMakeCategoryObject(target,$e) or
---+ copy needed since slot1 is reset; compMake.. can return a cached vector
- sayBrightly '" cannot produce category object:"
- pp target
- return nil
- $domainShell:= COPY_-SEQ ds
- attributeList := ds.2 --see below under "loadTimeAlist"
---+ 7 lines for $NRT follow
--->--these globals used by NRTmakeCategoryAlist, set by NRTsetVector4Part1
- $condAlist: local := nil
- $uncondAlist: local := nil
--->>-- next global initialized here, reset by buildFunctor
- $NRTslot1PredicateList: local :=
- removeDuplicates [second x for x in attributeList]
--->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT)
- $NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList
- $NRTslot1Info: local := nil --set in NRTmakeSlot1Info
- --this is used below to set $lisplibSlot1 global
- $NRTaddForm: local := nil -- see compAdd
- $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts
- $NRTdeltaListComp: local := nil --list of compiled forms for $NRTdeltaList
- $NRTdeltaLength: local := 0 -- =length of block of extra entries in vector
- $template: local:= nil --stored in the lisplib
- $functionLocations: local := nil --locations of defined functions in source
- -- generate slots for arguments first, then for $NRTaddForm in compAdd
- for x in argl repeat NRTgetLocalIndex x
- [.,.,$e]:= compMakeDeclaration("$",target,$e)
- --The following loop sees if we can economise on ADDed operations
- --by using those of Rep, if that is the same. Example: DIRPROD
- if not $insideCategoryPackageIfTrue then
- if body is ['add,ab:=[fn,:.],['CAPSULE,:cb]] and fn in '(List Vector)
- and FindRep(cb) = ab
- where FindRep cb ==
- u:=
- while cb repeat
- atom cb => return nil
- cb is [["%LET",'Rep,v,:.],:.] => return (u:=v)
- cb:=rest cb
- u
- then $e:= augModemapsFromCategoryRep('_$,ab,cb,target,$e)
- else $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e)
- $signature:= signature'
- operationAlist:= SUBLIS($pairlis,$domainShell.1)
- parSignature:= SUBLIS($pairlis,signature')
- parForm:= SUBLIS($pairlis,form)
-
--- (3.1) now make a list of the functor's local parameters; for
--- domain D in argl,check its signature: if domain, its type is Join(A1,..,An);
--- in this case, D is replaced by D1,..,Dn (gensyms) which are set
--- to the A1,..,An view of D
---+
- $functorLocalParameters:=
- argPars :=
- makeFunctorArgumentParameters(argl,rest signature',first signature')
- -- must do above to bring categories into scope --see line 5 of genDomainView
- argl
--- 4. compile body in environment of %type declarations for arguments
- op':= $op
- rettype:= signature'.target
- T:= compFunctorBody(body,rettype,$e,parForm)
----------------> new <---------------------
- $convert2NewCompiler =>
- return markFinish($originalBody,[$form,['Mapping,:signature'],T.env])
----------------> new <---------------------
- -- If only compiling certain items, then ignore the body shell.
- $compileOnlyCertainItems =>
- reportOnFunctorCompilation()
- [nil, ['Mapping, :signature'], originale]
-
- body':= T.expr
- lamOrSlam:= if $mutableDomain then 'LAM else 'SPADSLAM
- fun:= compile SUBLIS($pairlis, [op',[lamOrSlam,argl,body']])
- --The above statement stops substitutions gettting in one another's way
---+
- operationAlist := SUBLIS($pairlis,$lisplibOperationAlist)
- if $LISPLIB then
- augmentLisplibModemapsFromFunctor(parForm,operationAlist,parSignature)
- reportOnFunctorCompilation()
-
--- 5. give operator a 'modemap property
- $insideFunctorIfTrue:= false
- if $LISPLIB then
- $lisplibKind:=
- $functorTarget is ["CATEGORY",key,:.] and key~="domain" => 'package
- 'domain
- $lisplibForm:= form
- modemap:= [[parForm,:parSignature],[true,op']]
- $lisplibModemap:= modemap
- if null $bootStrapMode then
- $NRTslot1Info := NRTmakeSlot1Info()
- $isOpPackageName: local := isCategoryPackageName $op
- if $isOpPackageName then lisplibWrite('"slot1DataBase",
- ['updateSlot1DataBase,MKQ $NRTslot1Info],$libFile)
- $lisplibFunctionLocations := SUBLIS($pairlis,$functionLocations)
- libFn := getConstructorAbbreviation op'
- $lookupFunction: local :=
- NRTgetLookupFunction($functorForm,$lisplibModemap.mmTarget,$NRTaddForm)
- --either lookupComplete (for forgetful guys) or lookupIncomplete
- $byteAddress :local := 0
- $byteVec :local := nil
- $NRTslot1PredicateList :=
- [simpBool x for x in $NRTslot1PredicateList]
- rwriteLispForm('loadTimeStuff,
- ['MAKEPROP,MKQ $op,''infovec,getInfovecCode()])
- $lisplibSlot1 := $NRTslot1Info --NIL or set by $NRTmakeSlot1
- $lisplibOperationAlist:= operationAlist
- lisplibWrite('"compilerInfo",
- ['SETQ,'$CategoryFrame,
- ['put,['QUOTE,op'],'
- (QUOTE isFunctor),
- ['QUOTE,operationAlist],['addModemap,['QUOTE,op'],['
- QUOTE,parForm],['QUOTE,parSignature],true,['QUOTE,op'],
- ['put,['QUOTE,op' ],'(QUOTE mode),
- ['QUOTE,['Mapping,:parSignature]],'$CategoryFrame]]]],$libFile)
- if null argl then
- evalAndRwriteLispForm('NILADIC,
- ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'NILADIC], true])
- [fun,['Mapping,:signature'],originale]
-
-makeFunctorArgumentParameters(argl,sigl,target) ==
- $forceAdd: local:= true
- $ConditionalOperators: local
- target := markKillAll target
- ("append"/[fn(a,augmentSig(s,findExtras(a,target)))
- for a in argl for s in sigl]) where
- findExtras(a,target) ==
- -- see if conditional information implies anything else
- -- in the signature of a
- target is ['Join,:l] => "union"/[findExtras(a,x) for x in l]
- target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where
- findExtras1(a,x) ==
- x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l]
- x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l]
- x is ['IF,c,p,q] =>
- union(findExtrasP(a,c),
- union(findExtras1(a,p),findExtras1(a,q))) where
- findExtrasP(a,x) ==
- x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l]
- x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l]
- x is ["has",=a,y] and y is ['SIGNATURE,:.] => [y]
- nil
- nil
- augmentSig(s,ss) ==
- -- if we find something extra, add it to the signature
- null ss => s
- for u in ss repeat
- $ConditionalOperators:=[rest u,:$ConditionalOperators]
- s is ['Join,:sl] =>
- u:=ASSQ('CATEGORY,ss) =>
- SUBST([:u,:ss],u,s)
- ['Join,:sl,['CATEGORY,'package,:ss]]
- ['Join,s,['CATEGORY,'package,:ss]]
- fn(a,s) ==
- isCategoryForm(s,$CategoryFrame) =>
- s is ["Join",:catlist] => genDomainViewList(a,rest s)
- [genDomainView(a,a,s,"getDomainView")]
- [a]
-
-compDefineCapsuleFunction(df,m,oldE,$prefix,$formalArgList) ==
- ['DEF,form,originalSignature,specialCases,body] := df
- signature := markKillAll originalSignature
- $markFreeStack: local := nil --holds "free variables"
- $localImportStack : local := nil --local import stack for function
- $localDeclareStack: local := nil
- $localLoopVariables: local := nil
- originalDef := COPY df
- [lineNumber,:specialCases] := specialCases
- e := oldE
- --1. bind global variables
- $form: local := nil
- $op: local := nil
- $functionStats: local:= [0,0]
- $argumentConditionList: local
- $finalEnv: local := nil
- --used by ReplaceExitEtc to get a common environment
- $initCapsuleErrorCount: local:= #$semanticErrorStack
- $insideCapsuleFunctionIfTrue: local:= true
- $CapsuleModemapFrame: local:= e
- $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e)
- $insideExpressionIfTrue: local:= true
- $returnMode:= m
- [$op,:argl]:= form
- $form:= [$op,:argl]
- argl:= stripOffArgumentConditions argl
- $formalArgList:= [:argl,:$formalArgList]
-
- --let target and local signatures help determine modes of arguments
- argModeList:=
- identSig:= hasSigInTargetCategory(argl,form,first signature,e) =>
- (e:= checkAndDeclare(argl,form,identSig,e); rest identSig)
- [getArgumentModeOrMoan(a,form,e) for a in argl]
- argModeList:= stripOffSubdomainConditions(argModeList,argl)
- signature':= [first signature,:argModeList]
- if null identSig then --make $op a local function
- oldE := put($op,'mode,['Mapping,:signature'],oldE)
-
- --obtain target type if not given
- if null first signature' then signature':=
- identSig => identSig
- getSignature($op,rest signature',e) or return nil
- e:= giveFormalParametersValues(argl,e)
-
- $signatureOfForm:= signature' --this global is bound in compCapsuleItems
- $functionLocations := [[[$op,$signatureOfForm],:lineNumber],
- :$functionLocations]
- e:= addDomain(first signature',e)
- e:= compArgumentConditions e
-
- if $profileCompiler then
- for x in argl for t in rest signature' repeat profileRecord('arguments,x,t)
-
-
- --4. introduce needed domains into extendedEnv
- for domain in signature' repeat e:= addDomain(domain,e)
-
- --6. compile body in environment with extended environment
- rettype:= resolve(signature'.target,$returnMode)
-
- localOrExported :=
- not MEMQ($op,$formalArgList) and
- getmode($op,e) is ['Mapping,:.] => 'local
- 'exported
-
- --6a skip if compiling only certain items but not this one
- -- could be moved closer to the top
- formattedSig := formatUnabbreviated ['Mapping,:signature']
- $compileOnlyCertainItems and _
- not member($op, $compileOnlyCertainItems) =>
- sayBrightly ['" skipping ", localOrExported,:bright $op]
- [nil,['Mapping,:signature'],oldE]
- sayBrightly ['" compiling ",localOrExported,
- :bright $op,'": ",:formattedSig]
----------------------> new <---------------------------------
- returnType := signature'.target
--- trialT := returnType = "$" and get("Rep",'value,e) and comp(body,'Rep,e)
- trialT := returnType = "$" and comp(body,$EmptyMode,e)
- ------------------------------------------------------ 11/1/94
- -- try comp-ing in $EmptyMode; if succeed
- -- if we succeed then trialT.mode = "$" or "Rep"
- -- do a coerce to get the correct result
- T := (trialT and coerce(trialT,returnType))
- -------------------------------------- 11/1/94
- or CATCH('compCapsuleBody, compOrCroak(body,returnType,e))
- markChanges(originalDef,T,$signatureOfForm)
- [nil,['Mapping,:signature'],oldE]
- ---------------------------------
-
-compCapsuleInner(itemList,m,e) ==
- e:= addInformation(m,e)
- --puts a new 'special' property of $Information
- data:= ["PROGN",:itemList]
- --RPLACd by compCapsuleItems and Friends
- e:= compCapsuleItems(itemList,nil,e)
- $convert2NewCompiler =>
- [nil,m,e] --nonsense but that's fine
- localParList:= $functorLocalParameters
- if $addForm then data:= ['add,$addForm,data]
- code:=
- $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => data
- processFunctor($form,$signature,data,localParList,e)
- [MKPF([:$getDomainCode,code],"PROGN"),m,e]
-
-compSingleCapsuleItem(item,$predl,$e) ==
- $localImportStack : local := nil
- $localDeclareStack: local := nil
- $markFreeStack: local := nil
- newItem := macroExpandInPlace(item,qe(25,$e))
- qe(26,$e)
- doIt(newItem, $predl)
- qe(27,$e)
- $e
-
-compImport(["import",:doms],m,e) ==
- for dom in doms repeat
- dom := markKillAll dom
- markImport dom
- e:=addDomain(dom,e)
- ["/throwAway",$NoValueMode,e]
-
-mkUnion(a,b) ==
- b="$" and $Rep is ["Union",:l] => b
- a is ["Union",:l] =>
- b is ["Union",:l'] => ["Union",:setUnion(l,l')]
- member(b, l) => a
- ["Union",:setUnion([b],l)]
- b is ["Union",:l] =>
- member(a, l) => b
- ["Union",:setUnion([a],l)]
- string? a => ["Union",b,a]
- ["Union",a,b]
-
-compForMode(x,m,e) ==
- $compForModeIfTrue: local:= true
- $convert2NewCompiler: local := nil
- comp(x,m,e)
-
-compMakeCategoryObject(c,$e) ==
- not isCategoryForm(c,$e) => nil
- c := markKillAll c
- u:= mkEvalableCategoryForm c => [eval markKillAll u,$Category,$e]
- nil
-
-macroExpand(x,e) == --not worked out yet
- atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x)
- x is ['DEF,lhs,sig,spCases,rhs] =>
- ['DEF,macroExpand(lhs,e), macroExpandList(sig,e),macroExpandList(spCases,e),
- macroExpand(rhs,e)]
- x is ['MI,a,b] =>
- ['MI,a,macroExpand(b,e)]
- macroExpandList(x,e)
-
---======================================================================
--- From apply.boot
---======================================================================
-applyMapping([op,:argl],m,e,ml) ==
- #argl~=#ml-1 => nil
- isCategoryForm(first ml,e) =>
- --is op a functor?
- pairlis:= pairList(argl,$FormalMapVariableList)
- ml' := SUBLIS(pairlis, ml)
- argl':=
- [T.expr for x in argl for m' in rest ml'] where
- T() == [.,.,e]:= comp(x,m',e) or return "failed"
- if argl'="failed" then return nil
- form:= [op,:argl']
----------------------> new <----------------------------
- if constructor? op then form := markKillAll form
----------------------> new <----------------------------
- convert([form,first ml',e],m)
- argl':=
- [T.expr for x in argl for m' in rest ml] where
- T() == [.,.,e]:= comp(x,m',e) or return "failed"
- if argl'="failed" then return nil
- form:=
- not MEMQ(op,$formalArgList) and atom op and not get(op,'value,e) =>
- nprefix := $prefix or
- -- following needed for referencing local funs at capsule level
- getAbbreviation($op,#rest $form)
- [op',:argl',"$"] where
- op':= makeSymbol strconc(encodeItem nprefix,";",encodeItem op)
- ['%call,['applyFun,op],:argl']
- pairlis := pairList(argl',$FormalMapVariableList)
- convert([form,SUBLIS(pairlis,first ml),e],m)
-
-compFormWithModemap(form,m,e,modemap) ==
- compFormWithModemap1(form,m,e,modemap,true) or compFormWithModemap1(form,m,e,modemap,false)
-
-compFormWithModemap1(form,m,e,modemap,Rep2Dollar?) ==
- [op,:argl] := form := markKillExpr form
- [[dc,:.],:.] := modemap
-----------> new: <-----------
- if Rep2Dollar? then
- if dc = 'Rep then
- modemap := SUBST('Rep,'_$,modemap)
- m := SUBST('Rep,'_$,m)
- else return nil
-----------> new: <-----------
- [map:= [.,target,:.],[pred,impl]]:= modemap
- -- this fails if the subsuming modemap is conditional
- --impl is ['Subsumed,:.] => nil
- if isCategoryForm(target,e) and isFunctor op then
- [modemap,e]:= substituteIntoFunctorModemap(argl,modemap,e) or return nil
- [map:= [.,target,:.],:cexpr]:= modemap
- sv:=listOfSharpVars map
- if sv then
- -- SAY [ "compiling ", op, " in compFormWithModemap,
- -- mode= ",map," sharp vars=",sv]
- for x in argl for ss in $FormalMapVariableList repeat
- if ss in sv then
- [map:= [.,target,:.],:cexpr]:= modemap :=SUBST(x,ss,modemap)
- -- SAY ["new map is",map]
- not (target':= coerceable(target,m,e)) => nil
- markMap := map
- map:= [target',:rest map]
- [f,Tl,sl]:= compApplyModemap(form,modemap,e) or return nil
-
- --generate code; return
- T:=
- e':=
- Tl => last(Tl).env
- e
- [x',m',e'] where
- m':= SUBLIS(sl,map.1)
- x':=
- form':= [f,:[t.expr for t in Tl]]
- m'=$Category or isCategoryForm(m',e) => form'
- -- try to deal with new-style Unions where we know the conditions
- op = "elt" and f is ['XLAM,:.] and IDENTP(z:=first argl) and
- (c:=get(z,'condition,e)) and
- c is [["case",=z,c1]] and
- (c1 is ['_:,=(second argl),=m] or EQ(c1,second argl) ) =>
--- first is a full tag, as placed by getInverseEnvironment
--- second is what getSuccessEnvironment will place there
- ['%tail,z]
- markTran(form,form',markMap,e')
- qt(18,T)
- convert(T,m)
-
-convert(T,m) ==
- tcheck T
- qe(23,T.env)
- coerce(T,resolve(T.mode,m) or return nil)
-
-compElt(origForm,m,E) ==
- form := markKillAll origForm
- form isnt ["elt",aDomain,anOp] => compForm(origForm,m,E)
- aDomain="Lisp" =>
- markLisp([anOp',m,E],E)where anOp'() == (anOp=$Zero => 0; anOp=$One => 1; anOp)
- isDomainForm(aDomain,E) =>
- markImport opOf aDomain
- E:= addDomain(aDomain,E)
- mmList:= getModemapListFromDomain(anOp,0,aDomain,E)
- modemap:=
- n:=#mmList
- 1=n => mmList.0
- 0=n =>
- return
- stackMessage ['"Operation ","%b",anOp,"%d",
- '"missing from domain: ", aDomain]
- stackWarning ['"more than 1 modemap for: ",anOp,
- '" with dc=",aDomain,'" ===>"
- ,mmList]
- mmList.0
-----------> new: <-----------
- if aDomain = 'Rep then
- modemap := SUBST('Rep,'_$,modemap)
- m := SUBST('Rep,'_$,m)
-----------> new: <-----------
- [sig,[pred,val]]:= modemap
- #sig~=2 and val isnt ["CONST",:.] => nil
---+
- val := genDeltaEntry([opOf anOp,:modemap],E)
- x := markTran(origForm,[val],sig,[E])
- [x,second sig,E] --implies fn calls used to access constants
- compForm(origForm,m,E)
-
-pause op == op
-compApplyModemap(form,modemap,$e) ==
- sl := nil
- [op,:argl] := form --form to be compiled
- [[mc,mr,:margl],:fnsel] := modemap --modemap we are testing
-
- -- $e is the current environment
- -- sl substitution list, nil means bottom-up, otherwise top-down
-
- -- 0. fail immediately if #argl=#margl
-
- if #argl~=#margl then return nil
-
- -- 1. use modemap to evaluate arguments, returning failed if
- -- not possible
-
- lt:=
- [[.,m',$e]:=
- comp(y,g,$e) or return "failed" where
- g:= SUBLIS(sl,m) where
- sl:= pmatchWithSl(m',m,sl) for y in argl for m in margl]
- lt="failed" => return nil
-
- -- 2. coerce each argument to final domain, returning failed
- -- if not possible
-
- lt':= [coerce(y,d) or return "failed"
- for y in lt for d in SUBLIS(sl,margl)]
- lt'="failed" => return nil
-
- -- 3. obtain domain-specific function, if possible, and return
-
- --$bindings is bound by compMapCond
- [f,$bindings]:= compMapCond(op,mc,sl,fnsel) or return nil
-
---+ can no longer trust what the modemap says for a reference into
---+ an exterior domain (it is calculating the displacement based on view
---+ information which is no longer valid; thus ignore this index and
---+ store the signature instead.
-
---$NRTflag=true and f is [op1,d,.] and NE(d,'$) and member(op1,'(ELT CONST)) =>
- f is [op1,d,.] and op1 in '(ELT CONST Subsumed) =>
- [genDeltaEntry([op,:modemap],$e),lt',$bindings]
- markImport mc
- [f,lt',$bindings]
-
-compMapCond''(cexpr,dc) ==
- cexpr=true => true
- --cexpr = "true" => true
----------------> new <----------------------
- cexpr is [op,:l] and op in '(and AND) => and/[compMapCond''(u,dc) for u in l]
- cexpr is [op,:l] and op in '(or OR) => or/[compMapCond''(u,dc) for u in l]
----------------> new <----------------------
- cexpr is ["not",u] => not compMapCond''(u,dc)
- cexpr is ["has",name,cat] => (knownInfo cexpr => true; false)
- --for the time being we'll stop here - shouldn't happen so far
- --$disregardConditionIfTrue => true
- --stackSemanticError(("not known that",'"%b",name,
- -- '"%d","has",'"%b",cat,'"%d"),nil)
- --now it must be an attribute
- member(["ATTRIBUTE",dc,cexpr],get("$Information","special",$e)) => true
- --for the time being we'll stop here - shouldn't happen so far
- stackMessage ["not known that",'"%b",dc,'"%d","has",'"%b",cexpr,'"%d"]
- false
-
---======================================================================
--- From nruncomp.boot
---======================================================================
-optCallEval u ==
- u is ["List",:.] => List Integer()
- u is ["Vector",:.] => Vector Integer()
- u is ["PrimitiveArray",:.] => PrimitiveArray Integer()
- u is ["FactoredForm",:.] => FactoredForm Integer()
- u is ["Matrix",:.] => Matrix Integer()
- eval u
-
-optDeltaEntry(op,sig,dc,eltOrConst) ==
- return nil --------> kill it
- $killOptimizeIfTrue = true => nil
- ndc :=
- dc = '$ => $functorForm
- atom dc and (dcval := get(dc,'value,$e)) => dcval.expr
- dc
---if (atom dc) and (dcval := get(dc,'value,$e))
--- then ndc := dcval.expr
--- else ndc := dc
- sig := SUBST(ndc,dc,sig)
- not optimizableDomain? ndc => nil
- dcval := optCallEval ndc
- -- MSUBST guarantees to use EQUAL testing
- sig := MSUBST(devaluate dcval, ndc, sig)
- if rest ndc then
- for new in rest devaluate dcval for old in rest ndc repeat
- sig := MSUBST(new,old,sig)
- -- optCallEval sends (List X) to (LIst (Integer)) etc,
- -- so we should make the same transformation
- fn := compiledLookup(op,sig,dcval)
- if null fn then
- -- following code is to handle selectors like first, rest
- nsig := [quoteSelector tt for tt in sig] where
- quoteSelector(x) ==
- not(IDENTP x) => x
- get(x,'value,$e) => x
- x='$ => x
- MKQ x
- fn := compiledLookup(op,nsig,dcval)
- if null fn then return nil
- eltOrConst="CONST" =>
- hehe fn
- [op] -----------> return just the op here
--- ['XLAM,'ignore,MKQ SPADCALL fn]
- getFunctionReplacement first fn
-
-genDeltaEntry(opMmPair,e) ==
---called from compApplyModemap
---$NRTdeltaLength=0.. always equals length of $NRTdeltaList
- [.,[odc,:.],.] := opMmPair
- --opModemapPair := SUBLIS($LocalDomainAlist,opMmPair)
- [op,[dc,:sig],[.,cform:=[eltOrConst,:.]]] := opMmPair
- if $profileCompiler = true then
- profileRecord(dc,op,sig)
--- markImport dc
- eltOrConst = 'XLAM => cform
- if eltOrConst = 'Subsumed then eltOrConst := 'ELT
- -- following hack needed to invert Rep to $ substitution
- if odc = 'Rep and cform is [.,.,osig] then sig:=osig
- newimp := optDeltaEntry(op,sig,dc,eltOrConst) => newimp
- setDifference(listOfBoundVars dc,$functorLocalParameters) ~= [] =>
- ['applyFun,['compiledLookupCheck,MKQ op,
- mkList consSig(sig,dc),consDomainForm(dc,nil)]]
- --if cons? dc then
- -- sig := substitute('$,dc,sig)
- -- cform := substitute('$,dc,cform)
- opModemapPair :=
- [op,[dc,:[genDeltaSig x for x in sig]],['T,cform]] -- force pred to T
- if null NRTassocIndex dc and
- (member(dc,$functorLocalParameters) or cons? dc) then
- --create "%domain" entry to $NRTdeltaList
- $NRTdeltaList:= [["%domain",NRTaddInner dc,:dc],:$NRTdeltaList]
- saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp]
- $NRTdeltaLength := $NRTdeltaLength+1
- compEntry:=
- dc
- saveNRTdeltaListComp.first := compEntry
- chk(saveNRTdeltaListComp,102)
- u :=
- [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index() ==
- (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1
- --n + 1 since $NRTdeltaLength is 1 too large
- $NRTdeltaList:= [opModemapPair,:$NRTdeltaList]
- $NRTdeltaListComp:=[nil,:$NRTdeltaListComp]
- $NRTdeltaLength := $NRTdeltaLength+1
- 0
- u
-
---======================================================================
--- From nruncomp.boot
---======================================================================
-parseIf t ==
- t isnt [p,a,b] => t
- ifTran(parseTran p,parseTran a,parseTran b) where
- ifTran(p,a,b) ==
- null($InteractiveMode) and p='true => a
- null($InteractiveMode) and p='false => b
- p is ['not,p'] => ifTran(p',b,a)
- p is ['IF,p',a',b'] => ifTran(p',ifTran(a',COPY a,COPY b),ifTran(b',a,b))
- p is ['SEQ,:l,['exit,1,p']] =>
- ['SEQ,:l,['exit,1,ifTran(p',incExitLevel a,incExitLevel b)]]
- --this assumes that l has no exits
- a is ['IF, =p,a',.] => ['IF,p,a',b]
- b is ['IF, =p,.,b'] => ['IF,p,a,b']
--- makeSimplePredicateOrNil p is ['SEQ,:s,['exit,1,val]] =>
--- parseTran ['SEQ,:s,['exit,1,incExitLevel ['IF,val,a,b]]]
- ['IF,p,a,b]
-
---======================================================================
--- From parse.boot
---======================================================================
-parseNot u == ['not,parseTran first u]
-
-makeSimplePredicateOrNil p == nil
-
---======================================================================
--- From g-cndata.boot
---======================================================================
-mkUserConstructorAbbreviation(c,a,type) ==
- if $AnalyzeOnly or $convert2NewCompiler then
- $abbreviationStack := [[type,a,:c],:$abbreviationStack]
- if cons? c then c:= first c -- Existing constructors will be wrapped
- constructorAbbreviationErrorCheck(c,a,type,'abbreviationError)
- clearClams()
- clearConstructorCache(c)
- installConstructor(c,type)
- setAutoLoadProperty(c)
-
---======================================================================
--- From iterator.boot
---======================================================================
-
-compreduce(form is [.,op,x],m,e) ==
- T := compForm(form,m,e) or return nil
- y := T.expr
- y.first := "REDUCE"
- ------------------<== distinquish this as the special reduce form
- (y is ["REDUCE",:.]) and (id:= getIdentity(op,e)) and (u := comp0(id,m,e)) and
- # getNumberTypesInScope() > 1 => markSimpleReduce([:y, ["@",u.expr,m]], T)
- T
-
-compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) ==
--------------------------------> 11/28 all new to preserve collect forms
- markImport m
- [collectOp,:itl,body]:= collectForm
- $e:= e
- itl:= [([.,$e]:= compIterator(x,$e) or return "failed").0 for x in itl]
- itl="failed" => return nil
- e:= $e
- T0 := comp0(body,m,e) or return nil
- md := T0.mode
- T1 := compOrCroak(collectForm,["List",md],e)
- T := [["REDUCE",op,nil,T1.expr],md,T1.env]
- markReduce(form,T)
-
-compIterator(it,e) ==
- it is ["IN",x,y] =>
- --these two lines must be in this order, to get "for f in list f"
- --to give an error message if f is undefined
- ---------------> new <---------------------
- [y',m,e] := markInValue(y, e)
- x := markKillAll x
- ------------------
- $formalArgList:= [x,:$formalArgList]
- [.,mUnder]:=
- modeIsAggregateOf("List",m,e) or modeIsAggregateOf("Vector",m,e) or return
- stackMessage ["mode: ",m," must be a list or vector of some mode"]
- if null get(x,"mode",e) then [.,.,e]:=
- compMakeDeclaration(x,mUnder,e) or return nil
- e:= giveVariableSomeValue(x,mUnder,e)
- markReduceIn(it, [["IN",x,y'],e])
- it is ["ON",x,y] =>
----------------> new <---------------------
- x := markKillAll x
- ------------------
- $formalArgList:= [x,:$formalArgList]
- y := markKillAll y
- markImport m
----------------> new <---------------------
- [y',m,e]:= comp(y,$EmptyMode,e) or return nil
- [.,mUnder]:=
- modeIsAggregateOf("List",m,e) or return
- stackMessage ["mode: ",m," must be a list of other modes"]
- if null get(x,"mode",e) then [.,.,e]:=
- compMakeDeclaration(x,m,e) or return nil
- e:= giveVariableSomeValue(x,m,e)
- [["ON",x,y'],e]
- it is ["STEP",oindex,start,inc,:optFinal] =>
- index := markKillAll oindex
- $formalArgList:= [index,:$formalArgList]
- --if all start/inc/end compile as small integers, then loop
- --is compiled as a small integer loop
- final':= nil
----------------> new <---------------------
- u := smallIntegerStep(it,index,start,inc,optFinal,e) => u
----------------> new <---------------------
- [start,.,e]:=
- comp(markKillAll start,$Integer,e) or return
- stackMessage ["start value of index: ",start," must be an integer"]
- [inc,.,e]:=
- comp(markKillAll inc,$Integer,e) or return
- stackMessage ["index increment:",inc," must be an integer"]
- if optFinal is [final] then
- [final,.,e]:=
- comp(markKillAll final,$Integer,e) or return
- stackMessage ["final value of index: ",final," must be an integer"]
- optFinal:= [final]
- indexmode:=
- comp(third it,$NonNegativeInteger,e) => $NonNegativeInteger
- $Integer
--- markImport ['Segment,indexmode]
- if null get(index,"mode",e) then [.,.,e]:=
- compMakeDeclaration(index,indexmode,e) or return nil
- e:= giveVariableSomeValue(index,indexmode,e)
- markReduceStep(it, [["STEP",markStep(index),start,inc,:optFinal],e])
- it is ["WHILE",p] =>
- [p',m,e]:=
- comp(p,$Boolean,e) or return
- stackMessage ["WHILE operand: ",p," is not Boolean valued"]
- markReduceWhile(it, [["WHILE",p'],e])
- it is ["UNTIL",p] => markReduceUntil(it, ($until:= p; ['$until,e]))
- it is ["|",x] =>
- u:=
- comp(x,$Boolean,e) or return
- stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"]
- markReduceSuchthat(it, [["|",u.expr],u.env])
- nil
-
-smallIntegerStep(it,index,start,inc,optFinal,e) ==
- start := markKillAll start
- inc := markKillAll inc
- optFinal := markKillAll optFinal
- startNum := source2Number start
- incNum := source2Number inc
- mode := get(index,"mode",e)
---fail if
-----> a) index has a mode that is not $SmallInteger
-----> b) one of start,inc, final won't comp as a $SmallInteger
- mode and mode ~= $SmallInteger => nil
- null (start':= comp(start,$SmallInteger,e)) => nil
- null (inc':= comp(inc,$SmallInteger,start'.env)) => nil
- if optFinal is [final] and not (final':= comp(final,$SmallInteger,inc'.env)) then
--- not (integer? startNum and integer? incNum) => return nil
--- null integer? startNum or abs startNum > 100 => return nil
- -----> assume that optFinal is $SmallInteger
- T := comp(final,$EmptyMode,inc'.env) or return nil
- final' := T
- maximalSuperType T.mode ~= $Integer => return nil
- givenRange := T.mode
- indexmode:= $SmallInteger
- [.,.,e]:= compMakeDeclaration(index,indexmode,
- (final' => final'.env; inc'.env)) or return nil
- range :=
- integer? startNum and integer? incNum =>
- startNum > 0 and incNum > 0 => $PositiveInteger
- startNum < 0 and incNum < 0 => $NegativeInteger
- incNum > 0 => $NonNegativeInteger --startNum = 0
- $NonPositiveInteger
- givenRange => givenRange
- nil
- e:= put(index,"range",range,e)
- e:= giveVariableSomeValue(index,indexmode,e)
- noptFinal :=
- final' =>
- [final'.expr]
- nil
- [markStepSI(it,["ISTEP",index,start'.expr,inc'.expr,:noptFinal]),e]
-
-source2Number n ==
- n := markKillAll n
- n = $Zero => 0
- n = $One => 1
- n
-
-compRepeatOrCollect(form,m,e) ==
- fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList
- ,e) where
- fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) ==
- $until: local
- [repeatOrCollect,:itl,body]:= form
- itl':=
- [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl]
- itl'="failed" => nil
- targetMode:= first $exitModeStack
--- pp '"---------"
--- pp targetMode
- bodyMode:=
- repeatOrCollect="COLLECT" =>
- targetMode = '$EmptyMode => '$EmptyMode
- (u:=modeIsAggregateOf('List,targetMode,e)) =>
- second u
- (u:=modeIsAggregateOf('Vector,targetMode,e)) =>
- repeatOrCollect:='COLLECTV
- second u
- stackMessage('"Invalid collect bodytype")
- return nil
- -- If we're doing a collect, and the type isn't conformable
- -- then we've boobed. JHD 26.July.1990
- $NoValueMode
- [body',m',e']:= T :=
- -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or
- compOrCroak(body,bodyMode,e) or return nil
- markRepeatBody(body, T)
- if $until then
- [untilCode,.,e']:= comp($until,$Boolean,e')
- itl':= substitute(["UNTIL",untilCode],'$until,itl')
- form':= [repeatOrCollect,:itl',body']
- m'':=
- repeatOrCollect="COLLECT" =>
- (u:=modeIsAggregateOf('List,targetMode,e)) => first u
- ["List",m']
- repeatOrCollect="COLLECTV" =>
- (u:=modeIsAggregateOf('Vector,targetMode,e)) => first u
- ["Vector",m']
- m'
---------> new <--------------
- markImport m''
---------> new <--------------
- markRepeat(form,coerceExit([form',m'',e'],targetMode))
-
-chaseInferences(origPred,$e) ==
- pred := markKillAll origPred
- ----------------------------12/4/94 do this immediately
- foo hasToInfo pred where
- foo pred ==
- knownInfo pred => nil
- $e:= actOnInfo(pred,$e)
- pred:= infoToHas pred
- for u in get("$Information","special",$e) repeat
- u is ['%when,:l] =>
- for [ante,:conseq] in l repeat
- ante=pred => [foo w for w in conseq]
- ante is ["and",:ante'] and member(pred,ante') =>
- ante':= delete(pred,ante')
- v':=
- # ante'=1 => first ante'
- ["and",:ante']
- v':= ['%when,[v',:conseq]]
- member(v',get("$Information","special",$e)) => nil
- $e:=
- put("$Information","special",[v',:
- get("$Information","special",$e)],$e)
- nil
- $e
-
---======================================================================
--- doit Code
---======================================================================
-doIt(item,$predl) ==
- $GENNO: local:= 0
- $coerceList: local := nil
- --->
- if item is ['PART,.,a] then item := a
- -------------------------------------
- item is ['SEQ,:.] => doItSeq item
- isDomainForm(item,$e) => doItDomain item
- item is ["%LET",:.] => doItLet item
- item is [":",a,t] => [.,.,$e]:=
- markDeclaredImport markKillAll t
- compOrCroak(item,$EmptyMode,$e)
- item is ["import",:doms] =>
- item := ["import",:(doms := markKillAll doms)]
- for dom in doms repeat
- sayBrightly ['" importing ",:formatUnabbreviated dom]
- [.,.,$e] := compOrCroak(item,$EmptyMode,$e)
- wiReplaceNode(item,'(PROGN),10)
- item is ["IF",:.] => doItIf(item,$predl,$e)
- item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e)
- item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e)
- item is ['DEF,:.] => doItDef item
- T:= compOrCroak(item,$EmptyMode,$e) => doItExpression(item,T)
- true => cannotDo()
-
-holdIt item == item
-
-doItIf(item is [.,p,x,y],$predl,$e) ==
- olde:= $e
- [p',.,$e]:= qt(19,comp(p,$Boolean,$e)) or userError ['"not a Boolean:",p]
- oldFLP:=$functorLocalParameters
- if x~="%noBranch" then
---> new <-----------------------
- qe(20,compSingleCapsuleItem(x,[p,:$predl],getSuccessEnvironment(markKillAll p,$e)))
----> new -----------
- x':=localExtras(oldFLP)
- where localExtras(oldFLP) ==
- EQ(oldFLP,$functorLocalParameters) => NIL
- flp1:=$functorLocalParameters
- oldFLP':=oldFLP
- n:=0
- while oldFLP' repeat
- oldFLP':=rest oldFLP'
- flp1:=rest flp1
- n:=n+1
- -- Now we have to add code to compile all the elements
- -- of functorLocalParameters that were added during the
- -- conditional compilation
- nils:=ans:=[]
- for u in flp1 repeat -- is =u form always an atom?
- if atom u or (or/[v is [.,=u,:.] for v in $getDomainCode])
- then
- nils:=[u,:nils]
- else
- gv := gensym()
- ans:=[["%LET",gv,u],:ans]
- nils:=[gv,:nils]
- n:=n+1
-
- $functorLocalParameters:=[:oldFLP,:reverse nils]
- reverse ans
- oldFLP:=$functorLocalParameters
- if y~="%noBranch" then
---> new <-----------------------
- qe(21,compSingleCapsuleItem(y,[['not, p],:$predl],getInverseEnvironment(markKillAll p,olde)))
---> -----------
- y':=localExtras(oldFLP)
- wiReplaceNode(item,['%when,[p',x,:x'],['%otherwise,y,:y']],12)
-
-doItSeq item ==
- ['SEQ,:l,['exit,1,x]] := item
- item.first := "PROGN"
- lastNode(item).first := x
- for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e)
-
-doItDomain item ==
- -- convert naked top level domains to import
- u:= ["import", [first item,:rest item]]
- markImport second u
- stackWarning ["Use: import ", [first item,:rest item]]
---wiReplaceNode(item, u, 14)
- item.first := first u
- item.rest := rest u
- doIt(item,$predl)
-
-doItLet item ==
- qe(3,$e)
- res := doItLet1 item
- qe(4,$e)
- res
-
-doItLet1 item ==
- ["%LET",lhs,rhs,:.] := item
- not (compOrCroak(item,$EmptyMode,$e) is [code,.,$e]) =>
- stackSemanticError(["cannot compile assigned value to",:bright lhs],nil)
- qe(5,$e)
- code := markKillAll code
- not (code is ["%LET",lhs',rhs',:.] and atom lhs') =>
- code is ["PROGN",:.] =>
- stackSemanticError(["multiple assignment ",item," not allowed"],nil)
- wiReplaceNode(item, code, 24)
- lhs:= lhs'
- if not member(KAR rhs,$NonMentionableDomainNames) and
- not MEMQ(lhs, $functorLocalParameters) then
- $functorLocalParameters:= [:$functorLocalParameters,lhs]
- if (rhs' := rhsOfLetIsDomainForm code) then
- if isFunctor rhs' then
- $globalImportDefAlist := pp [[lhs, :rhs'],:$globalImportDefAlist]
- if lhs="Rep" then
- $Representation:= (get("Rep",'value,$e)).expr
- --$Representation bound by compDefineFunctor, used in compNoStacking
---+
- if $NRTopt = true
- then NRTgetLocalIndex $Representation
---+
- $LocalDomainAlist:= --see genDeltaEntry
- [[lhs,:SUBLIS($LocalDomainAlist,(get(lhs,'value,$e)).0)],:$LocalDomainAlist]
---+
- qe(6,$e)
- code is ["%LET",:.] =>
- rhsCode:= rhs'
- op := '%store
- wiReplaceNode(item,[op,['%tref,'$,NRTgetLocalIndex lhs],rhsCode], 16)
- wiReplaceNode(item, code, 18)
-
-rhsOfLetIsDomainForm code ==
- code is ["%LET",.,rhs',:.] =>
- isDomainForm(rhs',$e) => rhs'
- isDomainForm(rhs' := markKillAll rhs',$e) => rhs'
- false
- false
-
-doItDef item ==
- ['DEF,[op,:.],:.] := item
- body:= isMacro(item,$e) => $e := putMacro(op,body,$e)
- [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e)
- chk(item,3)
- item.first := "CodeDefine"
- --Note that DescendCode, in CodeDefine, is looking for this
- second(item).rest := [$signatureOfForm]
- chk(item,4)
- --This is how the signature is updated for buildFunctor to recognise
---+
- functionPart:= ['dispatchFunction,t.expr]
- wiReplaceNode(CDDR item,[functionPart], 20)
- chk(item, 30)
-
-doItExpression(item,T) ==
- SETQ($ITEM,COPY item)
- SETQ($T1,COPY T.expr)
- chk(T.expr, 304)
- u := markCapsuleExpression(item, T)
- [code,.,$e]:= u
- wiReplaceNode(item,code, 22)
-
-wiReplaceNode(node,ocode,key) ==
- ncode := [first ocode,:rest ocode]
- code := replaceNodeInStructureBy(node,ncode)
- SETQ($NODE,COPY node)
- SETQ($NODE1, COPY first code)
- SETQ($NODE2, COPY rest code)
- node.first := first code
- node.rest := rest code
- chk(code, key)
- chk(node, key + 1)
-
-replaceNodeInStructureBy(node, x) ==
- $nodeCopy: local := [first node,:rest node]
- replaceNodeBy(node, x)
- node
-
-replaceNodeBy(node, x) ==
- atom x => nil
- for y in tails x | x is [=node,:.] repeat x.first := $nodeCopy
- nil
-
-chk(x,key) == fn(x,0,key) where fn(x,cnt,key) ==
- cnt > 10000 =>
- sayBrightly ["--> ", key, " <---"]
- hahaha(key)
- atom x => cnt
- vector? x => systemError nil
- for y in x repeat cnt := fn(y, cnt + 1, key)
- cnt
-
diff --git a/src/share/doc/msgs/s2-us.msgs b/src/share/doc/msgs/s2-us.msgs
index d13ced80..a9f281bd 100644
--- a/src/share/doc/msgs/s2-us.msgs
+++ b/src/share/doc/msgs/s2-us.msgs
@@ -1022,11 +1022,6 @@ S2IZ0083
".ao".
S2IZ0084
The )library system command was not called after compilation.
-S2IZ0085
- Warning: translation of an old-style source code ".spad" file to a new-style
- ".as" file changes the old system compiler. If you wish to use the old
- system compiler for regular compilation, you must exit and re-enter
- OpenAxiom.
S2IZ0086
Cannot write to file with name %b %1 %d .
S2IZ0087
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-04 07:55:40 +0000