diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ChangeLog | 18 | ||||
| -rw-r--r-- | src/interp/Makefile.in | 19 | ||||
| -rw-r--r-- | src/interp/i-syscmd.boot | 39 | ||||
| -rw-r--r-- | src/interp/mark.boot | 1543 | ||||
| -rw-r--r-- | src/interp/nspadaux.lisp | 119 | ||||
| -rw-r--r-- | src/interp/pspad1.boot | 745 | ||||
| -rw-r--r-- | src/interp/pspad2.boot | 663 | ||||
| -rw-r--r-- | src/interp/spad.lisp | 18 | ||||
| -rw-r--r-- | src/interp/util.lisp | 11 | ||||
| -rw-r--r-- | src/interp/wi1.boot | 1250 | ||||
| -rw-r--r-- | src/interp/wi2.boot | 1132 | ||||
| -rw-r--r-- | src/share/doc/msgs/s2-us.msgs | 5 |
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 |