From d34a01104fa6d8156a29d0e5d810e12823cba02d Mon Sep 17 00:00:00 2001 From: dos-reis Date: Fri, 19 Oct 2007 04:46:50 +0000 Subject: remove more pamphlets --- src/interp/int-top.boot | 439 +++++++++++ src/interp/int-top.boot.pamphlet | 550 -------------- src/interp/intfile.boot | 63 ++ src/interp/intfile.boot.pamphlet | 83 -- src/interp/lisplib.boot | 688 +++++++++++++++++ src/interp/lisplib.boot.pamphlet | 714 ----------------- src/interp/mark.boot | 1496 ++++++++++++++++++++++++++++++++++++ src/interp/mark.boot.pamphlet | 1520 ------------------------------------- src/interp/msg.boot | 553 ++++++++++++++ src/interp/msg.boot.pamphlet | 577 -------------- src/interp/pf2atree.boot | 555 ++++++++++++++ src/interp/pf2atree.boot.pamphlet | 575 -------------- src/interp/postpar.boot | 531 +++++++++++++ src/interp/postpar.boot.pamphlet | 555 -------------- 14 files changed, 4325 insertions(+), 4574 deletions(-) create mode 100644 src/interp/int-top.boot delete mode 100644 src/interp/int-top.boot.pamphlet create mode 100644 src/interp/intfile.boot delete mode 100644 src/interp/intfile.boot.pamphlet create mode 100644 src/interp/lisplib.boot delete mode 100644 src/interp/lisplib.boot.pamphlet create mode 100644 src/interp/mark.boot delete mode 100644 src/interp/mark.boot.pamphlet create mode 100644 src/interp/msg.boot delete mode 100644 src/interp/msg.boot.pamphlet create mode 100644 src/interp/pf2atree.boot delete mode 100644 src/interp/pf2atree.boot.pamphlet create mode 100644 src/interp/postpar.boot delete mode 100644 src/interp/postpar.boot.pamphlet (limited to 'src/interp') diff --git a/src/interp/int-top.boot b/src/interp/int-top.boot new file mode 100644 index 00000000..9d444b3f --- /dev/null +++ b/src/interp/int-top.boot @@ -0,0 +1,439 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +ncParseAndInterpretString s == + processInteractive(packageTran parseFromString s, nil) + +ncParseFromString s == + zeroOneTran packageTran CATCH("SPAD_READER", parseFromString s) + +ncINTERPFILE(file, echo) == + savedEcho := $EchoLines + savedReadingFile := $ReadingFile + $EchoLines: fluid := echo + $ReadingFile: fluid := true + result := SpadInterpretFile file + $EchoLines := savedEcho + $ReadingFile := savedReadingFile + result + +ncGetFunction(op, dom, sig) == + applyInPackage(function getNCfunction,_ + [rePackageTran(op, '"boot"),_ + rePackageTran(dom, '"boot"),_ + rePackageTran(sig, '"boot")],_ + '"BOOT") + +applyInPackage(fun, args, package) == + savedPackage := _*PACKAGE_* + SETQ(_*PACKAGE_*, FIND_-PACKAGE package) + result := apply(fun, args) + SETQ(_*PACKAGE_*, savedPackage) + result + +ncSetCurrentLine l == + setCurrentLine l + + +--% INTERPRETER TOP LEVEL + +spad() == + -- starts the interpreter but does not read in profiles, etc. + $PrintCompilerMessageIfTrue: local + $inLispVM : local := nil + setOutputAlgebra "%initialize%" + runspad() + 'EndOfSpad + +runspad() == + mode:='restart + while mode='restart repeat + resetStackLimits() + CATCH($quitTag, CATCH('coerceFailure, + mode:=CATCH('top__level, ncTopLevel()))) + +ncTopLevel() == +-- Top-level read-parse-eval-print loop for the interpreter. Uses +-- the Bill Burge's parser. + IN_-STREAM: fluid := CURINSTREAM + _*EOF_*: fluid := NIL + $InteractiveMode :fluid := true + $BOOT: fluid := NIL + $NEWSPAD: fluid := true + $SPAD: fluid := true + $e:fluid := $InteractiveFrame + ncIntLoop() + + +ncIntLoop() == + CURINSTREAM : local := _*STANDARD_-OUTPUT_* + CUROUTSTREAM : local := _*STANDARD_-INPUT_* + intloop() + + +intloop () == + mode := $intRestart + while mode = $intRestart repeat + resetStackLimits() + mode := CATCH($intTopLevel, + SpadInterpretStream(1, ["TIM", "DALY", "?"], true)) + + +SpadInterpretStream(str, source, interactive?) == + $fn : local := source + pile? := not interactive? + $libQuiet : local := not interactive? + $newcompMode : local := false +-- following seems useless and causes ccl package problems +-- $InteractiveMode : local := false + + $newcompErrorCount: local := 0 -- SMW Feb 2/90. + -- Used in highComplete, ncHardError etc. + + $okToExecuteMachineCode: local := true -- set false on error + $inclAssertions: local := ["AIX", "CommonLisp"] -- Jan 28/90 + + + $lastPos : local := $nopos ------------>!!! + $erMsgToss : local := false --------------->!!! + $ncMsgList : local := nil + + $systemCommandFunction : local := function InterpExecuteSpadSystemCommand + $shoeReadLineFunction : local := function serverReadLine + $promptMsg : local := 'S2CTP023 + + interactive? => + PRINC(MKPROMPT()) + intloopReadConsole('"", str) + [] + intloopInclude (source,0) + [] + + ----------------------------------------------------------------- + +intloopReadConsole(b, n)== + a:= serverReadLine(_*STANDARD_-INPUT_*) + not STRINGP a => leaveScratchpad() + #a=0 => + PRINC(MKPROMPT()) + intloopReadConsole('"", n) + $DALYMODE and intloopPrefix?('"(",a) => + intnplisp(a) + PRINC(MKPROMPT()) + intloopReadConsole('"",n) + pfx := stripSpaces intloopPrefix?('")fi",a) + pfx and ((pfx = '")fi") or (pfx = '")fin")) => [] + b = '"" and (d := intloopPrefix?('")", a)) => + setCurrentLine d + c := ncloopCommand(d,n) + PRINC(MKPROMPT()) + intloopReadConsole('"", c) + a:=CONCAT(b,a) + ncloopEscaped a => intloopReadConsole(SUBSEQ(a, 0, (LENGTH a) - 1),n) + c := intloopProcessString(a, n) + PRINC(MKPROMPT()) + intloopReadConsole('"", c) + +intloopPrefix?(prefix,whole) == + #prefix > #whole => false + good := true + leading := true + spaces := 0 + i := 0 + len := #prefix + wlen := #whole + for j in 0.. while (good and i < len and j < wlen) repeat + good := (prefix.i = whole.j) or (leading and (whole.j = char " ")) + if prefix.i = whole.j then i := i+1 + if (whole.j = char " ") and leading then + spaces := spaces + 1 + else leading := false + spaces = wlen => nil + if good then SUBSTRING(whole,spaces,nil) else good + + +intloopProcess(n,interactive,s)== + StreamNull s => n + [lines,ptree]:=CAR s + pfAbSynOp?(ptree,"command")=> + if interactive then setCurrentLine tokPart ptree + FUNCALL($systemCommandFunction, tokPart ptree) + intloopProcess(n ,interactive ,CDR s) + intloopProcess(intloopSpadProcess(n,lines,ptree,interactive) + ,interactive ,CDR s) + +intloopEchoParse s== + [dq,stream]:=CAR s + [lines,rest]:=ncloopDQlines(dq,$lines) + setCurrentLine(mkLineList(lines)) + if $EchoLines then ncloopPrintLines lines + $lines:=rest + cons([[lines,npParse dqToList dq]],CDR s) + +intloopInclude0(st, name, n) == + $lines:local:=incStream(st,name) + intloopProcess(n,false, + next(function intloopEchoParse, + next(function insertpile, + next(function lineoftoks,$lines)))) + +intloopInclude(name, n) == + WITH_-OPEN_-FILE(st name, intloopInclude0(st, name, n)) + +intloopInclude1(name,n) == + a:=ncloopIncFileName name + a => intloopInclude(a,n) + n + +intloopProcessString(s,n) == + setCurrentLine s + intloopProcess(n,true, + next(function ncloopParse, + next(function lineoftoks,incString s))) + +$pfMacros := [] + +intloopSpadProcess(stepNo,lines,ptree,interactive?)== + $stepNo:local := stepNo + $currentCarrier := cc := ['carrier] + ncPutQ(cc, 'stepNumber, stepNo) + ncPutQ(cc, 'messages, $ncMsgList) + ncPutQ(cc, 'lines, lines) + $ncMsgList := nil + result := CatchAsCan(flung, Catch("SpadCompileItem", + CATCH($intCoerceFailure, CATCH($intSpadReader, + interp(cc, ptree, interactive?))))) where + + interp(cc, ptree, interactive?) == + ncConversationPhase(function phParse, [cc, ptree]) + ncConversationPhase(function phMacro, [cc]) + ncConversationPhase(function phIntReportMsgs,[cc, interactive?]) + ncConversationPhase(function phInterpret, [cc]) + + #ncEltQ(cc, 'messages) ^= 0 => ncError() + + intSetNeedToSignalSessionManager() + $prevCarrier := $currentCarrier + result = 'ncEnd => stepNo + result = 'ncError => stepNo + result = 'ncEndItem => stepNo + stepNo+1 + +phInterpret carrier == + ptree := ncEltQ(carrier, 'ptree) + val := intInterpretPform(ptree) + ncPutQ(carrier, 'value, val) + + +--% phReportMsgs: carrier[lines,messages,..]-> carrier[lines,messages,..] +phIntReportMsgs(carrier, interactive?) == + $erMsgToss => 'OK + lines := ncEltQ(carrier, 'lines) + msgs := ncEltQ(carrier, 'messages) + nerr := #msgs + ncPutQ(carrier, 'ok?, nerr = 0) + nerr = 0 => 'OK + processMsgList(msgs, lines) + intSayKeyedMsg ('S2CTP010,[nerr]) + 'OK + +mkLineList lines == + l := [CDR line for line in lines | nonBlank CDR line] + #l = 1 => CAR l + l + +nonBlank str == + value := false + for i in 0..MAXINDEX str repeat + str.i ^= char " " => + value := true + return value + value + +ncloopCommand (line,n) == + a:=ncloopPrefix?('")include",line)=> + ncloopInclude1( a,n) + FUNCALL($systemCommandFunction,line) + n + +ncloopEscaped x== + esc :=false + done:=false + for i in (# x) - 1 .. 0 by -1 while not done repeat + done:= + x.i='" ".0 =>false + x.i='"__".0=> + esc:=true + true + true + esc + +ncloopDQlines (dq,stream)== + StreamNull stream + a:= poGlobalLinePosn tokPosn CADR dq + b:= poGlobalLinePosn CAAR stream + streamChop (a-b+1,stream) + +streamChop(n,s)== + if StreamNull s + then [nil,nil] + else if EQL(n,0) + then [nil,s] + else + [a,b]:= streamChop(n-1,cdr s) + line:=car s + c:=ncloopPrefix?('")command",CDR line) + d:= cons(car line,if c then c else cdr line) + [cons(d,a),b] + +ncloopPrintLines lines == + for line in lines repeat WRITE_-LINE CDR line + WRITE_-LINE '" " + +ncloopIncFileName string== + fn := incFileName string + not fn => + WRITE_-LINE (CONCAT(string, '" not found")) + [] + fn + +ncloopParse s== + [dq,stream]:=CAR s + [lines,rest]:=ncloopDQlines(dq,stream) + cons([[lines,npParse dqToList dq]],CDR s) + +ncloopInclude0(st, name, n) == + $lines:local := incStream(st, name) + ncloopProcess(n,false, + next(function ncloopEchoParse, + next(function insertpile, + next(function lineoftoks,$lines)))) + +ncloopInclude(name, n) == + WITH_-OPEN_-FILE(st name, ncloopInclude0(st, name, n)) + +ncloopInclude1(name,n) == + a:=ncloopIncFileName name + a => ncloopInclude(a,n) + n + +incString s== incRenumber incLude(0,[s],0,['"strings"] ,[Top]) + +ncError() == + THROW("SpadCompileItem",'ncError) + +--% Compilation Carriers +-- This data structure is used to carry information between phases. + +--% phParse: carrier[tokens,...] -> carrier[ptree, tokens,...] +--)line (defun pretty (x) (boottran::reallyprettyprint x)) +--)line (defun packagetran (x) (boot::|packageTran|)) +phParse(carrier,ptree) == + phBegin 'Parsing + if $ncmParse then + nothing + intSayKeyedMsg ('S2CTP003,[%pform ptree]) + ncPutQ(carrier, 'ptree, ptree) + 'OK + + +--% phMacro: carrier[ptree,...] -> carrier[ptree, ptreePremacro,...] +phMacro carrier == + phBegin 'Macroing + ptree := ncEltQ(carrier, 'ptree) + ncPutQ(carrier, 'ptreePremacro, ptree) + + ptree := macroExpanded ptree + if $ncmMacro then + intSayKeyedMsg ('S2CTP007,[%pform ptree] ) + + ncPutQ(carrier, 'ptree, ptree) + 'OK + +--% phReportMsgs: carrier[lines,messages,..]-> carrier[lines,messages,..] +phReportMsgs(carrier, interactive?) == + $erMsgToss => 'OK + lines := ncEltQ(carrier, 'lines) + msgs := ncEltQ(carrier, 'messages) + nerr := #msgs + ncPutQ(carrier, 'ok?, nerr = 0) + interactive? and nerr = 0 => 'OK + processMsgList(msgs, lines) + intSayKeyedMsg ('S2CTP010,[nerr]) + 'OK + +ncConversationPhase(fn, args) == + carrier := first args + + $ncMsgList: local := [] + $convPhase: local := 'NoPhase + + UNWIND_-PROTECT( APPLY(fn, args), wrapup(carrier) ) where + wrapup(carrier) == + for m in $ncMsgList repeat + ncPutQ(carrier, 'messages, [m, :ncEltQ(carrier, 'messages)]) + +ncloopPrefix?(prefix,whole) == + #prefix > #whole => false + good:=true + for i in 0..#prefix-1 for j in 0.. while good repeat + good:= prefix.i = whole.j + if good then SUBSTRING(whole,#prefix,nil) else good + +phBegin id == + $convPhase := id + if $ncmPhase then intSayKeyedMsg('S2CTP021,[id]) + +PullAndExecuteSpadSystemCommand stream == + ExecuteSpadSystemCommand CAR stream + CDR stream + +ExecuteSpadSystemCommand string == + FUNCALL($systemCommandFunction, string) + + +clearMacroTable() == + $pfMacros := nil + +getParserMacros() == + $pfMacros + +displayParserMacro m == + m := ASSQ(m, $pfMacros) + null m => nil + pfPrintSrcLines CADDR m + + diff --git a/src/interp/int-top.boot.pamphlet b/src/interp/int-top.boot.pamphlet deleted file mode 100644 index 9e86d4a1..00000000 --- a/src/interp/int-top.boot.pamphlet +++ /dev/null @@ -1,550 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp int-top.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{intloopReadConsole} - -This is the top level loop when reading from the input console. This -function calls itself after processing the current line. Because of -this it is important that the underlying common lisp supports -tail-recursion. - -Normally we never really exit this function. - -We read a string from the input. The serverReadLine\cite{1} function -is a special readline function that handles communication with the -session manager code, which is a separate process running in parallel. -In the usual case it just returns the current string. - -If the user enters a blank line ([[#a=]]) then just put up another prompt -and then tail-recursively call [[intloopReadConsole]]. - -If the user has set [[$DALYMODE]] to true and the new line starts with -an open parenthesis then the input is assumed to be a lisp expression -and is evaluated by the underlying common lisp. This is useful if you -are doing a lot of debugging. Commands can also be executed in the -underlying common lisp by using the [[)lisp]] command. In either case we -tail-recursively call [[intloopReadConsole]]. - -If the user typed [[)fin]] then we exit the loop and drop into the -underlying common lisp. You can use the [[(restart)]] function call -to return to the top level loop. - -If the input line starts with a close parenthesis we parse the -input line as a command rather than an expression. We execute the command -and then tail-recursively call [[intloopReadConsole]]. - -If the input line contains a trailing underscore, which is the standard -end-of-line escape character, then we continue to read the line by -tail-recursively calling [[intloopReadConsole]]. - -If none of the above conditions occur we simply evaluate the input line -and then tail-recursively call [[intloopReadConsole]]. - -However, there was a small bug in the test for the system command -[[)fin]]. Originally, the test took the form: -\begin{verbatim} - intloopPrefix?('")fin",a) => [] -\end{verbatim} -This test was flawed in two ways. First, it would match {\sl any} -command beginning with [[)fin]]. Second, it would {\sl only} match -names beginning with [[)fin]], although [[)fi]] is an acceptable -abbreviation for this command. The improved test takes the form: -\begin{verbatim} - pfx := stripSpaces intloopPrefix?('")fi",a) - pfx and ((pfx = '")fi") or (pfx = '")fin")) => [] -\end{verbatim} - -\section{intloopPrefix?} -The [[intloopPrefix?(prefix, whole)]] function simply tests if the string -[[prefix]] is a prefix of the string [[whole]]. The original -implementation discounts {\sl any} whitespace in [[whole]] in deciding a -match, when a more sensible behavior would be to discount only leading -whitespace. - -Moreover, the function SUBSTRING\cite{2} was being improperly called. -The reason why this improper call had gone undetected is that -generally [[intloopPrefix?]] is invoked with a prefix string of length -one -- hence the start position for the substring would generally -begin at index [[spaces]] (which is what we want). - -The original code read: -\begin{verbatim} -intloopPrefix?(prefix,whole) == - #prefix > #whole => false - good:=true - spaces := 0 - i := 0 - len := #prefix - wlen := #whole - for j in 0.. while (good and i < len and j < wlen) repeat - good:= (prefix.i = whole.j) or (whole.j = char " ") - if prefix.i = whole.j then i := i+1 - if whole.j = char " " then spaces := spaces + 1 - spaces = wlen => nil - if good then SUBSTRING(whole,#prefix+spaces-1,nil) else good - -\end{verbatim} - -The improved version of [[inloopPrefix?(prefix, whole)]] returns the -string [[whole]] sans leading whitespace if the match succeeds, else nil. - -<>= -intloopPrefix?(prefix,whole) == - #prefix > #whole => false - good := true - leading := true - spaces := 0 - i := 0 - len := #prefix - wlen := #whole - for j in 0.. while (good and i < len and j < wlen) repeat - good := (prefix.i = whole.j) or (leading and (whole.j = char " ")) - if prefix.i = whole.j then i := i+1 - if (whole.j = char " ") and leading then - spaces := spaces + 1 - else leading := false - spaces = wlen => nil - if good then SUBSTRING(whole,spaces,nil) else good - -@ -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -)package "BOOT" - -ncParseAndInterpretString s == - processInteractive(packageTran parseFromString s, nil) - -ncParseFromString s == - zeroOneTran packageTran CATCH("SPAD_READER", parseFromString s) - -ncINTERPFILE(file, echo) == - savedEcho := $EchoLines - savedReadingFile := $ReadingFile - $EchoLines: fluid := echo - $ReadingFile: fluid := true - result := SpadInterpretFile file - $EchoLines := savedEcho - $ReadingFile := savedReadingFile - result - -ncGetFunction(op, dom, sig) == - applyInPackage(function getNCfunction,_ - [rePackageTran(op, '"boot"),_ - rePackageTran(dom, '"boot"),_ - rePackageTran(sig, '"boot")],_ - '"BOOT") - -applyInPackage(fun, args, package) == - savedPackage := _*PACKAGE_* - SETQ(_*PACKAGE_*, FIND_-PACKAGE package) - result := apply(fun, args) - SETQ(_*PACKAGE_*, savedPackage) - result - -ncSetCurrentLine l == - setCurrentLine l - - ---% INTERPRETER TOP LEVEL - -spad() == - -- starts the interpreter but does not read in profiles, etc. - $PrintCompilerMessageIfTrue: local - $inLispVM : local := nil - setOutputAlgebra "%initialize%" - runspad() - 'EndOfSpad - -runspad() == - mode:='restart - while mode='restart repeat - resetStackLimits() - CATCH($quitTag, CATCH('coerceFailure, - mode:=CATCH('top__level, ncTopLevel()))) - -ncTopLevel() == --- Top-level read-parse-eval-print loop for the interpreter. Uses --- the Bill Burge's parser. - IN_-STREAM: fluid := CURINSTREAM - _*EOF_*: fluid := NIL - $InteractiveMode :fluid := true - $BOOT: fluid := NIL - $NEWSPAD: fluid := true - $SPAD: fluid := true - $e:fluid := $InteractiveFrame - ncIntLoop() - - -ncIntLoop() == - CURINSTREAM : local := _*STANDARD_-OUTPUT_* - CUROUTSTREAM : local := _*STANDARD_-INPUT_* - intloop() - - -intloop () == - mode := $intRestart - while mode = $intRestart repeat - resetStackLimits() - mode := CATCH($intTopLevel, - SpadInterpretStream(1, ["TIM", "DALY", "?"], true)) - - -SpadInterpretStream(str, source, interactive?) == - $fn : local := source - pile? := not interactive? - $libQuiet : local := not interactive? - $newcompMode : local := false --- following seems useless and causes ccl package problems --- $InteractiveMode : local := false - - $newcompErrorCount: local := 0 -- SMW Feb 2/90. - -- Used in highComplete, ncHardError etc. - - $okToExecuteMachineCode: local := true -- set false on error - $inclAssertions: local := ["AIX", "CommonLisp"] -- Jan 28/90 - - - $lastPos : local := $nopos ------------>!!! - $erMsgToss : local := false --------------->!!! - $ncMsgList : local := nil - - $systemCommandFunction : local := function InterpExecuteSpadSystemCommand - $shoeReadLineFunction : local := function serverReadLine - $promptMsg : local := 'S2CTP023 - - interactive? => - PRINC(MKPROMPT()) - intloopReadConsole('"", str) - [] - intloopInclude (source,0) - [] - - ----------------------------------------------------------------- - -intloopReadConsole(b, n)== - a:= serverReadLine(_*STANDARD_-INPUT_*) - not STRINGP a => leaveScratchpad() - #a=0 => - PRINC(MKPROMPT()) - intloopReadConsole('"", n) - $DALYMODE and intloopPrefix?('"(",a) => - intnplisp(a) - PRINC(MKPROMPT()) - intloopReadConsole('"",n) - pfx := stripSpaces intloopPrefix?('")fi",a) - pfx and ((pfx = '")fi") or (pfx = '")fin")) => [] - b = '"" and (d := intloopPrefix?('")", a)) => - setCurrentLine d - c := ncloopCommand(d,n) - PRINC(MKPROMPT()) - intloopReadConsole('"", c) - a:=CONCAT(b,a) - ncloopEscaped a => intloopReadConsole(SUBSEQ(a, 0, (LENGTH a) - 1),n) - c := intloopProcessString(a, n) - PRINC(MKPROMPT()) - intloopReadConsole('"", c) - -<> - -intloopProcess(n,interactive,s)== - StreamNull s => n - [lines,ptree]:=CAR s - pfAbSynOp?(ptree,"command")=> - if interactive then setCurrentLine tokPart ptree - FUNCALL($systemCommandFunction, tokPart ptree) - intloopProcess(n ,interactive ,CDR s) - intloopProcess(intloopSpadProcess(n,lines,ptree,interactive) - ,interactive ,CDR s) - -intloopEchoParse s== - [dq,stream]:=CAR s - [lines,rest]:=ncloopDQlines(dq,$lines) - setCurrentLine(mkLineList(lines)) - if $EchoLines then ncloopPrintLines lines - $lines:=rest - cons([[lines,npParse dqToList dq]],CDR s) - -intloopInclude0(st, name, n) == - $lines:local:=incStream(st,name) - intloopProcess(n,false, - next(function intloopEchoParse, - next(function insertpile, - next(function lineoftoks,$lines)))) - -intloopInclude(name, n) == - WITH_-OPEN_-FILE(st name, intloopInclude0(st, name, n)) - -intloopInclude1(name,n) == - a:=ncloopIncFileName name - a => intloopInclude(a,n) - n - -intloopProcessString(s,n) == - setCurrentLine s - intloopProcess(n,true, - next(function ncloopParse, - next(function lineoftoks,incString s))) - -$pfMacros := [] - -intloopSpadProcess(stepNo,lines,ptree,interactive?)== - $stepNo:local := stepNo - $currentCarrier := cc := ['carrier] - ncPutQ(cc, 'stepNumber, stepNo) - ncPutQ(cc, 'messages, $ncMsgList) - ncPutQ(cc, 'lines, lines) - $ncMsgList := nil - result := CatchAsCan(flung, Catch("SpadCompileItem", - CATCH($intCoerceFailure, CATCH($intSpadReader, - interp(cc, ptree, interactive?))))) where - - interp(cc, ptree, interactive?) == - ncConversationPhase(function phParse, [cc, ptree]) - ncConversationPhase(function phMacro, [cc]) - ncConversationPhase(function phIntReportMsgs,[cc, interactive?]) - ncConversationPhase(function phInterpret, [cc]) - - #ncEltQ(cc, 'messages) ^= 0 => ncError() - - intSetNeedToSignalSessionManager() - $prevCarrier := $currentCarrier - result = 'ncEnd => stepNo - result = 'ncError => stepNo - result = 'ncEndItem => stepNo - stepNo+1 - -phInterpret carrier == - ptree := ncEltQ(carrier, 'ptree) - val := intInterpretPform(ptree) - ncPutQ(carrier, 'value, val) - - ---% phReportMsgs: carrier[lines,messages,..]-> carrier[lines,messages,..] -phIntReportMsgs(carrier, interactive?) == - $erMsgToss => 'OK - lines := ncEltQ(carrier, 'lines) - msgs := ncEltQ(carrier, 'messages) - nerr := #msgs - ncPutQ(carrier, 'ok?, nerr = 0) - nerr = 0 => 'OK - processMsgList(msgs, lines) - intSayKeyedMsg ('S2CTP010,[nerr]) - 'OK - -mkLineList lines == - l := [CDR line for line in lines | nonBlank CDR line] - #l = 1 => CAR l - l - -nonBlank str == - value := false - for i in 0..MAXINDEX str repeat - str.i ^= char " " => - value := true - return value - value - -ncloopCommand (line,n) == - a:=ncloopPrefix?('")include",line)=> - ncloopInclude1( a,n) - FUNCALL($systemCommandFunction,line) - n - -ncloopEscaped x== - esc :=false - done:=false - for i in (# x) - 1 .. 0 by -1 while not done repeat - done:= - x.i='" ".0 =>false - x.i='"__".0=> - esc:=true - true - true - esc - -ncloopDQlines (dq,stream)== - StreamNull stream - a:= poGlobalLinePosn tokPosn CADR dq - b:= poGlobalLinePosn CAAR stream - streamChop (a-b+1,stream) - -streamChop(n,s)== - if StreamNull s - then [nil,nil] - else if EQL(n,0) - then [nil,s] - else - [a,b]:= streamChop(n-1,cdr s) - line:=car s - c:=ncloopPrefix?('")command",CDR line) - d:= cons(car line,if c then c else cdr line) - [cons(d,a),b] - -ncloopPrintLines lines == - for line in lines repeat WRITE_-LINE CDR line - WRITE_-LINE '" " - -ncloopIncFileName string== - fn := incFileName string - not fn => - WRITE_-LINE (CONCAT(string, '" not found")) - [] - fn - -ncloopParse s== - [dq,stream]:=CAR s - [lines,rest]:=ncloopDQlines(dq,stream) - cons([[lines,npParse dqToList dq]],CDR s) - -ncloopInclude0(st, name, n) == - $lines:local := incStream(st, name) - ncloopProcess(n,false, - next(function ncloopEchoParse, - next(function insertpile, - next(function lineoftoks,$lines)))) - -ncloopInclude(name, n) == - WITH_-OPEN_-FILE(st name, ncloopInclude0(st, name, n)) - -ncloopInclude1(name,n) == - a:=ncloopIncFileName name - a => ncloopInclude(a,n) - n - -incString s== incRenumber incLude(0,[s],0,['"strings"] ,[Top]) - -ncError() == - THROW("SpadCompileItem",'ncError) - ---% Compilation Carriers --- This data structure is used to carry information between phases. - ---% phParse: carrier[tokens,...] -> carrier[ptree, tokens,...] ---)line (defun pretty (x) (boottran::reallyprettyprint x)) ---)line (defun packagetran (x) (boot::|packageTran|)) -phParse(carrier,ptree) == - phBegin 'Parsing - if $ncmParse then - nothing - intSayKeyedMsg ('S2CTP003,[%pform ptree]) - ncPutQ(carrier, 'ptree, ptree) - 'OK - - ---% phMacro: carrier[ptree,...] -> carrier[ptree, ptreePremacro,...] -phMacro carrier == - phBegin 'Macroing - ptree := ncEltQ(carrier, 'ptree) - ncPutQ(carrier, 'ptreePremacro, ptree) - - ptree := macroExpanded ptree - if $ncmMacro then - intSayKeyedMsg ('S2CTP007,[%pform ptree] ) - - ncPutQ(carrier, 'ptree, ptree) - 'OK - ---% phReportMsgs: carrier[lines,messages,..]-> carrier[lines,messages,..] -phReportMsgs(carrier, interactive?) == - $erMsgToss => 'OK - lines := ncEltQ(carrier, 'lines) - msgs := ncEltQ(carrier, 'messages) - nerr := #msgs - ncPutQ(carrier, 'ok?, nerr = 0) - interactive? and nerr = 0 => 'OK - processMsgList(msgs, lines) - intSayKeyedMsg ('S2CTP010,[nerr]) - 'OK - -ncConversationPhase(fn, args) == - carrier := first args - - $ncMsgList: local := [] - $convPhase: local := 'NoPhase - - UNWIND_-PROTECT( APPLY(fn, args), wrapup(carrier) ) where - wrapup(carrier) == - for m in $ncMsgList repeat - ncPutQ(carrier, 'messages, [m, :ncEltQ(carrier, 'messages)]) - -ncloopPrefix?(prefix,whole) == - #prefix > #whole => false - good:=true - for i in 0..#prefix-1 for j in 0.. while good repeat - good:= prefix.i = whole.j - if good then SUBSTRING(whole,#prefix,nil) else good - -phBegin id == - $convPhase := id - if $ncmPhase then intSayKeyedMsg('S2CTP021,[id]) - -PullAndExecuteSpadSystemCommand stream == - ExecuteSpadSystemCommand CAR stream - CDR stream - -ExecuteSpadSystemCommand string == - FUNCALL($systemCommandFunction, string) - - -clearMacroTable() == - $pfMacros := nil - -getParserMacros() == - $pfMacros - -displayParserMacro m == - m := ASSQ(m, $pfMacros) - null m => nil - pfPrintSrcLines CADDR m - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} [[src/interp/server.boot.pamphlet]] -\bibitem{2} [[src/interp/vmlisp.lisp.pamphlet]] -\end{thebibliography} -\end{document} diff --git a/src/interp/intfile.boot b/src/interp/intfile.boot new file mode 100644 index 00000000..a7e3d543 --- /dev/null +++ b/src/interp/intfile.boot @@ -0,0 +1,63 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +shoeInternFile(fn)== + a:=shoeInputFile fn + if null a + then WRITE_-LINE (CONCAT(fn,'" not found"),_*TERMINAL_-IO_*) + else shoeIntern incRgen a + +shoeIntern (s)== + StreamNull s => nil + f:=CAR s + # f < 8 => shoeIntern CDR s + f.0=char " " =>shoeIntern CDR s + a:=INTERN SUBSTRING (f,0,8) + [b,c]:= shoeStrings CDR s + SETF(GET (a,"MSGS"),b) + shoeIntern c + +shoeStrings (stream)== + StreamNull stream => ['"",stream] + a:=CAR stream + if a.0^=char " " + then ['"",stream] + else + [h,t]:=shoeStrings(cdr stream) + [CONCAT(a,h),t] + +--fetchKeyedMsg(key,b)== GET(key,"MSGS") +--shoeInternFile '"/usr/local/scratchpad/cur/doc/msgs/co-eng.msgs" diff --git a/src/interp/intfile.boot.pamphlet b/src/interp/intfile.boot.pamphlet deleted file mode 100644 index 1dcdcf2d..00000000 --- a/src/interp/intfile.boot.pamphlet +++ /dev/null @@ -1,83 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp intfile.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -)package "BOOT" - -shoeInternFile(fn)== - a:=shoeInputFile fn - if null a - then WRITE_-LINE (CONCAT(fn,'" not found"),_*TERMINAL_-IO_*) - else shoeIntern incRgen a - -shoeIntern (s)== - StreamNull s => nil - f:=CAR s - # f < 8 => shoeIntern CDR s - f.0=char " " =>shoeIntern CDR s - a:=INTERN SUBSTRING (f,0,8) - [b,c]:= shoeStrings CDR s - SETF(GET (a,"MSGS"),b) - shoeIntern c - -shoeStrings (stream)== - StreamNull stream => ['"",stream] - a:=CAR stream - if a.0^=char " " - then ['"",stream] - else - [h,t]:=shoeStrings(cdr stream) - [CONCAT(a,h),t] - ---fetchKeyedMsg(key,b)== GET(key,"MSGS") ---shoeInternFile '"/usr/local/scratchpad/cur/doc/msgs/co-eng.msgs" -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot new file mode 100644 index 00000000..47e4b666 --- /dev/null +++ b/src/interp/lisplib.boot @@ -0,0 +1,688 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +--% Standard Library Creation Functions + +readLib(fn,ft) == readLib1(fn,ft,"*") + +readLib1(fn,ft,fm) == + -- see if it exists first + p := pathname [fn,ft,fm] + readLibPathFast p + +readLibPathFast p == + -- assumes 1) p is a valid pathname + -- 2) file has already been checked for existence + RDEFIOSTREAM([['FILE,:p], '(MODE . INPUT)],false) + +writeLib(fn,ft) == writeLib1(fn,ft,"*") + +writeLib1(fn,ft,fm) == RDEFIOSTREAM [['FILE,fn,ft,fm],'(MODE . OUTPUT)] + +putFileProperty(fn,ft,id,val) == + fnStream:= writeLib1(fn,ft,"*") + val:= rwrite( id,val,fnStream) + RSHUT fnStream + val + +lisplibWrite(prop,val,filename) == + -- this may someday not write NIL keys, but it will now + if $LISPLIB then + rwrite128(prop,val,filename) + +rwrite128(key,value,stream) == + rwrite(key,value,stream) + +evalAndRwriteLispForm(key,form) == + eval form + rwriteLispForm(key,form) + +rwriteLispForm(key,form) == + if $LISPLIB then + rwrite( key,form,$libFile) + LAM_,FILEACTQ(key,form) + +getLisplib(name,id) == + -- this version does cache the returned value + getFileProperty(name,$spadLibFT,id,true) + +getLisplibNoCache(name,id) == + -- this version does not cache the returned value + getFileProperty(name,$spadLibFT,id,false) + +getFileProperty(fn,ft,id,cache) == + fn in '(DOMAIN SUBDOM MODE) => nil + p := pathname [fn,ft,'"*"] + cache => hasFileProperty(p,id,fn) + hasFilePropertyNoCache(p,id,fn) + +hasFilePropertyNoCache(p,id,abbrev) == + -- it is assumed that the file exists and is a proper pathname + -- startTimingProcess 'diskread + fnStream:= readLibPathFast p + NULL fnStream => NIL + -- str:= object2String id + val:= rread(id,fnStream, nil) + RSHUT fnStream + -- stopTimingProcess 'diskread + val + +--% Uninstantiating + +unInstantiate(clist) == + for c in clist repeat + clearConstructorCache(c) + killNestedInstantiations(clist) + +killNestedInstantiations(deps) == + for key in HKEYS($ConstructorCache) + repeat + for [arg,count,:inst] in HGET($ConstructorCache,key) repeat + isNestedInstantiation(inst.0,deps) => + HREMPROP($ConstructorCache,key,arg) + +isNestedInstantiation(form,deps) == + form is [op,:argl] => + op in deps => true + or/[isNestedInstantiation(x,deps) for x in argl] + false + +--% Loading + +loadLibIfNotLoaded libName == + -- replaces old SpadCondLoad + -- loads is library is not already loaded + $PrintOnly = 'T => NIL + GETL(libName,'LOADED) => NIL + loadLib libName + +loadLib cname == + startTimingProcess 'load + fullLibName := GETDATABASE(cname,'OBJECT) or return nil + systemdir? := isSystemDirectory(pathnameDirectory fullLibName) + update? := $forceDatabaseUpdate or not systemdir? + not update? => + loadLibNoUpdate(cname, cname, fullLibName) + kind := GETDATABASE(cname,'CONSTRUCTORKIND) + if $printLoadMsgs then + sayKeyedMsg("S2IL0002",[namestring fullLibName,kind,cname]) + LOAD(fullLibName) + clearConstructorCache cname + updateDatabase(cname,cname,systemdir?) + installConstructor(cname,kind) + u := GETDATABASE(cname, 'CONSTRUCTORMODEMAP) + updateCategoryTable(cname,kind) + coSig := + u => + [[.,:sig],:.] := u + CONS(NIL,[categoryForm?(x) for x in CDR sig]) + NIL + -- in following, add property value false or NIL to possibly clear + -- old value + if null CDR GETDATABASE(cname,'CONSTRUCTORFORM) then + MAKEPROP(cname,'NILADIC,'T) + else + REMPROP(cname,'NILADIC) + MAKEPROP(cname,'LOADED,fullLibName) + if $InteractiveMode then $CategoryFrame := [[nil]] + stopTimingProcess 'load + 'T + +loadLibNoUpdate(cname, libName, fullLibName) == + kind := GETDATABASE(cname,'CONSTRUCTORKIND) + if $printLoadMsgs then + sayKeyedMsg("S2IL0002",[namestring fullLibName,kind,cname]) + if CATCH('VERSIONCHECK,LOAD(fullLibName)) = -1 + then + PRINC('" wrong library version...recompile ") + PRINC(fullLibName) + TERPRI() + TOPLEVEL() + else + clearConstructorCache cname + installConstructor(cname,kind) + MAKEPROP(cname,'LOADED,fullLibName) + if $InteractiveMode then $CategoryFrame := [[nil]] + stopTimingProcess 'load + 'T + +loadIfNecessary u == loadLibIfNecessary(u,true) + +loadIfNecessaryAndExists u == loadLibIfNecessary(u,nil) + +loadLibIfNecessary(u,mustExist) == + u = '$EmptyMode => u + null atom u => loadLibIfNecessary(first u,mustExist) + value:= + functionp(u) or macrop(u) => u + GETL(u,'LOADED) => u + loadLib u => u + null $InteractiveMode and ((null (y:= getProplist(u,$CategoryFrame))) + or (null LASSOC('isFunctor,y)) and (null LASSOC('isCategory,y))) => + y:= GETDATABASE(u,'CONSTRUCTORKIND) => + y = 'category => + updateCategoryFrameForCategory u + updateCategoryFrameForConstructor u + throwKeyedMsg("S2IL0005",[u]) + value + +convertOpAlist2compilerInfo(opalist) == + "append"/[[formatSig(op,sig) for sig in siglist] + for [op,:siglist] in opalist] where + formatSig(op, [typelist, slot,:stuff]) == + pred := if stuff then first stuff else 'T + impl := if CDR stuff then CADR stuff else 'ELT -- handles 'CONST + [[op, typelist], pred, [impl, '$, slot]] + +updateCategoryFrameForConstructor(constructor) == + opAlist := GETDATABASE(constructor, 'OPERATIONALIST) + [[dc,:sig],[pred,impl]] := GETDATABASE(constructor, 'CONSTRUCTORMODEMAP) + $CategoryFrame := put(constructor,'isFunctor, + convertOpAlist2compilerInfo(opAlist), + addModemap(constructor, dc, sig, pred, impl, + put(constructor, 'mode, ['Mapping,:sig], $CategoryFrame))) + +updateCategoryFrameForCategory(category) == + [[dc,:sig],[pred,impl]] := GETDATABASE(category, 'CONSTRUCTORMODEMAP) + $CategoryFrame := + put(category, 'isCategory, 'T, + addModemap(category, dc, sig, pred, impl, $CategoryFrame)) + +loadFunctor u == + null atom u => loadFunctor first u + loadLibIfNotLoaded u + u + +makeConstructorsAutoLoad() == + for cnam in allConstructors() repeat + REMPROP(cnam,'LOADED) +-- fn:=GETDATABASE(cnam,'ABBREVIATION) + if GETDATABASE(cnam,'NILADIC) + then PUT(cnam,'NILADIC,'T) + else REMPROP(cnam,'NILADIC) + systemDependentMkAutoload(cnam,cnam) + +systemDependentMkAutoload(fn,cnam) == + FBOUNDP(cnam) => "next" + asharpName := GETDATABASE(cnam, 'ASHARP?) => + kind := GETDATABASE(cnam, 'CONSTRUCTORKIND) + cosig := GETDATABASE(cnam, 'COSIG) + file := GETDATABASE(cnam, 'OBJECT) + SET_-LIB_-FILE_-GETTER(file, cnam) + kind = 'category => + ASHARPMKAUTOLOADCATEGORY(file, cnam, asharpName, cosig) + ASHARPMKAUTOLOADFUNCTOR(file, cnam, asharpName, cosig) + SETF(SYMBOL_-FUNCTION cnam,mkAutoLoad(fn, cnam)) + +autoLoad(abb,cname) == + if not GETL(cname,'LOADED) then loadLib cname + SYMBOL_-FUNCTION cname + +setAutoLoadProperty(name) == +-- abb := constructor? name + REMPROP(name,'LOADED) + SETF(SYMBOL_-FUNCTION name,mkAutoLoad(name, name)) + +--% Compilation + +compileConstructorLib(l,op,editFlag,traceFlag) == + --this file corresponds to /C,1 + MEMQ('_?,l) => return editFile '(_/C TELL _*) + optionList:= _/OPTIONS l + funList:= TRUNCLIST(l,optionList) or [_/FN] + options:= [[UPCASE CAR x,:CDR x] for x in optionList] + infile:= _/MKINFILENAM _/GETOPTION(options,'FROM_=) + outfile:= _/MKINFILENAM _/GETOPTION(options,'TO_=) + res:= [compConLib1(fn,infile,outfile,op,editFlag,traceFlag) + for fn in funList] + SHUT INPUTSTREAM + res + +compConLib1(fun,infileOrNil,outfileOrNil,auxOp,editFlag,traceFlag) == + $PRETTYPRINT: local := 'T + $LISPLIB: local := 'T + $lisplibAttributes: local := NIL + $lisplibPredicates: local := NIL + $lisplibForm: local := NIL + $lisplibAbbreviation: local := NIL + $lisplibParents: local := NIL + $lisplibAncestors: local := NIL + $lisplibKind: local := NIL + $lisplibModemap: local := NIL + $lisplibModemapAlist: local := NIL + $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) + $lisplibSlot1 : local := NIL --used by NRT mechanisms + $lisplibOperationAlist: local := NIL + $lisplibOpAlist: local:= NIL + $lisplibSuperDomain: local := NIL + $libFile: local := NIL + $lisplibVariableAlist: local := NIL + $lisplibSignatureAlist: local := NIL + if null atom fun and null CDR fun then fun:= CAR fun -- unwrap nullary + libName:= getConstructorAbbreviation fun + infile:= infileOrNil or getFunctionSourceFile fun or + throwKeyedMsg("S2IL0004",[fun]) + SETQ(_/EDITFILE,infile) + outfile := outfileOrNil or + [libName,'OUTPUT,$listingDirectory] --always QUIET + _$ERASE(libName,'OUTPUT,$listingDirectory) + outstream:= DEFSTREAM(outfile,'OUTPUT) + val:= _/D_,2_,LIB(fun,infile,outstream,auxOp,editFlag,traceFlag) + val + +compDefineLisplib(df:=["DEF",[op,:.],:.],m,e,prefix,fal,fn) == + --fn= compDefineCategory OR compDefineFunctor + sayMSG fillerSpaces(72,'"-") + $LISPLIB: local := 'T + $op: local := op + $lisplibAttributes: local := NIL + $lisplibPredicates: local := NIL -- set by makePredicateBitVector + $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) + $lisplibForm: local := NIL + $lisplibKind: local := NIL + $lisplibAbbreviation: local := NIL + $lisplibParents: local := NIL + $lisplibAncestors: 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 compDefineCategory1 if category, otherwise in finalizeLisplib + libName := getConstructorAbbreviation op + BOUNDP '$compileDocumentation and $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 + -- following guarantee's compiler output files get closed. + ok := false; + UNWIND_-PROTECT( + PROGN(res:= FUNCALL(fn,df,m,e,prefix,fal), + sayMSG ['" finalizing ",$spadLibFT,:bright libName], + finalizeLisplib libName, + ok := true), + RSHUT $libFile) + if ok then lisplibDoRename(libName) + filearg := $FILEP(libName,$spadLibFT,$libraryDirectory) + RPACKFILE filearg + FRESH_-LINE $algebraOutputStream + sayMSG fillerSpaces(72,'"-") + unloadOneConstructor(op,libName) + LOCALDATABASE(LIST GETDATABASE(op,'ABBREVIATION),NIL) + $newConlist := [op, :$newConlist] ----------> bound in function "compiler" + if $lisplibKind = 'category + then updateCategoryFrameForCategory op + else updateCategoryFrameForConstructor op + res + +compileDocumentation libName == + filename := MAKE_-INPUT_-FILENAME(libName,$spadLibFT) + $FCOPY(filename,[libName,'DOCLB]) + stream := RDEFIOSTREAM [['FILE,libName,'DOCLB],['MODE, :'O]] + lisplibWrite('"documentation",finalizeDocumentation(),stream) +-- if $lisplibRelatedDomains then +-- lisplibWrite('"relatedDomains",$lisplibRelatedDomains,stream) + RSHUT(stream) + RPACKFILE([libName,'DOCLB]) + $REPLACE([libName,$spadLibFT],[libName,'DOCLB]) + ['dummy, $EmptyMode, $e] + +getLisplibVersion libName == + stream := RDEFIOSTREAM [['FILE,libName,$spadLibFT],['MODE, :'I]] + version:= CADR rread('VERSION, stream,nil) + RSHUT(stream) + version + +initializeLisplib libName == + _$ERASE(libName,'ERRORLIB,$libraryDirectory) + SETQ(ERRORS,0) -- ERRORS is a fluid variable for the compiler + $libFile:= writeLib1(libName,'ERRORLIB,$libraryDirectory) + ADDOPTIONS('FILE,$libFile) + $lisplibForm := nil --defining form for lisplib + $lisplibModemap := nil --modemap for constructor form + $lisplibKind := nil --category, domain, or package + $lisplibModemapAlist := nil --changed in "augmentLisplibModemapsFromCategory" + $lisplibAbbreviation := nil + $lisplibAncestors := nil + $lisplibOpAlist := nil --operations alist for new runtime system + $lisplibOperationAlist := nil --old list of operations for functor/package + $lisplibSuperDomain:= nil + -- next var changed in "augmentLisplibDependents" + $lisplibVariableAlist := nil --this and the next are used by "luke" + $lisplibSignatureAlist := nil + if pathnameTypeId(_/EDITFILE) = 'SPAD + then LAM_,FILEACTQ('VERSION,['_/VERSIONCHECK,_/MAJOR_-VERSION]) + +finalizeLisplib libName == + lisplibWrite('"constructorForm",removeZeroOne $lisplibForm,$libFile) + lisplibWrite('"constructorKind",kind:=removeZeroOne $lisplibKind,$libFile) + lisplibWrite('"constructorModemap",removeZeroOne $lisplibModemap,$libFile) + $lisplibCategory:= $lisplibCategory or $lisplibModemap.mmTarget + -- set to target of modemap for package/domain constructors; + -- to the right-hand sides (the definition) for category constructors + lisplibWrite('"constructorCategory",$lisplibCategory,$libFile) + lisplibWrite('"sourceFile",namestring _/EDITFILE,$libFile) + lisplibWrite('"modemaps",removeZeroOne $lisplibModemapAlist,$libFile) + opsAndAtts:= getConstructorOpsAndAtts( + $lisplibForm,kind,$lisplibModemap) + lisplibWrite('"operationAlist",removeZeroOne CAR opsAndAtts,$libFile) + --lisplibWrite('"attributes",CDR opsAndAtts,$libFile) + --if kind='category then NRTgenInitialAttributeAlist CDR opsAndAtts + if kind='category then + $pairlis : local := [[a,:v] for a in rest $lisplibForm + for v in $FormalMapVariableList] + $NRTslot1PredicateList : local := [] + NRTgenInitialAttributeAlist CDR opsAndAtts + lisplibWrite('"superDomain",removeZeroOne $lisplibSuperDomain,$libFile) + lisplibWrite('"signaturesAndLocals", + removeZeroOne mergeSignatureAndLocalVarAlists($lisplibSignatureAlist, + $lisplibVariableAlist),$libFile) + lisplibWrite('"attributes",removeZeroOne $lisplibAttributes,$libFile) + lisplibWrite('"predicates",removeZeroOne $lisplibPredicates,$libFile) + lisplibWrite('"abbreviation",$lisplibAbbreviation,$libFile) + lisplibWrite('"parents",removeZeroOne $lisplibParents,$libFile) + lisplibWrite('"ancestors",removeZeroOne $lisplibAncestors,$libFile) + lisplibWrite('"documentation",finalizeDocumentation(),$libFile) + lisplibWrite('"slot1Info",removeZeroOne $lisplibSlot1,$libFile) + if $profileCompiler then profileWrite() + if $lisplibForm and null CDR $lisplibForm then + MAKEPROP(CAR $lisplibForm,'NILADIC,'T) + ERRORS ^=0 => -- ERRORS is a fluid variable for the compiler + sayMSG ['" Errors in processing ",kind,'" ",:bright libName,'":"] + sayMSG ['" not replacing ",$spadLibFT,'" for",:bright libName] + +lisplibDoRename(libName) == + _$REPLACE([libName,$spadLibFT,$libraryDirectory], + [libName,'ERRORLIB,$libraryDirectory]) + +lisplibError(cname,fname,type,cn,fn,typ,error) == + sayMSG bright ['" Illegal ",$spadLibFT] + error in '(duplicateAbb wrongType) => + sayKeyedMsg("S2IL0007", + [namestring [fname,$spadLibFT],type,cname,typ,cn]) + error is 'abbIsName => + throwKeyedMsg("S2IL0008",[fname,typ,namestring [fn,$spadLibFT]]) + +getPartialConstructorModemapSig(c) == + (s := getConstructorSignature c) => rest s + throwEvalTypeMsg("S2IL0015",[c]) + +mergeSignatureAndLocalVarAlists(signatureAlist, localVarAlist) == + -- this function makes a single Alist for both signatures + -- and local variable types, to be stored in the LISPLIB + -- for the function being compiled + [[funcName,:[signature,:LASSOC(funcName,localVarAlist)]] for + [funcName, :signature] in signatureAlist] + +Operators u == + ATOM u => [] + ATOM first u => + answer:="union"/[Operators v for v in rest u] + MEMQ(first u,answer) => answer + [first u,:answer] + "union"/[Operators v for v in u] + +getConstructorOpsAndAtts(form,kind,modemap) == + kind is 'category => getCategoryOpsAndAtts(form) + getFunctorOpsAndAtts(form,modemap) + +getCategoryOpsAndAtts(catForm) == + -- returns [operations,:attributes] of CAR catForm + [transformOperationAlist getSlotFromCategoryForm(catForm,1), + :getSlotFromCategoryForm(catForm,2)] + +getFunctorOpsAndAtts(form,modemap) == + [transformOperationAlist getSlotFromFunctor(form,1,modemap), + :getSlotFromFunctor(form,2,modemap)] + +getSlotFromFunctor([name,:args],slot,[[.,target,:argMml],:.]) == + slot = 1 => $lisplibOperationAlist + t := compMakeCategoryObject(target,$e) or + systemErrorHere '"getSlotFromFunctor" + t.expr.slot + +getSlot1 domainName == + $e: local:= $CategoryFrame + fn:= getLisplibName domainName + p := pathname [fn,$spadLibFT,'"*"] + not isExistingFile(p) => + sayKeyedMsg("S2IL0003",[namestring p]) + NIL + (sig := getConstructorSignature domainName) => + [.,target,:argMml] := sig + for a in $FormalMapVariableList for m in argMml repeat + $e:= put(a,'mode,m,$e) + t := compMakeCategoryObject(target,$e) or + systemErrorHere '"getSlot1" + t.expr.1 + sayKeyedMsg("S2IL0022",[namestring p,'"constructor modemap"]) + NIL + +transformOperationAlist operationAlist == + -- this transforms the operationAlist which is written out onto LISPLIBs. + -- The original form of this list is a list of items of the form: + -- (( ) ( (ELT $ n))) + -- The new form is an op-Alist which has entries ( . signature-Alist) + -- where signature-Alist has entries ( . item) + -- where item has form ( ) + -- where = + -- NIL => function + -- CONST => constant ... and others + newAlist:= nil + for [[op,sig,:.],condition,implementation] in operationAlist repeat + kind:= + implementation is [eltEtc,.,n] and eltEtc in '(CONST ELT) => eltEtc + implementation is [impOp,:.] => + impOp = 'XLAM => implementation + impOp in '(CONST Subsumed) => impOp + keyedSystemError("S2IL0025",[impOp]) + implementation = 'mkRecord => 'mkRecord + keyedSystemError("S2IL0025",[implementation]) + signatureItem:= + if u:= ASSOC([op,sig],$functionLocations) then n := [n,:rest u] + kind = 'ELT => + condition = 'T => [sig,n] + [sig,n,condition] + [sig,n,condition,kind] + itemList:= [signatureItem,:LASSQ(op,newAlist)] + newAlist:= insertAlist(op,itemList,newAlist) + newAlist + +sayNonUnique x == + sayBrightlyNT '"Non-unique:" + pp x + +-- flattenOperationAlist operationAlist == +-- --new form is ( ) +-- [:[[op,:x] for x in y] for [op,:y] in operationAlist] + +getSlotFromDomain(dom,op,oldSig) == + -- returns the slot number in the domain where the function whose + -- signature is oldSig may be found in the domain dom + oldSig:= removeOPT oldSig + dom:= removeOPT dom + sig:= SUBST("$",dom,oldSig) + loadIfNecessary first dom + isPackageForm dom => getSlotFromPackage(dom,op,oldSig) + domain:= evalDomain dom + n:= findConstructorSlotNumber(dom,domain,op,sig) => + (slot:= domain.n).0 = Undef => + throwKeyedMsg("S2IL0023A",[op,formatSignature sig,dom]) + slot + throwKeyedMsg("S2IL0024A",[op,formatSignature sig,dom]) + +findConstructorSlotNumber(domainForm,domain,op,sig) == + null domain.1 => getSlotNumberFromOperationAlist(domainForm,op,sig) + sayMSG ['" using slot 1 of ",domainForm] + constructorArglist:= rest domainForm + nsig:=#sig + tail:= or/[r for [[op1,sig1],:r] in domain.1 | op=op1 and nsig=#sig1 and + "and"/[compare for a in sig for b in sig1]] where compare() == + a=b => true + FIXP b => a=constructorArglist.b + isSuperDomain(bustUnion b,bustUnion a,$CategoryFrame) + tail is [.,["ELT",.,n]] => n + systemErrorHere '"findSlotNumber" + +bustUnion d == + d is ["Union",domain,utype] and utype='"failed" => domain + d + +getSlotNumberFromOperationAlist(domainForm,op,sig) == + constructorName:= CAR domainForm + constructorArglist:= CDR domainForm + operationAlist:= + GETDATABASE(constructorName, 'OPERATIONALIST) or + keyedSystemError("S2IL0026",[constructorName]) + entryList:= QLASSQ(op,operationAlist) or return nil + tail:= or/[r for [sig1,:r] in entryList | sigsMatch(sig,sig1,domainForm)] => + first tail + nil + +sigsMatch(sig,sig1,domainForm) == + -- does signature "sig" match "sig1", where integers 1,2,.. in + -- sig1 designate corresponding arguments of domainForm + while sig and sig1 repeat + partsMatch:= + (item:= CAR sig)=(item1:= CAR sig1) => true --ok, go to next iteration + FIXP item1 => item = domainForm.item1 --item1=n means nth arg + isSuperDomain(bustUnion item,bustUnion item1,$CategoryFrame) + null partsMatch => return nil + sig:= rest sig; sig1 := rest sig1 + sig or sig1 => nil + true + +findDomainSlotNumber(domain,op,sig) == --using slot 1 of the domain + nsig:=#sig + tail:= or/[r for [[op1,sig1],:r] in domain.1 | op=op1 and nsig=#sig1 and + "and"/[a=b or isSuperDomain(bustUnion b,bustUnion a,$CategoryFrame) + for a in sig for b in sig1]] + tail is [.,["ELT",.,n]] => n + systemErrorHere '"findDomainSlotNumber" + + +getConstructorModemap form == + GETDATABASE(opOf form, 'CONSTRUCTORMODEMAP) + +getConstructorSignature form == + (mm := GETDATABASE(opOf(form),'CONSTRUCTORMODEMAP)) => + [[.,:sig],:.] := mm + sig + NIL + +--% from MODEMAP BOOT + +augModemapsFromDomain1(name,functorForm,e) == + GETL(KAR functorForm,"makeFunctionList") => + addConstructorModemaps(name,functorForm,e) + atom functorForm and (catform:= getmode(functorForm,e)) => + augModemapsFromCategory(name,name,functorForm,catform,e) + mappingForm:= getmodeOrMapping(KAR functorForm,e) => + ["Mapping",categoryForm,:functArgTypes]:= mappingForm + catform:= substituteCategoryArguments(rest functorForm,categoryForm) + augModemapsFromCategory(name,name,functorForm,catform,e) + stackMessage [functorForm," is an unknown mode"] + e + +getSlotFromCategoryForm ([op,:argl],index) == + u:= eval [op,:MAPCAR('MKQ,TAKE(#argl,$FormalMapVariableList))] + null VECP u => + systemErrorHere '"getSlotFromCategoryForm" + u . index + + +--% constructor evaluation +-- The following functions are used by the compiler but are modified +-- here for use with new LISPLIB scheme + +mkEvalableCategoryForm c == --from DEFINE + c is [op,:argl] => + op="Join" => ["Join",:[mkEvalableCategoryForm x for x in argl]] + op is "DomainSubstitutionMacro" => + --$extraParms :local + --catobj := EVAL c -- DomainSubstitutionFunction makes $extraParms + --mkEvalableCategoryForm sublisV($extraParms, catobj) + mkEvalableCategoryForm CADR argl + op is "mkCategory" => c + MEMQ(op,$CategoryNames) => + ([x,m,$e]:= compOrCroak(c,$EmptyMode,$e); m=$Category => x) + --loadIfNecessary op + GETDATABASE(op,'CONSTRUCTORKIND) = 'category or + get(op,"isCategory",$CategoryFrame) => + [op,:[quotifyCategoryArgument x for x in argl]] + [x,m,$e]:= compOrCroak(c,$EmptyMode,$e) + m=$Category => x + MKQ c + +isDomainForm(D,e) == + --added for MPOLY 3/83 by RDJ + MEMQ(KAR D,$SpecialDomainNames) or isFunctor D or + -- ((D is ['Mapping,target,:.]) and isCategoryForm(target,e)) or + ((getmode(D,e) is ['Mapping,target,:.]) and isCategoryForm(target,e)) or + isCategoryForm(getmode(D,e),e) or isDomainConstructorForm(D,e) + +isDomainConstructorForm(D,e) == + D is [op,:argl] and (u:= get(op,"value",e)) and + u is [.,["Mapping",target,:.],:.] and + isCategoryForm(EQSUBSTLIST(argl,$FormalMapVariableList,target),e) + +isFunctor x == + op:= opOf x + not IDENTP op => false + $InteractiveMode => + MEMQ(op,'(Union SubDomain Mapping Record)) => true + MEMQ(GETDATABASE(op,'CONSTRUCTORKIND),'(domain package)) + u:= get(op,'isFunctor,$CategoryFrame) + or MEMQ(op,'(SubDomain Union Record)) => u + constructor? op => + prop := get(op,'isFunctor,$CategoryFrame) => prop + if GETDATABASE(op,'CONSTRUCTORKIND) = 'category + then updateCategoryFrameForCategory op + else updateCategoryFrameForConstructor op + get(op,'isFunctor,$CategoryFrame) + nil + + + diff --git a/src/interp/lisplib.boot.pamphlet b/src/interp/lisplib.boot.pamphlet deleted file mode 100644 index 8028e449..00000000 --- a/src/interp/lisplib.boot.pamphlet +++ /dev/null @@ -1,714 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/lisplib.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{License} - -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -)package "BOOT" - ---% Standard Library Creation Functions - -readLib(fn,ft) == readLib1(fn,ft,"*") - -readLib1(fn,ft,fm) == - -- see if it exists first - p := pathname [fn,ft,fm] - readLibPathFast p - -readLibPathFast p == - -- assumes 1) p is a valid pathname - -- 2) file has already been checked for existence - RDEFIOSTREAM([['FILE,:p], '(MODE . INPUT)],false) - -writeLib(fn,ft) == writeLib1(fn,ft,"*") - -writeLib1(fn,ft,fm) == RDEFIOSTREAM [['FILE,fn,ft,fm],'(MODE . OUTPUT)] - -putFileProperty(fn,ft,id,val) == - fnStream:= writeLib1(fn,ft,"*") - val:= rwrite( id,val,fnStream) - RSHUT fnStream - val - -lisplibWrite(prop,val,filename) == - -- this may someday not write NIL keys, but it will now - if $LISPLIB then - rwrite128(prop,val,filename) - -rwrite128(key,value,stream) == - rwrite(key,value,stream) - -evalAndRwriteLispForm(key,form) == - eval form - rwriteLispForm(key,form) - -rwriteLispForm(key,form) == - if $LISPLIB then - rwrite( key,form,$libFile) - LAM_,FILEACTQ(key,form) - -getLisplib(name,id) == - -- this version does cache the returned value - getFileProperty(name,$spadLibFT,id,true) - -getLisplibNoCache(name,id) == - -- this version does not cache the returned value - getFileProperty(name,$spadLibFT,id,false) - -getFileProperty(fn,ft,id,cache) == - fn in '(DOMAIN SUBDOM MODE) => nil - p := pathname [fn,ft,'"*"] - cache => hasFileProperty(p,id,fn) - hasFilePropertyNoCache(p,id,fn) - -hasFilePropertyNoCache(p,id,abbrev) == - -- it is assumed that the file exists and is a proper pathname - -- startTimingProcess 'diskread - fnStream:= readLibPathFast p - NULL fnStream => NIL - -- str:= object2String id - val:= rread(id,fnStream, nil) - RSHUT fnStream - -- stopTimingProcess 'diskread - val - ---% Uninstantiating - -unInstantiate(clist) == - for c in clist repeat - clearConstructorCache(c) - killNestedInstantiations(clist) - -killNestedInstantiations(deps) == - for key in HKEYS($ConstructorCache) - repeat - for [arg,count,:inst] in HGET($ConstructorCache,key) repeat - isNestedInstantiation(inst.0,deps) => - HREMPROP($ConstructorCache,key,arg) - -isNestedInstantiation(form,deps) == - form is [op,:argl] => - op in deps => true - or/[isNestedInstantiation(x,deps) for x in argl] - false - ---% Loading - -loadLibIfNotLoaded libName == - -- replaces old SpadCondLoad - -- loads is library is not already loaded - $PrintOnly = 'T => NIL - GETL(libName,'LOADED) => NIL - loadLib libName - -loadLib cname == - startTimingProcess 'load - fullLibName := GETDATABASE(cname,'OBJECT) or return nil - systemdir? := isSystemDirectory(pathnameDirectory fullLibName) - update? := $forceDatabaseUpdate or not systemdir? - not update? => - loadLibNoUpdate(cname, cname, fullLibName) - kind := GETDATABASE(cname,'CONSTRUCTORKIND) - if $printLoadMsgs then - sayKeyedMsg("S2IL0002",[namestring fullLibName,kind,cname]) - LOAD(fullLibName) - clearConstructorCache cname - updateDatabase(cname,cname,systemdir?) - installConstructor(cname,kind) - u := GETDATABASE(cname, 'CONSTRUCTORMODEMAP) - updateCategoryTable(cname,kind) - coSig := - u => - [[.,:sig],:.] := u - CONS(NIL,[categoryForm?(x) for x in CDR sig]) - NIL - -- in following, add property value false or NIL to possibly clear - -- old value - if null CDR GETDATABASE(cname,'CONSTRUCTORFORM) then - MAKEPROP(cname,'NILADIC,'T) - else - REMPROP(cname,'NILADIC) - MAKEPROP(cname,'LOADED,fullLibName) - if $InteractiveMode then $CategoryFrame := [[nil]] - stopTimingProcess 'load - 'T - -loadLibNoUpdate(cname, libName, fullLibName) == - kind := GETDATABASE(cname,'CONSTRUCTORKIND) - if $printLoadMsgs then - sayKeyedMsg("S2IL0002",[namestring fullLibName,kind,cname]) - if CATCH('VERSIONCHECK,LOAD(fullLibName)) = -1 - then - PRINC('" wrong library version...recompile ") - PRINC(fullLibName) - TERPRI() - TOPLEVEL() - else - clearConstructorCache cname - installConstructor(cname,kind) - MAKEPROP(cname,'LOADED,fullLibName) - if $InteractiveMode then $CategoryFrame := [[nil]] - stopTimingProcess 'load - 'T - -loadIfNecessary u == loadLibIfNecessary(u,true) - -loadIfNecessaryAndExists u == loadLibIfNecessary(u,nil) - -loadLibIfNecessary(u,mustExist) == - u = '$EmptyMode => u - null atom u => loadLibIfNecessary(first u,mustExist) - value:= - functionp(u) or macrop(u) => u - GETL(u,'LOADED) => u - loadLib u => u - null $InteractiveMode and ((null (y:= getProplist(u,$CategoryFrame))) - or (null LASSOC('isFunctor,y)) and (null LASSOC('isCategory,y))) => - y:= GETDATABASE(u,'CONSTRUCTORKIND) => - y = 'category => - updateCategoryFrameForCategory u - updateCategoryFrameForConstructor u - throwKeyedMsg("S2IL0005",[u]) - value - -convertOpAlist2compilerInfo(opalist) == - "append"/[[formatSig(op,sig) for sig in siglist] - for [op,:siglist] in opalist] where - formatSig(op, [typelist, slot,:stuff]) == - pred := if stuff then first stuff else 'T - impl := if CDR stuff then CADR stuff else 'ELT -- handles 'CONST - [[op, typelist], pred, [impl, '$, slot]] - -updateCategoryFrameForConstructor(constructor) == - opAlist := GETDATABASE(constructor, 'OPERATIONALIST) - [[dc,:sig],[pred,impl]] := GETDATABASE(constructor, 'CONSTRUCTORMODEMAP) - $CategoryFrame := put(constructor,'isFunctor, - convertOpAlist2compilerInfo(opAlist), - addModemap(constructor, dc, sig, pred, impl, - put(constructor, 'mode, ['Mapping,:sig], $CategoryFrame))) - -updateCategoryFrameForCategory(category) == - [[dc,:sig],[pred,impl]] := GETDATABASE(category, 'CONSTRUCTORMODEMAP) - $CategoryFrame := - put(category, 'isCategory, 'T, - addModemap(category, dc, sig, pred, impl, $CategoryFrame)) - -loadFunctor u == - null atom u => loadFunctor first u - loadLibIfNotLoaded u - u - -makeConstructorsAutoLoad() == - for cnam in allConstructors() repeat - REMPROP(cnam,'LOADED) --- fn:=GETDATABASE(cnam,'ABBREVIATION) - if GETDATABASE(cnam,'NILADIC) - then PUT(cnam,'NILADIC,'T) - else REMPROP(cnam,'NILADIC) - systemDependentMkAutoload(cnam,cnam) - -systemDependentMkAutoload(fn,cnam) == - FBOUNDP(cnam) => "next" - asharpName := GETDATABASE(cnam, 'ASHARP?) => - kind := GETDATABASE(cnam, 'CONSTRUCTORKIND) - cosig := GETDATABASE(cnam, 'COSIG) - file := GETDATABASE(cnam, 'OBJECT) - SET_-LIB_-FILE_-GETTER(file, cnam) - kind = 'category => - ASHARPMKAUTOLOADCATEGORY(file, cnam, asharpName, cosig) - ASHARPMKAUTOLOADFUNCTOR(file, cnam, asharpName, cosig) - SETF(SYMBOL_-FUNCTION cnam,mkAutoLoad(fn, cnam)) - -autoLoad(abb,cname) == - if not GETL(cname,'LOADED) then loadLib cname - SYMBOL_-FUNCTION cname - -setAutoLoadProperty(name) == --- abb := constructor? name - REMPROP(name,'LOADED) - SETF(SYMBOL_-FUNCTION name,mkAutoLoad(name, name)) - ---% Compilation - -compileConstructorLib(l,op,editFlag,traceFlag) == - --this file corresponds to /C,1 - MEMQ('_?,l) => return editFile '(_/C TELL _*) - optionList:= _/OPTIONS l - funList:= TRUNCLIST(l,optionList) or [_/FN] - options:= [[UPCASE CAR x,:CDR x] for x in optionList] - infile:= _/MKINFILENAM _/GETOPTION(options,'FROM_=) - outfile:= _/MKINFILENAM _/GETOPTION(options,'TO_=) - res:= [compConLib1(fn,infile,outfile,op,editFlag,traceFlag) - for fn in funList] - SHUT INPUTSTREAM - res - -compConLib1(fun,infileOrNil,outfileOrNil,auxOp,editFlag,traceFlag) == - $PRETTYPRINT: local := 'T - $LISPLIB: local := 'T - $lisplibAttributes: local := NIL - $lisplibPredicates: local := NIL - $lisplibForm: local := NIL - $lisplibAbbreviation: local := NIL - $lisplibParents: local := NIL - $lisplibAncestors: local := NIL - $lisplibKind: local := NIL - $lisplibModemap: local := NIL - $lisplibModemapAlist: local := NIL - $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) - $lisplibSlot1 : local := NIL --used by NRT mechanisms - $lisplibOperationAlist: local := NIL - $lisplibOpAlist: local:= NIL - $lisplibSuperDomain: local := NIL - $libFile: local := NIL - $lisplibVariableAlist: local := NIL - $lisplibSignatureAlist: local := NIL - if null atom fun and null CDR fun then fun:= CAR fun -- unwrap nullary - libName:= getConstructorAbbreviation fun - infile:= infileOrNil or getFunctionSourceFile fun or - throwKeyedMsg("S2IL0004",[fun]) - SETQ(_/EDITFILE,infile) - outfile := outfileOrNil or - [libName,'OUTPUT,$listingDirectory] --always QUIET - _$ERASE(libName,'OUTPUT,$listingDirectory) - outstream:= DEFSTREAM(outfile,'OUTPUT) - val:= _/D_,2_,LIB(fun,infile,outstream,auxOp,editFlag,traceFlag) - val - -compDefineLisplib(df:=["DEF",[op,:.],:.],m,e,prefix,fal,fn) == - --fn= compDefineCategory OR compDefineFunctor - sayMSG fillerSpaces(72,'"-") - $LISPLIB: local := 'T - $op: local := op - $lisplibAttributes: local := NIL - $lisplibPredicates: local := NIL -- set by makePredicateBitVector - $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) - $lisplibForm: local := NIL - $lisplibKind: local := NIL - $lisplibAbbreviation: local := NIL - $lisplibParents: local := NIL - $lisplibAncestors: 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 compDefineCategory1 if category, otherwise in finalizeLisplib - libName := getConstructorAbbreviation op - BOUNDP '$compileDocumentation and $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 - -- following guarantee's compiler output files get closed. - ok := false; - UNWIND_-PROTECT( - PROGN(res:= FUNCALL(fn,df,m,e,prefix,fal), - sayMSG ['" finalizing ",$spadLibFT,:bright libName], - finalizeLisplib libName, - ok := true), - RSHUT $libFile) - if ok then lisplibDoRename(libName) - filearg := $FILEP(libName,$spadLibFT,$libraryDirectory) - RPACKFILE filearg - FRESH_-LINE $algebraOutputStream - sayMSG fillerSpaces(72,'"-") - unloadOneConstructor(op,libName) - LOCALDATABASE(LIST GETDATABASE(op,'ABBREVIATION),NIL) - $newConlist := [op, :$newConlist] ----------> bound in function "compiler" - if $lisplibKind = 'category - then updateCategoryFrameForCategory op - else updateCategoryFrameForConstructor op - res - -compileDocumentation libName == - filename := MAKE_-INPUT_-FILENAME(libName,$spadLibFT) - $FCOPY(filename,[libName,'DOCLB]) - stream := RDEFIOSTREAM [['FILE,libName,'DOCLB],['MODE, :'O]] - lisplibWrite('"documentation",finalizeDocumentation(),stream) --- if $lisplibRelatedDomains then --- lisplibWrite('"relatedDomains",$lisplibRelatedDomains,stream) - RSHUT(stream) - RPACKFILE([libName,'DOCLB]) - $REPLACE([libName,$spadLibFT],[libName,'DOCLB]) - ['dummy, $EmptyMode, $e] - -getLisplibVersion libName == - stream := RDEFIOSTREAM [['FILE,libName,$spadLibFT],['MODE, :'I]] - version:= CADR rread('VERSION, stream,nil) - RSHUT(stream) - version - -initializeLisplib libName == - _$ERASE(libName,'ERRORLIB,$libraryDirectory) - SETQ(ERRORS,0) -- ERRORS is a fluid variable for the compiler - $libFile:= writeLib1(libName,'ERRORLIB,$libraryDirectory) - ADDOPTIONS('FILE,$libFile) - $lisplibForm := nil --defining form for lisplib - $lisplibModemap := nil --modemap for constructor form - $lisplibKind := nil --category, domain, or package - $lisplibModemapAlist := nil --changed in "augmentLisplibModemapsFromCategory" - $lisplibAbbreviation := nil - $lisplibAncestors := nil - $lisplibOpAlist := nil --operations alist for new runtime system - $lisplibOperationAlist := nil --old list of operations for functor/package - $lisplibSuperDomain:= nil - -- next var changed in "augmentLisplibDependents" - $lisplibVariableAlist := nil --this and the next are used by "luke" - $lisplibSignatureAlist := nil - if pathnameTypeId(_/EDITFILE) = 'SPAD - then LAM_,FILEACTQ('VERSION,['_/VERSIONCHECK,_/MAJOR_-VERSION]) - -finalizeLisplib libName == - lisplibWrite('"constructorForm",removeZeroOne $lisplibForm,$libFile) - lisplibWrite('"constructorKind",kind:=removeZeroOne $lisplibKind,$libFile) - lisplibWrite('"constructorModemap",removeZeroOne $lisplibModemap,$libFile) - $lisplibCategory:= $lisplibCategory or $lisplibModemap.mmTarget - -- set to target of modemap for package/domain constructors; - -- to the right-hand sides (the definition) for category constructors - lisplibWrite('"constructorCategory",$lisplibCategory,$libFile) - lisplibWrite('"sourceFile",namestring _/EDITFILE,$libFile) - lisplibWrite('"modemaps",removeZeroOne $lisplibModemapAlist,$libFile) - opsAndAtts:= getConstructorOpsAndAtts( - $lisplibForm,kind,$lisplibModemap) - lisplibWrite('"operationAlist",removeZeroOne CAR opsAndAtts,$libFile) - --lisplibWrite('"attributes",CDR opsAndAtts,$libFile) - --if kind='category then NRTgenInitialAttributeAlist CDR opsAndAtts - if kind='category then - $pairlis : local := [[a,:v] for a in rest $lisplibForm - for v in $FormalMapVariableList] - $NRTslot1PredicateList : local := [] - NRTgenInitialAttributeAlist CDR opsAndAtts - lisplibWrite('"superDomain",removeZeroOne $lisplibSuperDomain,$libFile) - lisplibWrite('"signaturesAndLocals", - removeZeroOne mergeSignatureAndLocalVarAlists($lisplibSignatureAlist, - $lisplibVariableAlist),$libFile) - lisplibWrite('"attributes",removeZeroOne $lisplibAttributes,$libFile) - lisplibWrite('"predicates",removeZeroOne $lisplibPredicates,$libFile) - lisplibWrite('"abbreviation",$lisplibAbbreviation,$libFile) - lisplibWrite('"parents",removeZeroOne $lisplibParents,$libFile) - lisplibWrite('"ancestors",removeZeroOne $lisplibAncestors,$libFile) - lisplibWrite('"documentation",finalizeDocumentation(),$libFile) - lisplibWrite('"slot1Info",removeZeroOne $lisplibSlot1,$libFile) - if $profileCompiler then profileWrite() - if $lisplibForm and null CDR $lisplibForm then - MAKEPROP(CAR $lisplibForm,'NILADIC,'T) - ERRORS ^=0 => -- ERRORS is a fluid variable for the compiler - sayMSG ['" Errors in processing ",kind,'" ",:bright libName,'":"] - sayMSG ['" not replacing ",$spadLibFT,'" for",:bright libName] - -lisplibDoRename(libName) == - _$REPLACE([libName,$spadLibFT,$libraryDirectory], - [libName,'ERRORLIB,$libraryDirectory]) - -lisplibError(cname,fname,type,cn,fn,typ,error) == - sayMSG bright ['" Illegal ",$spadLibFT] - error in '(duplicateAbb wrongType) => - sayKeyedMsg("S2IL0007", - [namestring [fname,$spadLibFT],type,cname,typ,cn]) - error is 'abbIsName => - throwKeyedMsg("S2IL0008",[fname,typ,namestring [fn,$spadLibFT]]) - -getPartialConstructorModemapSig(c) == - (s := getConstructorSignature c) => rest s - throwEvalTypeMsg("S2IL0015",[c]) - -mergeSignatureAndLocalVarAlists(signatureAlist, localVarAlist) == - -- this function makes a single Alist for both signatures - -- and local variable types, to be stored in the LISPLIB - -- for the function being compiled - [[funcName,:[signature,:LASSOC(funcName,localVarAlist)]] for - [funcName, :signature] in signatureAlist] - -Operators u == - ATOM u => [] - ATOM first u => - answer:="union"/[Operators v for v in rest u] - MEMQ(first u,answer) => answer - [first u,:answer] - "union"/[Operators v for v in u] - -getConstructorOpsAndAtts(form,kind,modemap) == - kind is 'category => getCategoryOpsAndAtts(form) - getFunctorOpsAndAtts(form,modemap) - -getCategoryOpsAndAtts(catForm) == - -- returns [operations,:attributes] of CAR catForm - [transformOperationAlist getSlotFromCategoryForm(catForm,1), - :getSlotFromCategoryForm(catForm,2)] - -getFunctorOpsAndAtts(form,modemap) == - [transformOperationAlist getSlotFromFunctor(form,1,modemap), - :getSlotFromFunctor(form,2,modemap)] - -getSlotFromFunctor([name,:args],slot,[[.,target,:argMml],:.]) == - slot = 1 => $lisplibOperationAlist - t := compMakeCategoryObject(target,$e) or - systemErrorHere '"getSlotFromFunctor" - t.expr.slot - -getSlot1 domainName == - $e: local:= $CategoryFrame - fn:= getLisplibName domainName - p := pathname [fn,$spadLibFT,'"*"] - not isExistingFile(p) => - sayKeyedMsg("S2IL0003",[namestring p]) - NIL - (sig := getConstructorSignature domainName) => - [.,target,:argMml] := sig - for a in $FormalMapVariableList for m in argMml repeat - $e:= put(a,'mode,m,$e) - t := compMakeCategoryObject(target,$e) or - systemErrorHere '"getSlot1" - t.expr.1 - sayKeyedMsg("S2IL0022",[namestring p,'"constructor modemap"]) - NIL - -transformOperationAlist operationAlist == - -- this transforms the operationAlist which is written out onto LISPLIBs. - -- The original form of this list is a list of items of the form: - -- (( ) ( (ELT $ n))) - -- The new form is an op-Alist which has entries ( . signature-Alist) - -- where signature-Alist has entries ( . item) - -- where item has form ( ) - -- where = - -- NIL => function - -- CONST => constant ... and others - newAlist:= nil - for [[op,sig,:.],condition,implementation] in operationAlist repeat - kind:= - implementation is [eltEtc,.,n] and eltEtc in '(CONST ELT) => eltEtc - implementation is [impOp,:.] => - impOp = 'XLAM => implementation - impOp in '(CONST Subsumed) => impOp - keyedSystemError("S2IL0025",[impOp]) - implementation = 'mkRecord => 'mkRecord - keyedSystemError("S2IL0025",[implementation]) - signatureItem:= - if u:= ASSOC([op,sig],$functionLocations) then n := [n,:rest u] - kind = 'ELT => - condition = 'T => [sig,n] - [sig,n,condition] - [sig,n,condition,kind] - itemList:= [signatureItem,:LASSQ(op,newAlist)] - newAlist:= insertAlist(op,itemList,newAlist) - newAlist - -sayNonUnique x == - sayBrightlyNT '"Non-unique:" - pp x - --- flattenOperationAlist operationAlist == --- --new form is ( ) --- [:[[op,:x] for x in y] for [op,:y] in operationAlist] - -getSlotFromDomain(dom,op,oldSig) == - -- returns the slot number in the domain where the function whose - -- signature is oldSig may be found in the domain dom - oldSig:= removeOPT oldSig - dom:= removeOPT dom - sig:= SUBST("$",dom,oldSig) - loadIfNecessary first dom - isPackageForm dom => getSlotFromPackage(dom,op,oldSig) - domain:= evalDomain dom - n:= findConstructorSlotNumber(dom,domain,op,sig) => - (slot:= domain.n).0 = Undef => - throwKeyedMsg("S2IL0023A",[op,formatSignature sig,dom]) - slot - throwKeyedMsg("S2IL0024A",[op,formatSignature sig,dom]) - -findConstructorSlotNumber(domainForm,domain,op,sig) == - null domain.1 => getSlotNumberFromOperationAlist(domainForm,op,sig) - sayMSG ['" using slot 1 of ",domainForm] - constructorArglist:= rest domainForm - nsig:=#sig - tail:= or/[r for [[op1,sig1],:r] in domain.1 | op=op1 and nsig=#sig1 and - "and"/[compare for a in sig for b in sig1]] where compare() == - a=b => true - FIXP b => a=constructorArglist.b - isSuperDomain(bustUnion b,bustUnion a,$CategoryFrame) - tail is [.,["ELT",.,n]] => n - systemErrorHere '"findSlotNumber" - -bustUnion d == - d is ["Union",domain,utype] and utype='"failed" => domain - d - -getSlotNumberFromOperationAlist(domainForm,op,sig) == - constructorName:= CAR domainForm - constructorArglist:= CDR domainForm - operationAlist:= - GETDATABASE(constructorName, 'OPERATIONALIST) or - keyedSystemError("S2IL0026",[constructorName]) - entryList:= QLASSQ(op,operationAlist) or return nil - tail:= or/[r for [sig1,:r] in entryList | sigsMatch(sig,sig1,domainForm)] => - first tail - nil - -sigsMatch(sig,sig1,domainForm) == - -- does signature "sig" match "sig1", where integers 1,2,.. in - -- sig1 designate corresponding arguments of domainForm - while sig and sig1 repeat - partsMatch:= - (item:= CAR sig)=(item1:= CAR sig1) => true --ok, go to next iteration - FIXP item1 => item = domainForm.item1 --item1=n means nth arg - isSuperDomain(bustUnion item,bustUnion item1,$CategoryFrame) - null partsMatch => return nil - sig:= rest sig; sig1 := rest sig1 - sig or sig1 => nil - true - -findDomainSlotNumber(domain,op,sig) == --using slot 1 of the domain - nsig:=#sig - tail:= or/[r for [[op1,sig1],:r] in domain.1 | op=op1 and nsig=#sig1 and - "and"/[a=b or isSuperDomain(bustUnion b,bustUnion a,$CategoryFrame) - for a in sig for b in sig1]] - tail is [.,["ELT",.,n]] => n - systemErrorHere '"findDomainSlotNumber" - - -getConstructorModemap form == - GETDATABASE(opOf form, 'CONSTRUCTORMODEMAP) - -getConstructorSignature form == - (mm := GETDATABASE(opOf(form),'CONSTRUCTORMODEMAP)) => - [[.,:sig],:.] := mm - sig - NIL - ---% from MODEMAP BOOT - -augModemapsFromDomain1(name,functorForm,e) == - GETL(KAR functorForm,"makeFunctionList") => - addConstructorModemaps(name,functorForm,e) - atom functorForm and (catform:= getmode(functorForm,e)) => - augModemapsFromCategory(name,name,functorForm,catform,e) - mappingForm:= getmodeOrMapping(KAR functorForm,e) => - ["Mapping",categoryForm,:functArgTypes]:= mappingForm - catform:= substituteCategoryArguments(rest functorForm,categoryForm) - augModemapsFromCategory(name,name,functorForm,catform,e) - stackMessage [functorForm," is an unknown mode"] - e - -getSlotFromCategoryForm ([op,:argl],index) == - u:= eval [op,:MAPCAR('MKQ,TAKE(#argl,$FormalMapVariableList))] - null VECP u => - systemErrorHere '"getSlotFromCategoryForm" - u . index - - ---% constructor evaluation --- The following functions are used by the compiler but are modified --- here for use with new LISPLIB scheme - -mkEvalableCategoryForm c == --from DEFINE - c is [op,:argl] => - op="Join" => ["Join",:[mkEvalableCategoryForm x for x in argl]] - op is "DomainSubstitutionMacro" => - --$extraParms :local - --catobj := EVAL c -- DomainSubstitutionFunction makes $extraParms - --mkEvalableCategoryForm sublisV($extraParms, catobj) - mkEvalableCategoryForm CADR argl - op is "mkCategory" => c - MEMQ(op,$CategoryNames) => - ([x,m,$e]:= compOrCroak(c,$EmptyMode,$e); m=$Category => x) - --loadIfNecessary op - GETDATABASE(op,'CONSTRUCTORKIND) = 'category or - get(op,"isCategory",$CategoryFrame) => - [op,:[quotifyCategoryArgument x for x in argl]] - [x,m,$e]:= compOrCroak(c,$EmptyMode,$e) - m=$Category => x - MKQ c - -isDomainForm(D,e) == - --added for MPOLY 3/83 by RDJ - MEMQ(KAR D,$SpecialDomainNames) or isFunctor D or - -- ((D is ['Mapping,target,:.]) and isCategoryForm(target,e)) or - ((getmode(D,e) is ['Mapping,target,:.]) and isCategoryForm(target,e)) or - isCategoryForm(getmode(D,e),e) or isDomainConstructorForm(D,e) - -isDomainConstructorForm(D,e) == - D is [op,:argl] and (u:= get(op,"value",e)) and - u is [.,["Mapping",target,:.],:.] and - isCategoryForm(EQSUBSTLIST(argl,$FormalMapVariableList,target),e) - -isFunctor x == - op:= opOf x - not IDENTP op => false - $InteractiveMode => - MEMQ(op,'(Union SubDomain Mapping Record)) => true - MEMQ(GETDATABASE(op,'CONSTRUCTORKIND),'(domain package)) - u:= get(op,'isFunctor,$CategoryFrame) - or MEMQ(op,'(SubDomain Union Record)) => u - constructor? op => - prop := get(op,'isFunctor,$CategoryFrame) => prop - if GETDATABASE(op,'CONSTRUCTORKIND) = 'category - then updateCategoryFrameForCategory op - else updateCategoryFrameForConstructor op - get(op,'isFunctor,$CategoryFrame) - nil - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/mark.boot b/src/interp/mark.boot new file mode 100644 index 00000000..333beb67 --- /dev/null +++ b/src/interp/mark.boot @@ -0,0 +1,1496 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical Algorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +-- 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 + + +)package "BOOT" + +REMPROP("and",'parseTran) +REMPROP("or",'parseTran) +REMPROP("not",'parseTran) +MAKEPROP("and",'special,'compAnd) +MAKEPROP("or",'special,'compOr) +MAKEPROP("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 ^= CAR T => [mkWi('comp,'WI,x,CAR T),:CDR T] + T + +markAny(key,x,T) == + tcheck T + x ^= CAR T => [mkWi(key,'WI,x,CAR T),:CDR 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,CAR T),:CDR T] + +yumyum kind == kind +markCoerce(T,T',kind) == --for coerce + tcheck T + tcheck T' + if kind = 'AUTOSUBSET then yumyum(kind) + STRINGP 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)),:CDR 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, ['Tuple,:nameList], ['Tuple,:valList]], + T.expr), :CDR T] + +markRetract(x,T) == + tcheck T + [mkWi('smallIntegerStep,'RETRACT,nil,['REPLACE,['retract,x]],T.expr),:CDR T] + +markSimpleReduce(x,T) == + tcheck T + [mkWi('compreduce,'LAMBDA, nil, ["REPLACE",x], T.expr), :CDR T] + +markCompAtom(x,T) == --for compAtom + tcheck T + BOUNDP '$convert2NewCompiler and $convert2NewCompiler => + [mkWi('compAtom,'ATOM,nil,['REPLACE,[x]],T.expr),:CDR T] + T + +markCase(x, tag, T) == + tcheck T + [mkWi('compCase1, 'LAMBDA, nil, ["REPLACE",["case",x,tag]], T.expr), + :CDR T] + +markCaseWas(x,T) == + tcheck T + [mkWi('compCase1,'WI,x,T.expr),:CDR T] + +markAutoWas(x,T) == + tcheck T + [mkWi('autoCoerce,'WI,x,T.expr),:CDR T] + +markCallCoerce(x,m,T) == + tcheck T + [mkWi("call",'WI,["::",x,m], T.expr),: CDR 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),:CDR 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), :CDR T] + +markAutoCoerceUp(x,T) == +-- y := getSourceWI x +-- y := +-- STRINGP y => INTERN y +-- y + tcheck T + [mkWi('coerceExtraHard,'LAMBDA, nil,["REPLACE",['construct, "##1"]],T.expr), + -----want to capture by ##1 what is there ------11/2/94 + :CDR T] + +markCompSymbol(x,T) == --for compSymbol + tcheck T + [mkWi('compSymbol,'ATOM,nil,['REPLACE,["@",x,$Symbol]],T.expr),:CDR 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),:CDR T'] + +markAt(T) == + tcheck T + [mkWi('compAtom,'COLON,"@",T.mode,T.expr),:CDR T] + +markCompColonInside(op,T) == --for compColonInside + tcheck T + BOUNDP '$convert2NewCompiler and $convert2NewCompiler => + [mkWi('compColonInside,'COLON,op,T.mode,T.expr),:CDR T] + T + +markLisp(T,m) == --for compForm1 + tcheck T + BOUNDP '$convert2NewCompiler and $convert2NewCompiler => + [mkWi('compForm1,'COLON,'Lisp,T.mode,T.expr),:CDR 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),:CDR T] + +markMacro(before,after) == --for compMacro + BOUNDP '$convert2NewCompiler and $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 + MEMQ(opOf a,'(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, CAR pr), :CDR pr] +markReduceBody(body,T) == + tcheck T + [mkWi("reduceBody",'WI,body,CAR T), :CDR T] +markReduce(form, T) == + tcheck T + [SETQ($funk,mkWi("reduce", 'WI,form,CAR T)), :CDR T] + +markRepeatBody(body,T) == + tcheck T + [mkWi("repeatBody",'WI,body,CAR T), :CDR T] + +markRepeat(form, T) == + tcheck T + [mkWi("repeat", 'WI,form,CAR T), :CDR T] + +markTran(form,form',[dc,:sig],env) == --from compElt/compFormWithModemap + dc ^= 'Rep or ^MEMQ('_$,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,CAR form',:argl] + wi := mkWi('markTran,'WI,form,form') + CAR 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 MEMQ(op,'(Boolean Mapping Void Segment UniversalSegment)) => nil + STRINGP d or (IDENTP d and (PNAME d).0 = char '_#) => nil + MEMQ(d,'(_$ _$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 BOUNDP '$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 + MEMQ(op,'(Record Union)) => +-- pp ['"Cannot find: ",name] + name + [op,:[markMacroTran x for x in argl]] + +markSetq(originalLet,T) == --for compSetq + BOUNDP '$convert2NewCompiler and $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,:CDR T] + [code,:CDR 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,:CDR 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) == + BOUNDP '$convert2NewCompiler and $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 REMDUP $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] => + MEMQ(op, '(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 MEMQ(y,'(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 MEMQ(fn, '(REPEAT COLLECT)) => markEncodeLoop(i,r,s) + t := getTargetWI r + markEncodeChanges(t,[i,:s]) + x is ['PROGN,a,:.] and s is [[op,:.],:.] and MEMQ(op,'(REPEAT COLLECT)) => + markEncodeChanges(a,s) + x is ['TAGGEDreturn,a,[y,:.]] => markEncodeChanges(y,s) + x is ['CATCH,a,y] => markEncodeChanges(y,s) + atom x => nil +-- CAR x = IFCAR IFCAR s => +-- for y in x for r in CAR 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 := PNAME op + k := charPosition(char '_;, s, 0) + k > MAXINDEX s => nil + origName := INTERN SUBSTRING(s, k + 1, nil) + MAKEPROP(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 MEMQ(op1, '(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 + +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 + FIXP item or item = $One or item = $Zero => nil + item is ["-",a] and (FIXP a or a = $One or a = $Zero) => nil + STRINGP item => nil + item is [op,.,t] and MEMQ(op,'( _:_: _@ _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 BOUNDP '$shout2 and $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 CDR u ---> allow duplicates on path + path := markGetPath(a,b) or return nil -----> early exit + if BOUNDP '$shout1 and $shout1 then + pp '"=========" + pp path + pp a + pp b + [:first path,:markPath1 CDR u] + 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,'"--------"] + if not BOUNDP '$pathErrorStack then SETQ($pathErrorStack,nil) + SETQ($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 BOUNDP '$shout and $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 MEMQ(op,'(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 MEMQ(fn,'(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 MEMQ(fn,'(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?(PNAME y,PNAME 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) +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 BOUNDP '$hohum and $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 not atom x then x := CDR x + atom x => + pp '"Translator RPLACA error" + pp $data + foobum form + form + if BOUNDP '$hohum and $hohum then pp [i, '" >>> ", x] + SETQ($CHANGE,COPY x) + if x is ['elt,:y] and r then x := y + RPLACA(x,markInsertChanges(code,CAR 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 MEMQ(op,'(_@ _: _:_: _pretend)) => ['_pretend,a,t] + [code,form,t] + MEMQ(code,'(_@ _:_: _pretend)) => + form is [op,a,b] and MEMQ(op,'(_@ _: _:_: _pretend)) => + MEMQ(op,'(_: _pretend)) => form + op = code and b = t => form + markNumCheck(code,form,t) + FIXP form and MEMQ(opOf t,$markPrimitiveNumbers) => ['_@,form,t] + [code,form,t] + MEMQ(code,'(_@ _:_: _:)) 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] + MEMQ(t,'(rep per)) => + t = 'rep and EQCAR(form,'per) => CADR form + t = 'per and EQCAR(form,'rep) => CADR form + [t,form] + code is [op,x,t1] and MEMQ(op,'(_@ _: _:_: _pretend)) and t1 = t => form + FIXP form and MEMQ(opOf t,$markPrimitiveNumbers) => ['_@,form,t] + markNumCheck("::",form,t) + +markNumCheck(op,form,t) == + op = "::" and MEMQ(opOf t,'(Integer)) => + s := form = $One and 1 or form = $Zero and 0 => ['DOLLAR, s , t] + FIXP form => ["@", form, t] + form is ["-", =$One] => ['DOLLAR, -1, t] + form is ["-", n] and FIXP 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() + RPLACA(CDDR T,$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 REMDUP [:$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 := MAKE_-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,:.] => CAR LASTNODE a + CAR LASTNODE addForm + addForm + if capsule is ['CAPSULE,:r] then + capsule := CAR 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 REMDUP 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 == + null atom 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 MEMQ(op,'(REPEAT COLLECT)) => markInsertRepeat u + u is ['LET,['Tuple,:s],b] => + ['LET,['Tuple,:[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 MEMQ(op,'(_add _with IN LET)) => + [op,markInsertBodyParts a,markInsertBodyParts b] + u is [op,a,b] and MEMQ(op,'(_: _:_: _pretend _@)) => + [op,markInsertBodyParts a,b] + u is [op,a,:x] and MEMQ(op,'(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,:.] => + MEMQ(op,'(MI WI)) => markKillExpr CADDR m + MEMQ(op,'(AUTOHARD AUTOSUBSET AUTOREP)) => markKillExpr CADDDR 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 CADDR m + MEMQ(op,'(MI WI)) => markKillButIfs CADDR m + MEMQ(op,'(AUTOHARD AUTOSUBSET AUTOREP)) => markKillButIfs CADDDR 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 CADDR m + MEMQ(op,'(MI WI)) => markKillAll CADDR m + MEMQ(op,'(AUTOHARD AUTOSUBSET AUTOREP)) => markKillAll CADDDR 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 ALPHA_-CHAR_-P (x . (n - 1)) => nil + not substring?('":= ", x, n+1) => nil + m := n + 3 + while (m := m + 1) <= N and ALPHA_-CHAR_-P (x . m) repeat nil + m = n + 2 => nil + not UPPER_-CASE_-P (x . (n + 4)) => nil + word := INTERN SUBSTRING(x, n + 4, m - n - 4) + expandedWord := macroExpand(word,$e) + not (MEMQ(word, '(Record Union Mapping)) + or GETDATABASE(opOf expandedWord,'CONSTRUCTORFORM)) => 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,nil), :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 STRINGP CDR p => acc := [CDR p, x, :acc] + (p := lookupRight(i, alist)) and (CAR p) > i => RPLACD(p, x) + acc := [x, :acc] + REVERSE acc + +lookupRight(x, al) == + al is [p, :al] => + x = CDR 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) + GETDATABASE(name,'CONSTRUCTORFORM) + +--====================================================================== +-- new path functions +--====================================================================== + +markGetPaths(x,y) == + BOUNDP '$newPaths and $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 REMDUP $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 REMDUP $badStack repeat + pp mkGetPaths(x,y) + +mkGetPaths(x,y) == + u := REMDUP 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 MEMQ(op,'(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 MEMQ(fn,'(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) => RPLACD(pair, [item,:CDR 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 := INTERN(STRCONC(ops,'"X",STRINGIMAGE i)) + RPLACA(form, 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 RPLACA(u, y) + if null atom 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 := CDR theForm + theAlist := [[pred, CAR form, :theArgl] for [pred,:form] in alist] + theNils := [nil for x in theForm] + thePred := + member(outerPred, '(T (QUOTE T))) => 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] => + MEMQ(op,'(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 + diff --git a/src/interp/mark.boot.pamphlet b/src/interp/mark.boot.pamphlet deleted file mode 100644 index a72c838d..00000000 --- a/src/interp/mark.boot.pamphlet +++ /dev/null @@ -1,1520 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\$SPAD/src/interp mark.boot} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{verbatim} - -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 - -\end{verbatim} -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -)package "BOOT" - -REMPROP("and",'parseTran) -REMPROP("or",'parseTran) -REMPROP("not",'parseTran) -MAKEPROP("and",'special,'compAnd) -MAKEPROP("or",'special,'compOr) -MAKEPROP("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 ^= CAR T => [mkWi('comp,'WI,x,CAR T),:CDR T] - T - -markAny(key,x,T) == - tcheck T - x ^= CAR T => [mkWi(key,'WI,x,CAR T),:CDR 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,CAR T),:CDR T] - -yumyum kind == kind -markCoerce(T,T',kind) == --for coerce - tcheck T - tcheck T' - if kind = 'AUTOSUBSET then yumyum(kind) - STRINGP 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)),:CDR 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, ['Tuple,:nameList], ['Tuple,:valList]], - T.expr), :CDR T] - -markRetract(x,T) == - tcheck T - [mkWi('smallIntegerStep,'RETRACT,nil,['REPLACE,['retract,x]],T.expr),:CDR T] - -markSimpleReduce(x,T) == - tcheck T - [mkWi('compreduce,'LAMBDA, nil, ["REPLACE",x], T.expr), :CDR T] - -markCompAtom(x,T) == --for compAtom - tcheck T - BOUNDP '$convert2NewCompiler and $convert2NewCompiler => - [mkWi('compAtom,'ATOM,nil,['REPLACE,[x]],T.expr),:CDR T] - T - -markCase(x, tag, T) == - tcheck T - [mkWi('compCase1, 'LAMBDA, nil, ["REPLACE",["case",x,tag]], T.expr), - :CDR T] - -markCaseWas(x,T) == - tcheck T - [mkWi('compCase1,'WI,x,T.expr),:CDR T] - -markAutoWas(x,T) == - tcheck T - [mkWi('autoCoerce,'WI,x,T.expr),:CDR T] - -markCallCoerce(x,m,T) == - tcheck T - [mkWi("call",'WI,["::",x,m], T.expr),: CDR 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),:CDR 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), :CDR T] - -markAutoCoerceUp(x,T) == --- y := getSourceWI x --- y := --- STRINGP y => INTERN y --- y - tcheck T - [mkWi('coerceExtraHard,'LAMBDA, nil,["REPLACE",['construct, "##1"]],T.expr), - -----want to capture by ##1 what is there ------11/2/94 - :CDR T] - -markCompSymbol(x,T) == --for compSymbol - tcheck T - [mkWi('compSymbol,'ATOM,nil,['REPLACE,["@",x,$Symbol]],T.expr),:CDR 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),:CDR T'] - -markAt(T) == - tcheck T - [mkWi('compAtom,'COLON,"@",T.mode,T.expr),:CDR T] - -markCompColonInside(op,T) == --for compColonInside - tcheck T - BOUNDP '$convert2NewCompiler and $convert2NewCompiler => - [mkWi('compColonInside,'COLON,op,T.mode,T.expr),:CDR T] - T - -markLisp(T,m) == --for compForm1 - tcheck T - BOUNDP '$convert2NewCompiler and $convert2NewCompiler => - [mkWi('compForm1,'COLON,'Lisp,T.mode,T.expr),:CDR 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),:CDR T] - -markMacro(before,after) == --for compMacro - BOUNDP '$convert2NewCompiler and $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 - MEMQ(opOf a,'(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, CAR pr), :CDR pr] -markReduceBody(body,T) == - tcheck T - [mkWi("reduceBody",'WI,body,CAR T), :CDR T] -markReduce(form, T) == - tcheck T - [SETQ($funk,mkWi("reduce", 'WI,form,CAR T)), :CDR T] - -markRepeatBody(body,T) == - tcheck T - [mkWi("repeatBody",'WI,body,CAR T), :CDR T] - -markRepeat(form, T) == - tcheck T - [mkWi("repeat", 'WI,form,CAR T), :CDR T] - -markTran(form,form',[dc,:sig],env) == --from compElt/compFormWithModemap - dc ^= 'Rep or ^MEMQ('_$,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,CAR form',:argl] - wi := mkWi('markTran,'WI,form,form') - CAR 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 MEMQ(op,'(Boolean Mapping Void Segment UniversalSegment)) => nil - STRINGP d or (IDENTP d and (PNAME d).0 = char '_#) => nil - MEMQ(d,'(_$ _$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 BOUNDP '$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 - MEMQ(op,'(Record Union)) => --- pp ['"Cannot find: ",name] - name - [op,:[markMacroTran x for x in argl]] - -markSetq(originalLet,T) == --for compSetq - BOUNDP '$convert2NewCompiler and $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,:CDR T] - [code,:CDR 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,:CDR 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) == - BOUNDP '$convert2NewCompiler and $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 REMDUP $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] => - MEMQ(op, '(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 MEMQ(y,'(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 MEMQ(fn, '(REPEAT COLLECT)) => markEncodeLoop(i,r,s) - t := getTargetWI r - markEncodeChanges(t,[i,:s]) - x is ['PROGN,a,:.] and s is [[op,:.],:.] and MEMQ(op,'(REPEAT COLLECT)) => - markEncodeChanges(a,s) - x is ['TAGGEDreturn,a,[y,:.]] => markEncodeChanges(y,s) - x is ['CATCH,a,y] => markEncodeChanges(y,s) - atom x => nil --- CAR x = IFCAR IFCAR s => --- for y in x for r in CAR 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 := PNAME op - k := charPosition(char '_;, s, 0) - k > MAXINDEX s => nil - origName := INTERN SUBSTRING(s, k + 1, nil) - MAKEPROP(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 MEMQ(op1, '(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 - -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 - FIXP item or item = $One or item = $Zero => nil - item is ["-",a] and (FIXP a or a = $One or a = $Zero) => nil - STRINGP item => nil - item is [op,.,t] and MEMQ(op,'( _:_: _@ _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 BOUNDP '$shout2 and $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 CDR u ---> allow duplicates on path - path := markGetPath(a,b) or return nil -----> early exit - if BOUNDP '$shout1 and $shout1 then - pp '"=========" - pp path - pp a - pp b - [:first path,:markPath1 CDR u] - 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,'"--------"] - if not BOUNDP '$pathErrorStack then SETQ($pathErrorStack,nil) - SETQ($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 BOUNDP '$shout and $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 MEMQ(op,'(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 MEMQ(fn,'(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 MEMQ(fn,'(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?(PNAME y,PNAME 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) -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 BOUNDP '$hohum and $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 not atom x then x := CDR x - atom x => - pp '"Translator RPLACA error" - pp $data - foobum form - form - if BOUNDP '$hohum and $hohum then pp [i, '" >>> ", x] - SETQ($CHANGE,COPY x) - if x is ['elt,:y] and r then x := y - RPLACA(x,markInsertChanges(code,CAR 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 MEMQ(op,'(_@ _: _:_: _pretend)) => ['_pretend,a,t] - [code,form,t] - MEMQ(code,'(_@ _:_: _pretend)) => - form is [op,a,b] and MEMQ(op,'(_@ _: _:_: _pretend)) => - MEMQ(op,'(_: _pretend)) => form - op = code and b = t => form - markNumCheck(code,form,t) - FIXP form and MEMQ(opOf t,$markPrimitiveNumbers) => ['_@,form,t] - [code,form,t] - MEMQ(code,'(_@ _:_: _:)) 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] - MEMQ(t,'(rep per)) => - t = 'rep and EQCAR(form,'per) => CADR form - t = 'per and EQCAR(form,'rep) => CADR form - [t,form] - code is [op,x,t1] and MEMQ(op,'(_@ _: _:_: _pretend)) and t1 = t => form - FIXP form and MEMQ(opOf t,$markPrimitiveNumbers) => ['_@,form,t] - markNumCheck("::",form,t) - -markNumCheck(op,form,t) == - op = "::" and MEMQ(opOf t,'(Integer)) => - s := form = $One and 1 or form = $Zero and 0 => ['DOLLAR, s , t] - FIXP form => ["@", form, t] - form is ["-", =$One] => ['DOLLAR, -1, t] - form is ["-", n] and FIXP 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() - RPLACA(CDDR T,$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 REMDUP [:$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 := MAKE_-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,:.] => CAR LASTNODE a - CAR LASTNODE addForm - addForm - if capsule is ['CAPSULE,:r] then - capsule := CAR 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 REMDUP 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 == - null atom 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 MEMQ(op,'(REPEAT COLLECT)) => markInsertRepeat u - u is ['LET,['Tuple,:s],b] => - ['LET,['Tuple,:[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 MEMQ(op,'(_add _with IN LET)) => - [op,markInsertBodyParts a,markInsertBodyParts b] - u is [op,a,b] and MEMQ(op,'(_: _:_: _pretend _@)) => - [op,markInsertBodyParts a,b] - u is [op,a,:x] and MEMQ(op,'(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,:.] => - MEMQ(op,'(MI WI)) => markKillExpr CADDR m - MEMQ(op,'(AUTOHARD AUTOSUBSET AUTOREP)) => markKillExpr CADDDR 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 CADDR m - MEMQ(op,'(MI WI)) => markKillButIfs CADDR m - MEMQ(op,'(AUTOHARD AUTOSUBSET AUTOREP)) => markKillButIfs CADDDR 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 CADDR m - MEMQ(op,'(MI WI)) => markKillAll CADDR m - MEMQ(op,'(AUTOHARD AUTOSUBSET AUTOREP)) => markKillAll CADDDR 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 ALPHA_-CHAR_-P (x . (n - 1)) => nil - not substring?('":= ", x, n+1) => nil - m := n + 3 - while (m := m + 1) <= N and ALPHA_-CHAR_-P (x . m) repeat nil - m = n + 2 => nil - not UPPER_-CASE_-P (x . (n + 4)) => nil - word := INTERN SUBSTRING(x, n + 4, m - n - 4) - expandedWord := macroExpand(word,$e) - not (MEMQ(word, '(Record Union Mapping)) - or GETDATABASE(opOf expandedWord,'CONSTRUCTORFORM)) => 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,nil), :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 STRINGP CDR p => acc := [CDR p, x, :acc] - (p := lookupRight(i, alist)) and (CAR p) > i => RPLACD(p, x) - acc := [x, :acc] - REVERSE acc - -lookupRight(x, al) == - al is [p, :al] => - x = CDR 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) - GETDATABASE(name,'CONSTRUCTORFORM) - ---====================================================================== --- new path functions ---====================================================================== - -markGetPaths(x,y) == - BOUNDP '$newPaths and $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 REMDUP $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 REMDUP $badStack repeat - pp mkGetPaths(x,y) - -mkGetPaths(x,y) == - u := REMDUP 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 MEMQ(op,'(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 MEMQ(fn,'(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) => RPLACD(pair, [item,:CDR 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 := INTERN(STRCONC(ops,'"X",STRINGIMAGE i)) - RPLACA(form, 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 RPLACA(u, y) - if null atom 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 := CDR theForm - theAlist := [[pred, CAR form, :theArgl] for [pred,:form] in alist] - theNils := [nil for x in theForm] - thePred := - member(outerPred, '(T (QUOTE T))) => 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] => - MEMQ(op,'(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 - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/msg.boot b/src/interp/msg.boot new file mode 100644 index 00000000..d8f13559 --- /dev/null +++ b/src/interp/msg.boot @@ -0,0 +1,553 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +ListMember?(ob, l) == + MEMBER(ob, l, KEYWORD::TEST, function EQUAL) + +--% Messages for the USERS of the compiler. +-- The program being compiled has a minor error. +-- Give a message and continue processing. +ncSoftError(pos, erMsgKey, erArgL,:optAttr) == + $newcompErrorCount := $newcompErrorCount + 1 + desiredMsg erMsgKey => + processKeyedError _ + msgCreate ('error, pos, erMsgKey, erArgL, $compErrorPrefix,optAttr) + +-- The program being compiled is seriously incorrect. +-- Give message and throw to a recovery point. +ncHardError(pos, erMsgKey, erArgL,:optAttr) == + $newcompErrorCount := $newcompErrorCount + 1 + desiredMsg erMsgKey => + erMsg := processKeyedError _ + msgCreate('error,pos,erMsgKey, erArgL, $compErrorPrefix,optAttr) + ncError() + +-- Bug in the compiler: something which shouldn't have happened did. +ncBug (erMsgKey, erArgL,:optAttr) == + $newcompErrorCount := $newcompErrorCount + 1 + erMsg := processKeyedError _ + msgCreate('bug,$nopos, erMsgKey, erArgL,$compBugPrefix,optAttr) + -- The next line is to try to deal with some reported cases of unwanted + -- backtraces appearing, MCD. + ENABLE_-BACKTRACE(nil) + BREAK() + ncAbort() + +--% Lower level functions + +--msgObject tag -- catagory of msg +-- -- attributes as a-list +-- 'imPr => dont save for list processing +-- toWhere, screen or file +-- 'norep => only display once in list +-- pos -- position with possible FROM/TO tag +-- key -- key for message database +-- argL -- arguments to be placed in the msg test +-- prefix -- things like "Error: " +-- text -- the actual text + +msgCreate(tag,posWTag,key,argL,optPre,:optAttr) == + if PAIRP key then tag := 'old + msg := [tag,posWTag,key,argL,optPre,NIL] + if CAR optAttr then + setMsgForcedAttrList(msg,car optAttr) + putDatabaseStuff msg + initImPr msg + initToWhere msg + msg + +processKeyedError msg == + getMsgTag? msg = 'old => --temp + erMsg := getMsgKey msg --temp + if pre := getMsgPrefix? msg then --temp + erMsg := ['%b, pre, '%d, :erMsg] --temp + sayBrightly ['"old msg from ",_ + CallerName 4,:erMsg] --temp + msgImPr? msg => + msgOutputter msg + $ncMsgList := cons (msg, $ncMsgList) + +--------------------------------- +--%getting info from db. +putDatabaseStuff msg == + [text,attributes] := getMsgInfoFromKey msg + if attributes then setMsgUnforcedAttrList(msg,attributes) + setMsgText(msg,text) + +getMsgInfoFromKey msg == + $msgDatabaseName : local := [] + msgText := + msgKey := getMsgKey? msg => --temp oldmsgs use key tostoretext + dbL := [$erLocMsgDatabaseName,$erGlbMsgDatabaseName] + getErFromDbL (msgKey,dbL) + getMsgKey msg --temp oldmsgs + msgText := segmentKeyedMsg msgText + [msgText,attributes] := removeAttributes msgText + msgText := substituteSegmentedMsg(msgText, getMsgArgL msg) + [msgText,attributes] + + +getErFromDbL (erMsgKey,dbL) == + erMsg := NIL + while null erMsg repeat + dbName := CAR dbL + dbL := CDR dbL + $msgDatabaseName := dbName + lastName := null dbL +-- fileFound := '"co_-eng.msgs" + fileFound := '"s2_-us.msgs" + if fileFound or lastName then + erMsg := fetchKeyedMsg(erMsgKey,not lastName) + erMsg + +----------------------- +--%character position marking + +processChPosesForOneLine msgList == + chPosList := posPointers msgList + for msg in msgList repeat + if getMsgFTTag? msg then + putFTText (msg,chPosList) + posLetter := CDR ASSOC(poCharPosn getMsgPos msg,chPosList) + oldPre := getMsgPrefix msg + setMsgPrefix (msg,STRCONC(oldPre,_ + MAKE_-FULL_-CVEC ($preLength - 4 - SIZE oldPre),posLetter) ) + leaderMsg := makeLeaderMsg chPosList + NCONC(msgList,LIST leaderMsg) --a back cons + +posPointers msgList == +--gets all the char posns for msgs on one line +--associates them with a uppercase letter + pointers := '"ABCDEFGHIJKLMONPQRS" + increment := 0 + posList:= [] + ftPosList := [] + for msg in msgList repeat + pos := poCharPosn getMsgPos msg + if pos ^= IFCAR posList then + posList := [pos,:posList] + if getMsgFTTag? msg = 'FROMTO then + ftPosList := [poCharPosn getMsgPos2 msg,:ftPosList] + for toPos in ftPosList repeat + posList := insertPos(toPos,posList) + for pos in posList repeat + posLetterList := [[pos,:pointers.increment],:posLetterList] + increment := increment + 1 + posLetterList + +insertPos(newPos,posList) == +--insersts a position in the proper place of a positon list +--used for the 2nd pos of a fromto + done := false + bot := [0,:posList] + top := [] + while not done repeat + top := [CAR bot,:top] + bot := CDR bot + pos := CAR bot + done := + pos < newPos => false + pos = newPos => true + pos > newPos => + top := [newPos,:top] + true + [CDR reverse top,:bot] + +putFTText (msg,chPosList) == + tag := getMsgFTTag? msg + pos := poCharPosn getMsgPos msg + charMarker := CDR ASSOC(pos,chPosList) + tag = 'FROM => + markingText := ['"(from ",charMarker,'" and on) "] + setMsgText(msg,[:markingText,:getMsgText msg]) + tag = 'TO => + markingText := ['"(up to ",charMarker,'") "] + setMsgText(msg,[:markingText,:getMsgText msg]) + tag = 'FROMTO => + pos2 := poCharPosn getMsgPos2 msg + charMarker2 := CDR ASSOC(pos2,chPosList) + markingText := ['"(from ",charMarker,'" up to ",_ + charMarker2,'") "] + setMsgText(msg,[:markingText,:getMsgText msg]) + +rep (c,n) == + n > 0 => + MAKE_-FULL_-CVEC(n, c) + '"" + +--called from parameter list of nc message functions +From pos == ['FROM, pos] +To pos == ['TO, pos] +FromTo (pos1,pos2) == ['FROMTO, pos1, pos2] + +------------------------ +--%processing error lists +processMsgList (erMsgList,lineList) == + $outputList :local := []--grows in queueUp errors + $noRepList :local := []--grows in queueUp errors + erMsgList := erMsgSort erMsgList + for line in lineList repeat + msgLine := makeMsgFromLine line + $outputList := [msgLine,:$outputList] + globalNumOfLine := poGlobalLinePosn getMsgPos msgLine + erMsgList := + queueUpErrors(globalNumOfLine,erMsgList) + $outputList := append(erMsgList,$outputList) --the nopos's + st := '"---------SOURCE-TEXT-&-ERRORS------------------------" + listOutputter reverse $outputList + +erMsgSort erMsgList == + [msgWPos,msgWOPos] := erMsgSep erMsgList + msgWPos := listSort(function erMsgCompare, msgWPos) + msgWOPos := reverse msgWOPos + [:msgWPos,:msgWOPos] + +erMsgCompare(ob1,ob2)== + pos1 := getMsgPos ob1 + pos2 := getMsgPos ob2 + compareposns(pos2,pos1) + +erMsgSep erMsgList == + msgWPos := [] + msgWOPos := [] + for msg in erMsgList repeat + if poNopos? getMsgPos msg then + msgWOPos := [msg,:msgWOPos] + else + msgWPos := [msg,:msgWPos] + [msgWPos,msgWOPos] + +getLinePos line == CAR line +getLineText line == CDR line + +queueUpErrors(globalNumOfLine,msgList)== + thisPosMsgs := [] + notThisLineMsgs := [] + for msg in msgList _ + while thisPosIsLess(getMsgPos msg,globalNumOfLine) repeat + --these are msgs that refer to positions from earlier compilations + if not redundant (msg,notThisPosMsgs) then + notThisPosMsgs := [msg,:notThisPosMsgs] + msgList := rest msgList + for msg in msgList _ + while thisPosIsEqual(getMsgPos msg,globalNumOfLine) repeat + if not redundant (msg,thisPosMsgs) then + thisPosMsgs := [msg,:thisPosMsgs] + msgList := rest msgList + if thisPosMsgs then + thisPosMsgs := processChPosesForOneLine thisPosMsgs + $outputList := NCONC(thisPosMsgs,$outputList) + if notThisPosMsgs then + $outputList := NCONC(notThisPosMsgs,$outputList) + msgList + +redundant(msg,thisPosMsgs) == + found := NIL + if msgNoRep? msg then + for item in $noRepList repeat + sameMsg?(msg,item) => return (found := true) + $noRepList := [msg,$noRepList] + found or member(msg,thisPosMsgs) + +sameMsg? (msg1,msg2) == + (getMsgKey msg1 = getMsgKey msg2) and _ + (getMsgArgL msg1 = getMsgArgL msg2) + + +thisPosIsLess(pos,num) == + poNopos? pos => NIL + poGlobalLinePosn pos < num + +thisPosIsEqual(pos,num) == + poNopos? pos => NIL + poGlobalLinePosn pos = num + +--%outputting stuff + +listOutputter outputList == + for msg in outputList repeat + msgOutputter msg + +msgOutputter msg == + st := getStFromMsg msg + shouldFlow := not (leader? msg or line? msg) + if toScreen? msg then + if shouldFlow then + st := flowSegmentedMsg(st,$LINELENGTH,0) + sayBrightly st + if toFile? msg then + if shouldFlow then + st := flowSegmentedMsg(st,$LOGLENGTH,0) + alreadyOpened := alreadyOpened? msg + +toScreen? msg == getMsgToWhere msg ^= 'fileOnly +toFile? msg == + PAIRP $fn and _ + getMsgToWhere msg ^= 'screenOnly + + +alreadyOpened? msg == + not msgImPr? msg + +getStFromMsg msg == + $optKeyBlanks : local := '"" --set in setOptKeyBlanks() + setOptKeyBlanks() + preStL := getPreStL getMsgPrefix? msg + getMsgTag msg = 'line => + [$optKeyBlanks, '"%x1" , :preStL,_ + getMsgText msg] + posStL := getPosStL msg + optKey := + $showKeyNum => + msgKey := getMsgKey? msg => PNAME msgKey + '"no key " + '"" + st :=[posStL,getMsgLitSym msg,_ + optKey,:preStL,_ + tabbing msg,:getMsgText msg] + +tabbing msg == + chPos := 2 + if getMsgPrefix? msg then + chPos := chPos + $preLength - 1 + if $showKeyNum then chPos := chPos + 8 + ["%t",:chPos] + +setOptKeyBlanks() == + $optKeyBlanks := + $showKeyNum => '"%x8" + '"" + +getPosStL msg == + not showMsgPos? msg => '"" + msgPos := getMsgPos msg + howMuch := + msgImPr? msg => + decideHowMuch (msgPos,$lastPos) + listDecideHowMuch (msgPos,$lastPos) + $lastPos := msgPos + fullPrintedPos := ppos msgPos + printedFileName := ['"%x2",'"[",:remLine fullPrintedPos,'"]" ] + printedLineNum := ['"%x2",'"[",:remFile fullPrintedPos,'"]" ] + printedOrigin := ['"%x2",'"[",:fullPrintedPos,'"]" ] + howMuch = 'ORG => [$optKeyBlanks,:printedOrigin, '%l] + howMuch = 'LINE => [$optKeyBlanks,:printedLineNum, '%l] + howMuch = 'FILE => [$optKeyBlanks,:printedFileName, '%l] + howMuch = 'ALL => [$optKeyBlanks,:printedFileName, '%l,_ + $optKeyBlanks,:printedLineNum, '%l] + '"" + +showMsgPos? msg == + $erMsgToss or (not msgImPr? msg and not msgLeader? msg) + + +remFile positionList == + IFCDR IFCDR positionList + +remLine positionList == + [IFCAR positionList] + +decideHowMuch(pos,oldPos) == +--when printing a msg, we wish not to show pos infor that was +--shown for a previous msg with identical pos info. +--org prints out the word noposition or console + ((poNopos? pos) and (poNopos? oldPos)) or _ + ((poPosImmediate? pos) and (poPosImmediate? oldPos)) => 'NONE + (poNopos? pos) or (poPosImmediate? pos) => 'ORG + (poNopos? oldPos) or (poPosImmediate? oldPos) => 'ALL + poFileName oldPos ^= poFileName pos => 'ALL + poLinePosn oldPos ^= poLinePosn pos => 'LINE + 'NONE + +listDecideHowMuch(pos,oldPos) == + ((poNopos? pos) and (poNopos? oldPos)) or _ + ((poPosImmediate? pos) and (poPosImmediate? oldPos)) => 'NONE + (poNopos? pos) => 'ORG + (poNopos? oldPos) => 'NONE + poGlobalLinePosn pos < poGlobalLinePosn oldPos => + poPosImmediate? pos => 'ORG + 'LINE + --(poNopos? pos) or (poPosImmediate? pos) => 'ORG + 'NONE + +getPreStL optPre == + null optPre => [MAKE_-FULL_-CVEC 2] + spses := + (extraPlaces := ($preLength - (SIZE optPre) - 3)) > 0 => + MAKE_-FULL_-CVEC extraPlaces + '"" + ['%b, optPre,spses,'":", '%d] + +------------------- +--% a-list stuff +desiredMsg (erMsgKey,:optCatFlag) == + isKeyQualityP(erMsgKey,'show) => true + isKeyQualityP(erMsgKey,'stifle) => false + not null optCatFlag => CAR optCatFlag + true + +isKeyQualityP (key,qual) == + --returns pair if found, else NIL + found := false + while not found and (qualPair := ASSOC(key,$specificMsgTags)) repeat + if CDR qualPair = qual then found := true + qualPair + +----------------------------- +--% these functions handle the attributes + +initImPr msg == + $erMsgToss or MEMQ (getMsgTag msg,$imPrTagGuys) => + setMsgUnforcedAttr (msg,'$imPrGuys,'imPr) + +initToWhere msg == + member ('trace,getMsgCatAttr (msg,'catless)) => + setMsgUnforcedAttr (msg,'$toWhereGuys,'screenOnly) + +msgImPr? msg == + (getMsgCatAttr (msg,'$imPrGuys) = 'imPr) + +msgNoRep? msg == + (getMsgCatAttr (msg,'$repGuys) = 'noRep) + +msgLeader? msg == + getMsgTag msg = 'leader + +getMsgToWhere msg == + getMsgCatAttr (msg,'$toWhereGuys) + +getMsgCatAttr (msg,cat) == + IFCDR QASSQ(cat, ncAlist msg) + +setMsgForcedAttrList (msg,aL) == + for attr in aL repeat + setMsgForcedAttr(msg,whichCat attr,attr) + +setMsgUnforcedAttrList (msg,aL) == + for attr in aL repeat + setMsgUnforcedAttr(msg,whichCat attr,attr) + +setMsgForcedAttr(msg,cat,attr) == + cat = 'catless => setMsgCatlessAttr(msg,attr) + ncPutQ(msg,cat,attr) + +setMsgUnforcedAttr(msg,cat,attr) == + cat = 'catless => setMsgCatlessAttr(msg,attr) + not QASSQ(cat, ncAlist msg) => ncPutQ(msg,cat,attr) + +setMsgCatlessAttr(msg,attr) == + ncPutQ(msg,'catless,CONS (attr, IFCDR QASSQ(catless, ncAlist msg))) + +whichCat attr == + found := 'catless + for cat in $attrCats repeat + if ListMember? (attr,EVAL cat) then + found := cat + return found + found + +-------------------------------------- +--% these functions directly interact with the message object + +makeLeaderMsg chPosList == + st := MAKE_-FULL_-CVEC ($preLength- 3) + oldPos := -1 + for [posNum,:posLetter] in reverse chPosList repeat + st := STRCONC(st, _ + rep(char ".", (posNum - oldPos - 1)),posLetter) + oldPos := posNum + ['leader,$nopos,'nokey,NIL,NIL,[st]] + +makeMsgFromLine line == + posOfLine := getLinePos line + textOfLine := getLineText line + globalNumOfLine := poGlobalLinePosn posOfLine + localNumOfLine := + i := poLinePosn posOfLine + stNum := STRINGIMAGE i + STRCONC(rep(char " ", ($preLength - 7 - SIZE stNum)),_ + stNum) + ['line,posOfLine,NIL,NIL, STRCONC('"Line", localNumOfLine),_ + textOfLine] + +getMsgTag msg == ncTag msg + +getMsgTag? msg == + IFCAR member (getMsgTag msg,_ + ['line,'old,'error,'warn,'bug,'unimple,'remark,'stat,'say,'debug]) + +leader? msg == getMsgTag msg = 'leader +line? msg == getMsgTag msg = 'line + +getMsgPosTagOb msg == msg.1 + +getMsgPos msg == + getMsgFTTag? msg => CADR getMsgPosTagOb msg + getMsgPosTagOb msg + +getMsgPos2 msg == + getMsgFTTag? msg => CADDR getMsgPosTagOb msg + ncBug('"not a from to",[]) + +getMsgFTTag? msg == IFCAR member (IFCAR getMsgPosTagOb msg,_ + ['FROM,'TO,'FROMTO]) + +getMsgKey msg == msg.2 + +getMsgKey? msg == IDENTP (val := getMsgKey msg) => val + +getMsgArgL msg == msg.3 + +getMsgPrefix? msg == + (pre := msg.4) = 'noPre => NIL + pre + +getMsgPrefix msg == msg.4 + + +getMsgLitSym msg == + getMsgKey? msg => '" " + '"*" + +getMsgText msg == msg.5 + +setMsgPrefix (msg,val) == msg.4 := val + +setMsgText (msg,val) == msg.5 := val + + + + diff --git a/src/interp/msg.boot.pamphlet b/src/interp/msg.boot.pamphlet deleted file mode 100644 index ac311779..00000000 --- a/src/interp/msg.boot.pamphlet +++ /dev/null @@ -1,577 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/msg.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} - -\tableofcontents -\eject - -\section{License} - -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -)package "BOOT" - -ListMember?(ob, l) == - MEMBER(ob, l, KEYWORD::TEST, function EQUAL) - ---% Messages for the USERS of the compiler. --- The program being compiled has a minor error. --- Give a message and continue processing. -ncSoftError(pos, erMsgKey, erArgL,:optAttr) == - $newcompErrorCount := $newcompErrorCount + 1 - desiredMsg erMsgKey => - processKeyedError _ - msgCreate ('error, pos, erMsgKey, erArgL, $compErrorPrefix,optAttr) - --- The program being compiled is seriously incorrect. --- Give message and throw to a recovery point. -ncHardError(pos, erMsgKey, erArgL,:optAttr) == - $newcompErrorCount := $newcompErrorCount + 1 - desiredMsg erMsgKey => - erMsg := processKeyedError _ - msgCreate('error,pos,erMsgKey, erArgL, $compErrorPrefix,optAttr) - ncError() - --- Bug in the compiler: something which shouldn't have happened did. -ncBug (erMsgKey, erArgL,:optAttr) == - $newcompErrorCount := $newcompErrorCount + 1 - erMsg := processKeyedError _ - msgCreate('bug,$nopos, erMsgKey, erArgL,$compBugPrefix,optAttr) - -- The next line is to try to deal with some reported cases of unwanted - -- backtraces appearing, MCD. - ENABLE_-BACKTRACE(nil) - BREAK() - ncAbort() - ---% Lower level functions - ---msgObject tag -- catagory of msg --- -- attributes as a-list --- 'imPr => dont save for list processing --- toWhere, screen or file --- 'norep => only display once in list --- pos -- position with possible FROM/TO tag --- key -- key for message database --- argL -- arguments to be placed in the msg test --- prefix -- things like "Error: " --- text -- the actual text - -msgCreate(tag,posWTag,key,argL,optPre,:optAttr) == - if PAIRP key then tag := 'old - msg := [tag,posWTag,key,argL,optPre,NIL] - if CAR optAttr then - setMsgForcedAttrList(msg,car optAttr) - putDatabaseStuff msg - initImPr msg - initToWhere msg - msg - -processKeyedError msg == - getMsgTag? msg = 'old => --temp - erMsg := getMsgKey msg --temp - if pre := getMsgPrefix? msg then --temp - erMsg := ['%b, pre, '%d, :erMsg] --temp - sayBrightly ['"old msg from ",_ - CallerName 4,:erMsg] --temp - msgImPr? msg => - msgOutputter msg - $ncMsgList := cons (msg, $ncMsgList) - ---------------------------------- ---%getting info from db. -putDatabaseStuff msg == - [text,attributes] := getMsgInfoFromKey msg - if attributes then setMsgUnforcedAttrList(msg,attributes) - setMsgText(msg,text) - -getMsgInfoFromKey msg == - $msgDatabaseName : local := [] - msgText := - msgKey := getMsgKey? msg => --temp oldmsgs use key tostoretext - dbL := [$erLocMsgDatabaseName,$erGlbMsgDatabaseName] - getErFromDbL (msgKey,dbL) - getMsgKey msg --temp oldmsgs - msgText := segmentKeyedMsg msgText - [msgText,attributes] := removeAttributes msgText - msgText := substituteSegmentedMsg(msgText, getMsgArgL msg) - [msgText,attributes] - - -getErFromDbL (erMsgKey,dbL) == - erMsg := NIL - while null erMsg repeat - dbName := CAR dbL - dbL := CDR dbL - $msgDatabaseName := dbName - lastName := null dbL --- fileFound := '"co_-eng.msgs" - fileFound := '"s2_-us.msgs" - if fileFound or lastName then - erMsg := fetchKeyedMsg(erMsgKey,not lastName) - erMsg - ------------------------ ---%character position marking - -processChPosesForOneLine msgList == - chPosList := posPointers msgList - for msg in msgList repeat - if getMsgFTTag? msg then - putFTText (msg,chPosList) - posLetter := CDR ASSOC(poCharPosn getMsgPos msg,chPosList) - oldPre := getMsgPrefix msg - setMsgPrefix (msg,STRCONC(oldPre,_ - MAKE_-FULL_-CVEC ($preLength - 4 - SIZE oldPre),posLetter) ) - leaderMsg := makeLeaderMsg chPosList - NCONC(msgList,LIST leaderMsg) --a back cons - -posPointers msgList == ---gets all the char posns for msgs on one line ---associates them with a uppercase letter - pointers := '"ABCDEFGHIJKLMONPQRS" - increment := 0 - posList:= [] - ftPosList := [] - for msg in msgList repeat - pos := poCharPosn getMsgPos msg - if pos ^= IFCAR posList then - posList := [pos,:posList] - if getMsgFTTag? msg = 'FROMTO then - ftPosList := [poCharPosn getMsgPos2 msg,:ftPosList] - for toPos in ftPosList repeat - posList := insertPos(toPos,posList) - for pos in posList repeat - posLetterList := [[pos,:pointers.increment],:posLetterList] - increment := increment + 1 - posLetterList - -insertPos(newPos,posList) == ---insersts a position in the proper place of a positon list ---used for the 2nd pos of a fromto - done := false - bot := [0,:posList] - top := [] - while not done repeat - top := [CAR bot,:top] - bot := CDR bot - pos := CAR bot - done := - pos < newPos => false - pos = newPos => true - pos > newPos => - top := [newPos,:top] - true - [CDR reverse top,:bot] - -putFTText (msg,chPosList) == - tag := getMsgFTTag? msg - pos := poCharPosn getMsgPos msg - charMarker := CDR ASSOC(pos,chPosList) - tag = 'FROM => - markingText := ['"(from ",charMarker,'" and on) "] - setMsgText(msg,[:markingText,:getMsgText msg]) - tag = 'TO => - markingText := ['"(up to ",charMarker,'") "] - setMsgText(msg,[:markingText,:getMsgText msg]) - tag = 'FROMTO => - pos2 := poCharPosn getMsgPos2 msg - charMarker2 := CDR ASSOC(pos2,chPosList) - markingText := ['"(from ",charMarker,'" up to ",_ - charMarker2,'") "] - setMsgText(msg,[:markingText,:getMsgText msg]) - -rep (c,n) == - n > 0 => - MAKE_-FULL_-CVEC(n, c) - '"" - ---called from parameter list of nc message functions -From pos == ['FROM, pos] -To pos == ['TO, pos] -FromTo (pos1,pos2) == ['FROMTO, pos1, pos2] - ------------------------- ---%processing error lists -processMsgList (erMsgList,lineList) == - $outputList :local := []--grows in queueUp errors - $noRepList :local := []--grows in queueUp errors - erMsgList := erMsgSort erMsgList - for line in lineList repeat - msgLine := makeMsgFromLine line - $outputList := [msgLine,:$outputList] - globalNumOfLine := poGlobalLinePosn getMsgPos msgLine - erMsgList := - queueUpErrors(globalNumOfLine,erMsgList) - $outputList := append(erMsgList,$outputList) --the nopos's - st := '"---------SOURCE-TEXT-&-ERRORS------------------------" - listOutputter reverse $outputList - -erMsgSort erMsgList == - [msgWPos,msgWOPos] := erMsgSep erMsgList - msgWPos := listSort(function erMsgCompare, msgWPos) - msgWOPos := reverse msgWOPos - [:msgWPos,:msgWOPos] - -erMsgCompare(ob1,ob2)== - pos1 := getMsgPos ob1 - pos2 := getMsgPos ob2 - compareposns(pos2,pos1) - -erMsgSep erMsgList == - msgWPos := [] - msgWOPos := [] - for msg in erMsgList repeat - if poNopos? getMsgPos msg then - msgWOPos := [msg,:msgWOPos] - else - msgWPos := [msg,:msgWPos] - [msgWPos,msgWOPos] - -getLinePos line == CAR line -getLineText line == CDR line - -queueUpErrors(globalNumOfLine,msgList)== - thisPosMsgs := [] - notThisLineMsgs := [] - for msg in msgList _ - while thisPosIsLess(getMsgPos msg,globalNumOfLine) repeat - --these are msgs that refer to positions from earlier compilations - if not redundant (msg,notThisPosMsgs) then - notThisPosMsgs := [msg,:notThisPosMsgs] - msgList := rest msgList - for msg in msgList _ - while thisPosIsEqual(getMsgPos msg,globalNumOfLine) repeat - if not redundant (msg,thisPosMsgs) then - thisPosMsgs := [msg,:thisPosMsgs] - msgList := rest msgList - if thisPosMsgs then - thisPosMsgs := processChPosesForOneLine thisPosMsgs - $outputList := NCONC(thisPosMsgs,$outputList) - if notThisPosMsgs then - $outputList := NCONC(notThisPosMsgs,$outputList) - msgList - -redundant(msg,thisPosMsgs) == - found := NIL - if msgNoRep? msg then - for item in $noRepList repeat - sameMsg?(msg,item) => return (found := true) - $noRepList := [msg,$noRepList] - found or member(msg,thisPosMsgs) - -sameMsg? (msg1,msg2) == - (getMsgKey msg1 = getMsgKey msg2) and _ - (getMsgArgL msg1 = getMsgArgL msg2) - - -thisPosIsLess(pos,num) == - poNopos? pos => NIL - poGlobalLinePosn pos < num - -thisPosIsEqual(pos,num) == - poNopos? pos => NIL - poGlobalLinePosn pos = num - ---%outputting stuff - -listOutputter outputList == - for msg in outputList repeat - msgOutputter msg - -msgOutputter msg == - st := getStFromMsg msg - shouldFlow := not (leader? msg or line? msg) - if toScreen? msg then - if shouldFlow then - st := flowSegmentedMsg(st,$LINELENGTH,0) - sayBrightly st - if toFile? msg then - if shouldFlow then - st := flowSegmentedMsg(st,$LOGLENGTH,0) - alreadyOpened := alreadyOpened? msg - -toScreen? msg == getMsgToWhere msg ^= 'fileOnly -toFile? msg == - PAIRP $fn and _ - getMsgToWhere msg ^= 'screenOnly - - -alreadyOpened? msg == - not msgImPr? msg - -getStFromMsg msg == - $optKeyBlanks : local := '"" --set in setOptKeyBlanks() - setOptKeyBlanks() - preStL := getPreStL getMsgPrefix? msg - getMsgTag msg = 'line => - [$optKeyBlanks, '"%x1" , :preStL,_ - getMsgText msg] - posStL := getPosStL msg - optKey := - $showKeyNum => - msgKey := getMsgKey? msg => PNAME msgKey - '"no key " - '"" - st :=[posStL,getMsgLitSym msg,_ - optKey,:preStL,_ - tabbing msg,:getMsgText msg] - -tabbing msg == - chPos := 2 - if getMsgPrefix? msg then - chPos := chPos + $preLength - 1 - if $showKeyNum then chPos := chPos + 8 - ["%t",:chPos] - -setOptKeyBlanks() == - $optKeyBlanks := - $showKeyNum => '"%x8" - '"" - -getPosStL msg == - not showMsgPos? msg => '"" - msgPos := getMsgPos msg - howMuch := - msgImPr? msg => - decideHowMuch (msgPos,$lastPos) - listDecideHowMuch (msgPos,$lastPos) - $lastPos := msgPos - fullPrintedPos := ppos msgPos - printedFileName := ['"%x2",'"[",:remLine fullPrintedPos,'"]" ] - printedLineNum := ['"%x2",'"[",:remFile fullPrintedPos,'"]" ] - printedOrigin := ['"%x2",'"[",:fullPrintedPos,'"]" ] - howMuch = 'ORG => [$optKeyBlanks,:printedOrigin, '%l] - howMuch = 'LINE => [$optKeyBlanks,:printedLineNum, '%l] - howMuch = 'FILE => [$optKeyBlanks,:printedFileName, '%l] - howMuch = 'ALL => [$optKeyBlanks,:printedFileName, '%l,_ - $optKeyBlanks,:printedLineNum, '%l] - '"" - -showMsgPos? msg == - $erMsgToss or (not msgImPr? msg and not msgLeader? msg) - - -remFile positionList == - IFCDR IFCDR positionList - -remLine positionList == - [IFCAR positionList] - -decideHowMuch(pos,oldPos) == ---when printing a msg, we wish not to show pos infor that was ---shown for a previous msg with identical pos info. ---org prints out the word noposition or console - ((poNopos? pos) and (poNopos? oldPos)) or _ - ((poPosImmediate? pos) and (poPosImmediate? oldPos)) => 'NONE - (poNopos? pos) or (poPosImmediate? pos) => 'ORG - (poNopos? oldPos) or (poPosImmediate? oldPos) => 'ALL - poFileName oldPos ^= poFileName pos => 'ALL - poLinePosn oldPos ^= poLinePosn pos => 'LINE - 'NONE - -listDecideHowMuch(pos,oldPos) == - ((poNopos? pos) and (poNopos? oldPos)) or _ - ((poPosImmediate? pos) and (poPosImmediate? oldPos)) => 'NONE - (poNopos? pos) => 'ORG - (poNopos? oldPos) => 'NONE - poGlobalLinePosn pos < poGlobalLinePosn oldPos => - poPosImmediate? pos => 'ORG - 'LINE - --(poNopos? pos) or (poPosImmediate? pos) => 'ORG - 'NONE - -getPreStL optPre == - null optPre => [MAKE_-FULL_-CVEC 2] - spses := - (extraPlaces := ($preLength - (SIZE optPre) - 3)) > 0 => - MAKE_-FULL_-CVEC extraPlaces - '"" - ['%b, optPre,spses,'":", '%d] - -------------------- ---% a-list stuff -desiredMsg (erMsgKey,:optCatFlag) == - isKeyQualityP(erMsgKey,'show) => true - isKeyQualityP(erMsgKey,'stifle) => false - not null optCatFlag => CAR optCatFlag - true - -isKeyQualityP (key,qual) == - --returns pair if found, else NIL - found := false - while not found and (qualPair := ASSOC(key,$specificMsgTags)) repeat - if CDR qualPair = qual then found := true - qualPair - ------------------------------ ---% these functions handle the attributes - -initImPr msg == - $erMsgToss or MEMQ (getMsgTag msg,$imPrTagGuys) => - setMsgUnforcedAttr (msg,'$imPrGuys,'imPr) - -initToWhere msg == - member ('trace,getMsgCatAttr (msg,'catless)) => - setMsgUnforcedAttr (msg,'$toWhereGuys,'screenOnly) - -msgImPr? msg == - (getMsgCatAttr (msg,'$imPrGuys) = 'imPr) - -msgNoRep? msg == - (getMsgCatAttr (msg,'$repGuys) = 'noRep) - -msgLeader? msg == - getMsgTag msg = 'leader - -getMsgToWhere msg == - getMsgCatAttr (msg,'$toWhereGuys) - -getMsgCatAttr (msg,cat) == - IFCDR QASSQ(cat, ncAlist msg) - -setMsgForcedAttrList (msg,aL) == - for attr in aL repeat - setMsgForcedAttr(msg,whichCat attr,attr) - -setMsgUnforcedAttrList (msg,aL) == - for attr in aL repeat - setMsgUnforcedAttr(msg,whichCat attr,attr) - -setMsgForcedAttr(msg,cat,attr) == - cat = 'catless => setMsgCatlessAttr(msg,attr) - ncPutQ(msg,cat,attr) - -setMsgUnforcedAttr(msg,cat,attr) == - cat = 'catless => setMsgCatlessAttr(msg,attr) - not QASSQ(cat, ncAlist msg) => ncPutQ(msg,cat,attr) - -setMsgCatlessAttr(msg,attr) == - ncPutQ(msg,'catless,CONS (attr, IFCDR QASSQ(catless, ncAlist msg))) - -whichCat attr == - found := 'catless - for cat in $attrCats repeat - if ListMember? (attr,EVAL cat) then - found := cat - return found - found - --------------------------------------- ---% these functions directly interact with the message object - -makeLeaderMsg chPosList == - st := MAKE_-FULL_-CVEC ($preLength- 3) - oldPos := -1 - for [posNum,:posLetter] in reverse chPosList repeat - st := STRCONC(st, _ - rep(char ".", (posNum - oldPos - 1)),posLetter) - oldPos := posNum - ['leader,$nopos,'nokey,NIL,NIL,[st]] - -makeMsgFromLine line == - posOfLine := getLinePos line - textOfLine := getLineText line - globalNumOfLine := poGlobalLinePosn posOfLine - localNumOfLine := - i := poLinePosn posOfLine - stNum := STRINGIMAGE i - STRCONC(rep(char " ", ($preLength - 7 - SIZE stNum)),_ - stNum) - ['line,posOfLine,NIL,NIL, STRCONC('"Line", localNumOfLine),_ - textOfLine] - -getMsgTag msg == ncTag msg - -getMsgTag? msg == - IFCAR member (getMsgTag msg,_ - ['line,'old,'error,'warn,'bug,'unimple,'remark,'stat,'say,'debug]) - -leader? msg == getMsgTag msg = 'leader -line? msg == getMsgTag msg = 'line - -getMsgPosTagOb msg == msg.1 - -getMsgPos msg == - getMsgFTTag? msg => CADR getMsgPosTagOb msg - getMsgPosTagOb msg - -getMsgPos2 msg == - getMsgFTTag? msg => CADDR getMsgPosTagOb msg - ncBug('"not a from to",[]) - -getMsgFTTag? msg == IFCAR member (IFCAR getMsgPosTagOb msg,_ - ['FROM,'TO,'FROMTO]) - -getMsgKey msg == msg.2 - -getMsgKey? msg == IDENTP (val := getMsgKey msg) => val - -getMsgArgL msg == msg.3 - -getMsgPrefix? msg == - (pre := msg.4) = 'noPre => NIL - pre - -getMsgPrefix msg == msg.4 - - -getMsgLitSym msg == - getMsgKey? msg => '" " - '"*" - -getMsgText msg == msg.5 - -setMsgPrefix (msg,val) == msg.4 := val - -setMsgText (msg,val) == msg.5 := val - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/pf2atree.boot b/src/interp/pf2atree.boot new file mode 100644 index 00000000..4cfea2cd --- /dev/null +++ b/src/interp/pf2atree.boot @@ -0,0 +1,555 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +-- not hooked in yet + +-- BB parser tree to interpreter vectorized attributed trees. +-- Used to interface the BB parser +-- technology to the interpreter. The input is a parseTree and the +-- output is an interpreter attributed tree. + +SETANDFILEQ($useParserSrcPos, true) +SETANDFILEQ($transferParserSrcPos, true) + +pf2Sexpr pf == packageTran (pf2Sex1)(pf) + +pf2Atree pf == + (intUnsetQuiet)() + + $insideRule: local := false + $insideApplication: local := false + $insideSEQ: local := false + + -- we set the following because we will be using some things + -- within pf2sex.boot and they are in the spadcomp package. + + ($insideRule): local := false + ($insideApplication): local := false + ($insideSEQ): local := false + + pf2Atree1 pf + +pf2Atree1 pf == + -- some simple things that are really just S-expressions + + (pfNothing?)(pf) => + mkAtree1WithSrcPos(pf2Sexpr(pf), pf) + (pfSymbol?) pf => + mkAtree1WithSrcPos(pf2Sexpr(pf), pf) + (pfLiteral?)(pf) => + mkAtree1WithSrcPos(pf2Sexpr(pf), pf) + (pfId?) pf => + mkAtree1WithSrcPos(pf2Sexpr(pf), pf) + + -- Now some compound forms + + (pfApplication?)(pf) => + pfApplication2Atree pf + + (pfTuple?)(pf) => + [mkAtreeNodeWithSrcPos("Tuple",pf), + :[pf2Atree1 x for x in (pf0TupleParts)(pf)]] + + (pfIf?)(pf) => + condPf := (pfIfCond)(pf) + condPart := pf2Atree1 condPf + thenPart := pf2Atree1 (pfIfThen)(pf) + elsePart := pf2Atree1 (pfIfElse)(pf) + ifPart := mkAtreeNodeWithSrcPos("IF", pf) + thenPart = "noBranch" => + [ifPart, [mkAtreeNodeWithSrcPos("not", condPf), condPart], + elsePart, thenPart] + [ifPart, condPart, thenPart, elsePart] + + (pfTagged?)(pf) => + tag := (pfTaggedTag)(pf) + tagPart := + (pfTuple?) tag => + ["Tuple", :[pf2Sexpr(arg) for arg in (pf0TupleParts)(tag)]] + pf2Sexpr(tag) + [mkAtreeNodeWithSrcPos("Declare",pf), tagPart, + pf2Sexpr((pfTaggedExpr)(pf))] + + (pfCoerceto?)(pf) => + [mkAtreeNodeWithSrcPos("COERCE",pf), + pf2Atree1 (pfCoercetoExpr)(pf), + pf2Sexpr((pfCoercetoType)(pf))] + + (pfPretend?)(pf) => + [mkAtreeNodeWithSrcPos("pretend",pf), + pf2Atree1 (pfPretendExpr)(pf), + pf2Sexpr((pfPretendType)(pf))] + + (pfFromdom?)(pf) => + op := packageTran (opTran)(pf2Sexpr((pfFromdomWhat)(pf))) + if op = "braceFromCurly" then op := "SEQ" -- ?? + + op = 0 => + -- 0$Foo => Zero()$Foo + [mkAtreeNodeWithSrcPos("Dollar",pf), + pf2Sexpr((pfFromdomDomain)(pf)), + [mkAtreeNodeWithSrcPos("Zero",pf)]] + op = 1 => + -- 1$Foo => One()$Foo + [mkAtreeNodeWithSrcPos("Dollar",pf), + pf2Sexpr((pfFromdomDomain)(pf)), + [mkAtreeNodeWithSrcPos("One",pf)]] + INTEGERP op => + -- n$Foo => n * One()$Foo + [mkAtreeNodeWithSrcPos("*",pf), + mkAtree1WithSrcPos(op,pf), + [mkAtreeNodeWithSrcPos("Dollar",pf), + pf2Sexpr((pfFromdomDomain)(pf)), + [mkAtreeNodeWithSrcPos("One",pf)]]] + + [mkAtreeNodeWithSrcPos("Dollar",pf), + pf2Sexpr((pfFromdomDomain)(pf)), + mkAtreeNodeWithSrcPos(op,pf)] + + (pfSequence?)(pf) => + pfSequence2Atree pf + + (pfExit?)(pf) => + $insideSEQ => + [mkAtreeNodeWithSrcPos("exit",pf), + pf2Atree1 (pfExitCond)(pf), + pf2Atree1 (pfExitExpr)(pf)] + [mkAtreeNodeWithSrcPos("IF",pf), + pf2Atree1 (pfExitCond)(pf), + pf2Atree1 (pfExitExpr)(pf), "noBranch"] + + (pfLoop?)(pf) => + [mkAtreeNodeWithSrcPos("REPEAT",pf), + :loopIters2Atree (pf0LoopIterators)(pf)] + + (pfCollect?)(pf) => + pfCollect2Atree(pf) + + (pfForin?)(pf) => + ["IN", :[pf2Atree1 x for x in (pf0ForinLhs)(pf)], + pf2Atree1 (pfForinWhole)(pf)] + + (pfWhile?)(pf) => + ["WHILE", pf2Atree1((pfWhileCond)(pf))] + + (pfSuchthat?)(pf) => + $insideRule = 'left => + keyedSystemError('"S2GE0017", ['"pf2Atree1: pfSuchThat"]) + ["SUCHTHAT", pf2Atree1 (pfSuchthatCond)(pf)] + + (pfDo?)(pf) => + pf2Atree1 (pfDoBody)(pf) + +-- (pfTyped?)(pf) => +-- type := pfTypedType pf +-- pfNothing? type => pf2Atree1 pfTypedId pf +-- [":", pf2Atree1 pfTypedId pf, pf2Atree1 pfTypedType pf] + + (pfAssign?)(pf) => + -- declarations on the lhs are broken out into another + -- statement preceding the LET of the id(s) + lhsThings := (pf0AssignLhsItems)(pf) + if #lhsThings = 1 and (pfTuple?)(first lhsThings) then + lhsThings := (pf0TupleParts)(first lhsThings) + decls := nil + ids := nil + for x in lhsThings repeat + (pfTagged?)(x) => + decls := [x, :decls] + ids := [(pfTaggedTag)(x), :ids] + ids := [x, :ids] + idList := [pf2Atree1 x for x in reverse ids] + if #idList ^= 1 then idList := + [mkAtreeNodeWithSrcPos("Tuple",pf), :idList] + else idList := first idList + x := [mkAtreeNodeWithSrcPos("LET",pf), + idList, pf2Atree1 (pfAssignRhs)(pf)] + decls => + [mkAtreeNodeWithSrcPos("SEQ",pf), + :[pf2Atree1 decl for decl in nreverse decls], x] + x + +-- (pfDefinition?)(pf) => +-- pfDefinition2Atree pf + +-- (pfLambda?)(pf) => +-- pfLambda2Atree pf +-- (pfRestrict?)(pf) => +-- ["@", pf2Atree1 pfRestrictExpr pf, pf2Atree1 pfRestrictType pf] + + (pfFree?)(pf) => + [mkAtreeNodeWithSrcPos("free",pf), + :[pf2Atree1 item for item in (pf0FreeItems)(pf)]] + (pfLocal?)(pf) => + [mkAtreeNodeWithSrcPos("local",pf), + :[pf2Atree1 item for item in (pf0LocalItems)(pf)]] + + (pfWrong?)(pf) => + spadThrow() + + -- next 3 are probably be handled in pfApplication2Atree + + (pfAnd?)(pf) => + [mkAtreeNodeWithSrcPos("and",pf), + pf2Atree1 (pfAndLeft)(pf), + pf2Atree1 (pfAndRight)(pf)] + (pfOr?)(pf) => + [mkAtreeNodeWithSrcPos("or",pf), + pf2Atree1 (pfOrLeft)(pf), + pf2Atree1 (pfOrRight)(pf)] + (pfNot?)(pf) => + [mkAtreeNodeWithSrcPos("not",pf), + pf2Atree1 (pfNotArg)(pf)] + +-- (pfNovalue?)(pf) => +-- intSetQuiet() +-- ["SEQ", pf2Atree1 pfNovalueExpr pf] +-- (pfRule?)(pf) => +-- pfRule2Atree pf + + (pfBreak?)(pf) => + [mkAtreeNodeWithSrcPos("break",pf), (pfBreakFrom)(pf)] + + (pfMacro?)(pf) => + tree := mkAtree1WithSrcPos('(void), pf) + putValue(tree,objNewWrap(voidValue(),$Void)) + putModeSet(tree,[$Void]) + tree + + (pfReturn?)(pf) => + [mkAtreeNodeWithSrcPos("return",pf), + pf2Atree1 (pfReturnExpr)(pf)] + + (pfIterate?)(pf) => + [mkAtreeNodeWithSrcPos("iterate",pf)] + +-- (pfWhere?)(pf) => +-- args := [pf2Atree1 p for p in pf0WhereContext pf] +-- #args = 1 => +-- ["where", pf2Atree1 pfWhereExpr pf, :args] +-- ["where", pf2Atree1 pfWhereExpr pf, ["SEQ", :args]] + + mkAtree1WithSrcPos(pf2Sexpr(pf), pf) + +-- keyedSystemError('"S2GE0017", ['"pf2Atree1"]) +-- + +pfApplication2Atree pf == + $insideApplication: local := true + ($insideApplication): local := true + + opPf := (pfApplicationOp)(pf) + op := packageTran ((opTran)(pfOp2Sex)(opPf)) + op = "->" => + args := (pf0TupleParts)((pfApplicationArg)(pf)) + if (pfTuple?)(CAR args) then + typeList := [pf2Atree1 arg for arg in (pf0TupleParts)(CAR args)] + else + typeList := [pf2Atree1 CAR args] + args := [pf2Atree1 CADR args, :typeList] + [mkAtreeNodeWithSrcPos("Mapping", opPf), :args] + + (symEqual)(op, '":") and $insideRule = 'left => + [mkAtreeNodeWithSrcPos("multiple",opPf), + pf2Atree (pfApplicationArg)(pf)] + + (symEqual)(op, '"?") and $insideRule = 'left => + [mkAtreeNodeWithSrcPos("optional",opPf), + pf2Atree (pfApplicationArg)(pf)] + + args := (pfApplicationArg)(pf) + + (pfTuple?)(args) => +--! symEqual(op, '"|") and $insideRule = 'left => +--! pfSuchThat2Atree args + argAtree := [pf2Atree1 arg for arg in (pf0TupleParts)(args)] + + (symEqual)(op, '">") => + [mkAtreeNodeWithSrcPos("<",opPf), :reverse(argAtree)] + (symEqual)(op, '">=") => + [mkAtreeNodeWithSrcPos("not",opPf), + [mkAtreeNodeWithSrcPos("<",opPf), :argAtree]] + (symEqual)(op, '"<=") => + [mkAtreeNodeWithSrcPos("not",opPf), + [mkAtreeNodeWithSrcPos("<",opPf), :reverse(argAtree)]] + (symEqual)(op, '"AND") => + [mkAtreeNodeWithSrcPos("and",opPf), :argAtree] + (symEqual)(op, '"OR") => + [mkAtreeNodeWithSrcPos("or",opPf), :argAtree] + (symEqual) (op, '"Iterate") => + [mkAtreeNodeWithSrcPos("iterate",opPf)] + (symEqual)(op, '"by") => + [mkAtreeNodeWithSrcPos("BY",opPf), :argAtree] + (symEqual)(op, '"braceFromCurly") => + argAtree and getUnname first argAtree = "SEQ" => argAtree + [mkAtreeNodeWithSrcPos("SEQ",opPf), :argAtree] + op is [qt, realOp] and (symEqual)(qt, '"QUOTE") => + [mkAtreeNodeWithSrcPos("applyQuote",opPf), + mkAtreeNodeWithSrcPos(op,opPf), :argAtree] +--! val := (hasOptArgs?)(argSex) => [op, :val] + -- handle package call + (pfFromdom?)(opPf) => + opAtree := pf2Atree1 opPf + [CAR opAtree, CADR opAtree, [CADDR opAtree, :argAtree]] + -- regular call + [mkAtreeNodeWithSrcPos(op,opPf), :argAtree] + + op is [qt, realOp] and (symEqual)(qt, '"QUOTE") => + [mkAtreeNodeWithSrcPos("applyQuote",opPf), + mkAtreeNodeWithSrcPos(op,opPf), pf2Atree1 args] + (symEqual)(op, '"braceFromCurly") => + x := pf2Atree1 args + x and getUnname x = "SEQ" => x + [mkAtreeNodeWithSrcPos("SEQ",opPf), x] + (symEqual)(op, '"by") => + [mkAtreeNodeWithSrcPos("BY",opPf), pf2Atree1 args] + -- handle package call + (pfFromdom?)(opPf) => + opAtree := pf2Atree1 opPf + [CAR opAtree, CADR opAtree, [CADDR opAtree, pf2Atree1 args]] + -- regular call + [mkAtreeNodeWithSrcPos(op,opPf), pf2Atree1 args] + +-- pfDefinition2Atree pf == +-- --! $insideApplication => +-- --! ["OPTARG", pf2Atree1 CAR pf0DefinitionLhsItems pf, +-- --! pf2Atree1 pfDefinitionRhs pf] +-- idList := [pf2Atree1 x for x in (pf0DefinitionLhsItems)(pf)] +-- #idList ^= 1 => +-- systemError '"lhs of definition must be a single item in the interpreter" +-- id := first idList +-- rhs := (pfDefinitionRhs)(pf) +-- [argList, :body] := pfLambdaTran rhs +-- ["DEF", (argList = 'id => id; [id, :argList]), :body] + +-- pfLambdaTran pf == +-- pfLambda? pf => +-- argTypeList := nil +-- argList := nil +-- for arg in pf0LambdaArgs pf repeat +-- pfTyped? arg => +-- argList := [pfCollectArgTran pfTypedId arg, :argList] +-- pfNothing? pfTypedType arg => +-- argTypeList := [nil, :argTypeList] +-- argTypeList := [pf2Atree1 pfTypedType arg, :argTypeList] +-- systemError '"definition args should be typed" +-- argList := nreverse argList +-- retType := +-- pfNothing? pfLambdaRets pf => nil +-- pf2Atree1 pfLambdaRets pf +-- argTypeList := [retType, :nreverse argTypeList] +-- [argList, :[argTypeList, [nil for arg in argTypeList], +-- pf2Atree1 pfLambdaBody pf]] +-- ['id, :['(()), '(()), pf2Atree1 pf]] +-- +-- pfLambda2Atree pf == +-- [argList, :body] := pfLambdaTran pf +-- ["ADEF", argList, :body] +-- +-- pfCollectArgTran pf == +-- pfCollect? pf => +-- conds := [pf2Atree1 x for x in pfParts pfCollectIterators pf] +-- id := pf2Atree1 pfCollectBody pf +-- conds is [["|", cond]] => +-- ["|", id, cond] +-- [id, :conds] +-- pf2Atree1 pf +-- + +pfSequence2Atree pf == + $insideSEQ: local := true + ($insideSEQ): local := true + + seq := pfSequence2Atree0([pf2Atree1 x for x in (pf0SequenceArgs)(pf)], pf) + seqSex := (pfSequence2Sex0)([pf2Sexpr(x) for x in (pf0SequenceArgs)(pf)]) + seqSex is ["SEQ", :ruleList] and ruleList is [["rule", :.], :.] => + [mkAtreeNodeWithSrcPos("ruleset",pf), + [mkAtreeNodeWithSrcPos("construct",pf), :rest seq]] + seq + +pfSequence2Atree0(seqList, pf) == + null seqList => "noBranch" + seqTranList := [] + while seqList ^= nil repeat + item := first seqList + item is [exitVal, cond, value] and getUnname(exitVal) = "exit" => + item := [mkAtreeNodeWithSrcPos("IF",pf), cond, value, + pfSequence2Atree0(rest seqList, pf)] + seqTranList := [item, :seqTranList] + seqList := nil + seqTranList := [item ,:seqTranList] + seqList := rest seqList + #seqTranList = 1 => first seqTranList + [mkAtreeNodeWithSrcPos("SEQ",pf), :nreverse seqTranList] + +-- +-- float2Atree num == +-- eIndex := SEARCH('"e", num) +-- mantPart := +-- eIndex => SUBSEQ(num, 0, eIndex) +-- num +-- expPart := (eIndex => READ_-FROM_-STRING SUBSEQ(num, eIndex+1); 0) +-- dotIndex := SEARCH('".", mantPart) +-- intPart := +-- dotIndex => READ_-FROM_-STRING SUBSEQ(mantPart, 0, dotIndex) +-- READ_-FROM_-STRING mantPart +-- fracPartString := +-- dotIndex => SUBSEQ(mantPart, dotIndex+1) +-- '"0" +-- bfForm := MAKE_-FLOAT(intPart, READ_-FROM_-STRING fracPartString, +-- LENGTH fracPartString, expPart) +-- [., frac, :exp] := bfForm +-- [["$elt", intNewFloat(), 'float], frac, exp, 10] +-- + +loopIters2Atree iterList == + -- could probably do a better job of getting accurate SrcPos info onto parts + result := nil + for iter in iterList repeat + -- ON and UNTIL forms are no longer supported + sex := pf2Sexpr(iter) + sex is ['IN, var, ['SEGMENT, i, ["BY", incr]]] => + newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), + mkAtree1WithSrcPos(incr, iter)] + result := [newIter, :result] + sex is ['IN, var, ["BY", ['SEGMENT, i, j], incr]] => + newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), + mkAtree1WithSrcPos(incr, iter), mkAtree1WithSrcPos(j,iter)] + result := [newIter, :result] + sex is ['IN, var, ['SEGMENT, i, j]] => + newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), + mkAtree1WithSrcPos(1,iter), mkAtree1WithSrcPos(j,iter)] + result := [newIter, :result] + sex is ['IN, var, s] => + newIter := ["IN", var, mkAtree1 s] + result := [newIter, :result] + result := [pf2Atree1(iter), :result] + nreverse result + +pfCollect2Atree pf == + atree := [mkAtree1WithSrcPos("COLLECT",pf), + :loopIters2Atree (pfParts)((pfCollectIterators)(pf)), + pf2Atree1 (pfCollectBody)(pf)] + + -- next are for what appears to a parser screw-up + sex := ["COLLECT", + :(loopIters2Sex)((pfParts)((pfCollectIterators)(pf))), + pf2Sexpr (pfCollectBody)(pf)] + sex is ["COLLECT", ["|", cond], var] and SYMBOLP var => + [., [., condAtree], varAtree] := atree + ["SUCHTHAT", varAtree, condAtree] + + atree + +-- +-- pfRule2Atree pf == +-- $quotedOpList:local := nil +-- $predicateList:local := nil +-- $multiVarPredicateList:local := nil +-- lhs := pfLhsRule2Atree pfRuleLhsItems pf +-- rhs := pfRhsRule2Atree pfRuleRhs pf +-- lhs := ruleLhsTran lhs +-- rulePredicateTran +-- $quotedOpList => ["rule", lhs, rhs, ["construct", :$quotedOpList]] +-- ["rule", lhs, rhs] +-- +-- +-- ruleLhsTran ruleLhs == +-- for pred in $predicateList repeat +-- [name, predLhs, :predRhs] := pred +-- vars := patternVarsOf predRhs +-- CDR vars => -- if there is more than one patternVariable +-- ruleLhs := NSUBST(predLhs, name, ruleLhs) +-- $multiVarPredicateList := [pred, :$multiVarPredicateList] +-- predicate := +-- [., var] := predLhs +-- ["suchThat", predLhs, ["ADEF", [var], +-- '((Boolean) (Expression (Integer))), '(() ()), predRhs]] +-- ruleLhs := NSUBST(predicate, name, ruleLhs) +-- ruleLhs +-- +-- rulePredicateTran rule == +-- null $multiVarPredicateList => rule +-- varList := patternVarsOf [rhs for [.,.,:rhs] in $multiVarPredicateList] +-- predBody := +-- CDR $multiVarPredicateList => +-- ['AND, :[:pvarPredTran(rhs, varList) for [.,.,:rhs] in +-- $multiVarPredicateList]] +-- [[.,.,:rhs],:.] := $multiVarPredicateList +-- pvarPredTran(rhs, varList) +-- ['suchThat, rule, +-- ['construct, :[["QUOTE", var] for var in varList]], +-- ['ADEF, '(predicateVariable), +-- '((Boolean) (List (Expression (Integer)))), '(() ()), +-- predBody]] +-- +-- pvarPredTran(rhs, varList) == +-- for var in varList for i in 1.. repeat +-- rhs := NSUBST(['elt, 'predicateVariable, i], var, rhs) +-- rhs +-- +-- patternVarsOf expr == +-- patternVarsOf1(expr, nil) +-- +-- patternVarsOf1(expr, varList) == +-- NULL expr => varList +-- ATOM expr => +-- null SYMBOLP expr => varList +-- SymMemQ(expr, varList) => varList +-- [expr, :varList] +-- expr is [op, :argl] => +-- for arg in argl repeat +-- varList := patternVarsOf1(arg, varList) +-- varList +-- varList +-- +-- pfLhsRule2Atree lhs == +-- $insideRule: local := 'left +-- ($insideRule): local := 'left +-- pf2Atree1 lhs +-- +-- +-- pfRhsRule2Atree rhs == +-- $insideRule: local := 'right +-- ($insideRule): local := 'right +-- pf2Atree1 rhs +-- + +-- pfSuchThat2Atree args == +-- name := GENTEMP() +-- argList := pf0TupleParts args +-- lhsSex := pf2Atree1 CAR argList +-- rhsSex := pf2Atree CADR argList +-- $predicateList := [[name, lhsSex, :rhsSex], :$predicateList] +-- name diff --git a/src/interp/pf2atree.boot.pamphlet b/src/interp/pf2atree.boot.pamphlet deleted file mode 100644 index 29e85ad1..00000000 --- a/src/interp/pf2atree.boot.pamphlet +++ /dev/null @@ -1,575 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp pf2atree.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - --- not hooked in yet - --- BB parser tree to interpreter vectorized attributed trees. --- Used to interface the BB parser --- technology to the interpreter. The input is a parseTree and the --- output is an interpreter attributed tree. - -SETANDFILEQ($useParserSrcPos, true) -SETANDFILEQ($transferParserSrcPos, true) - -pf2Sexpr pf == packageTran (pf2Sex1)(pf) - -pf2Atree pf == - (intUnsetQuiet)() - - $insideRule: local := false - $insideApplication: local := false - $insideSEQ: local := false - - -- we set the following because we will be using some things - -- within pf2sex.boot and they are in the spadcomp package. - - ($insideRule): local := false - ($insideApplication): local := false - ($insideSEQ): local := false - - pf2Atree1 pf - -pf2Atree1 pf == - -- some simple things that are really just S-expressions - - (pfNothing?)(pf) => - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - (pfSymbol?) pf => - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - (pfLiteral?)(pf) => - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - (pfId?) pf => - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - - -- Now some compound forms - - (pfApplication?)(pf) => - pfApplication2Atree pf - - (pfTuple?)(pf) => - [mkAtreeNodeWithSrcPos("Tuple",pf), - :[pf2Atree1 x for x in (pf0TupleParts)(pf)]] - - (pfIf?)(pf) => - condPf := (pfIfCond)(pf) - condPart := pf2Atree1 condPf - thenPart := pf2Atree1 (pfIfThen)(pf) - elsePart := pf2Atree1 (pfIfElse)(pf) - ifPart := mkAtreeNodeWithSrcPos("IF", pf) - thenPart = "noBranch" => - [ifPart, [mkAtreeNodeWithSrcPos("not", condPf), condPart], - elsePart, thenPart] - [ifPart, condPart, thenPart, elsePart] - - (pfTagged?)(pf) => - tag := (pfTaggedTag)(pf) - tagPart := - (pfTuple?) tag => - ["Tuple", :[pf2Sexpr(arg) for arg in (pf0TupleParts)(tag)]] - pf2Sexpr(tag) - [mkAtreeNodeWithSrcPos("Declare",pf), tagPart, - pf2Sexpr((pfTaggedExpr)(pf))] - - (pfCoerceto?)(pf) => - [mkAtreeNodeWithSrcPos("COERCE",pf), - pf2Atree1 (pfCoercetoExpr)(pf), - pf2Sexpr((pfCoercetoType)(pf))] - - (pfPretend?)(pf) => - [mkAtreeNodeWithSrcPos("pretend",pf), - pf2Atree1 (pfPretendExpr)(pf), - pf2Sexpr((pfPretendType)(pf))] - - (pfFromdom?)(pf) => - op := packageTran (opTran)(pf2Sexpr((pfFromdomWhat)(pf))) - if op = "braceFromCurly" then op := "SEQ" -- ?? - - op = 0 => - -- 0$Foo => Zero()$Foo - [mkAtreeNodeWithSrcPos("Dollar",pf), - pf2Sexpr((pfFromdomDomain)(pf)), - [mkAtreeNodeWithSrcPos("Zero",pf)]] - op = 1 => - -- 1$Foo => One()$Foo - [mkAtreeNodeWithSrcPos("Dollar",pf), - pf2Sexpr((pfFromdomDomain)(pf)), - [mkAtreeNodeWithSrcPos("One",pf)]] - INTEGERP op => - -- n$Foo => n * One()$Foo - [mkAtreeNodeWithSrcPos("*",pf), - mkAtree1WithSrcPos(op,pf), - [mkAtreeNodeWithSrcPos("Dollar",pf), - pf2Sexpr((pfFromdomDomain)(pf)), - [mkAtreeNodeWithSrcPos("One",pf)]]] - - [mkAtreeNodeWithSrcPos("Dollar",pf), - pf2Sexpr((pfFromdomDomain)(pf)), - mkAtreeNodeWithSrcPos(op,pf)] - - (pfSequence?)(pf) => - pfSequence2Atree pf - - (pfExit?)(pf) => - $insideSEQ => - [mkAtreeNodeWithSrcPos("exit",pf), - pf2Atree1 (pfExitCond)(pf), - pf2Atree1 (pfExitExpr)(pf)] - [mkAtreeNodeWithSrcPos("IF",pf), - pf2Atree1 (pfExitCond)(pf), - pf2Atree1 (pfExitExpr)(pf), "noBranch"] - - (pfLoop?)(pf) => - [mkAtreeNodeWithSrcPos("REPEAT",pf), - :loopIters2Atree (pf0LoopIterators)(pf)] - - (pfCollect?)(pf) => - pfCollect2Atree(pf) - - (pfForin?)(pf) => - ["IN", :[pf2Atree1 x for x in (pf0ForinLhs)(pf)], - pf2Atree1 (pfForinWhole)(pf)] - - (pfWhile?)(pf) => - ["WHILE", pf2Atree1((pfWhileCond)(pf))] - - (pfSuchthat?)(pf) => - $insideRule = 'left => - keyedSystemError('"S2GE0017", ['"pf2Atree1: pfSuchThat"]) - ["SUCHTHAT", pf2Atree1 (pfSuchthatCond)(pf)] - - (pfDo?)(pf) => - pf2Atree1 (pfDoBody)(pf) - --- (pfTyped?)(pf) => --- type := pfTypedType pf --- pfNothing? type => pf2Atree1 pfTypedId pf --- [":", pf2Atree1 pfTypedId pf, pf2Atree1 pfTypedType pf] - - (pfAssign?)(pf) => - -- declarations on the lhs are broken out into another - -- statement preceding the LET of the id(s) - lhsThings := (pf0AssignLhsItems)(pf) - if #lhsThings = 1 and (pfTuple?)(first lhsThings) then - lhsThings := (pf0TupleParts)(first lhsThings) - decls := nil - ids := nil - for x in lhsThings repeat - (pfTagged?)(x) => - decls := [x, :decls] - ids := [(pfTaggedTag)(x), :ids] - ids := [x, :ids] - idList := [pf2Atree1 x for x in reverse ids] - if #idList ^= 1 then idList := - [mkAtreeNodeWithSrcPos("Tuple",pf), :idList] - else idList := first idList - x := [mkAtreeNodeWithSrcPos("LET",pf), - idList, pf2Atree1 (pfAssignRhs)(pf)] - decls => - [mkAtreeNodeWithSrcPos("SEQ",pf), - :[pf2Atree1 decl for decl in nreverse decls], x] - x - --- (pfDefinition?)(pf) => --- pfDefinition2Atree pf - --- (pfLambda?)(pf) => --- pfLambda2Atree pf --- (pfRestrict?)(pf) => --- ["@", pf2Atree1 pfRestrictExpr pf, pf2Atree1 pfRestrictType pf] - - (pfFree?)(pf) => - [mkAtreeNodeWithSrcPos("free",pf), - :[pf2Atree1 item for item in (pf0FreeItems)(pf)]] - (pfLocal?)(pf) => - [mkAtreeNodeWithSrcPos("local",pf), - :[pf2Atree1 item for item in (pf0LocalItems)(pf)]] - - (pfWrong?)(pf) => - spadThrow() - - -- next 3 are probably be handled in pfApplication2Atree - - (pfAnd?)(pf) => - [mkAtreeNodeWithSrcPos("and",pf), - pf2Atree1 (pfAndLeft)(pf), - pf2Atree1 (pfAndRight)(pf)] - (pfOr?)(pf) => - [mkAtreeNodeWithSrcPos("or",pf), - pf2Atree1 (pfOrLeft)(pf), - pf2Atree1 (pfOrRight)(pf)] - (pfNot?)(pf) => - [mkAtreeNodeWithSrcPos("not",pf), - pf2Atree1 (pfNotArg)(pf)] - --- (pfNovalue?)(pf) => --- intSetQuiet() --- ["SEQ", pf2Atree1 pfNovalueExpr pf] --- (pfRule?)(pf) => --- pfRule2Atree pf - - (pfBreak?)(pf) => - [mkAtreeNodeWithSrcPos("break",pf), (pfBreakFrom)(pf)] - - (pfMacro?)(pf) => - tree := mkAtree1WithSrcPos('(void), pf) - putValue(tree,objNewWrap(voidValue(),$Void)) - putModeSet(tree,[$Void]) - tree - - (pfReturn?)(pf) => - [mkAtreeNodeWithSrcPos("return",pf), - pf2Atree1 (pfReturnExpr)(pf)] - - (pfIterate?)(pf) => - [mkAtreeNodeWithSrcPos("iterate",pf)] - --- (pfWhere?)(pf) => --- args := [pf2Atree1 p for p in pf0WhereContext pf] --- #args = 1 => --- ["where", pf2Atree1 pfWhereExpr pf, :args] --- ["where", pf2Atree1 pfWhereExpr pf, ["SEQ", :args]] - - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - --- keyedSystemError('"S2GE0017", ['"pf2Atree1"]) --- - -pfApplication2Atree pf == - $insideApplication: local := true - ($insideApplication): local := true - - opPf := (pfApplicationOp)(pf) - op := packageTran ((opTran)(pfOp2Sex)(opPf)) - op = "->" => - args := (pf0TupleParts)((pfApplicationArg)(pf)) - if (pfTuple?)(CAR args) then - typeList := [pf2Atree1 arg for arg in (pf0TupleParts)(CAR args)] - else - typeList := [pf2Atree1 CAR args] - args := [pf2Atree1 CADR args, :typeList] - [mkAtreeNodeWithSrcPos("Mapping", opPf), :args] - - (symEqual)(op, '":") and $insideRule = 'left => - [mkAtreeNodeWithSrcPos("multiple",opPf), - pf2Atree (pfApplicationArg)(pf)] - - (symEqual)(op, '"?") and $insideRule = 'left => - [mkAtreeNodeWithSrcPos("optional",opPf), - pf2Atree (pfApplicationArg)(pf)] - - args := (pfApplicationArg)(pf) - - (pfTuple?)(args) => ---! symEqual(op, '"|") and $insideRule = 'left => ---! pfSuchThat2Atree args - argAtree := [pf2Atree1 arg for arg in (pf0TupleParts)(args)] - - (symEqual)(op, '">") => - [mkAtreeNodeWithSrcPos("<",opPf), :reverse(argAtree)] - (symEqual)(op, '">=") => - [mkAtreeNodeWithSrcPos("not",opPf), - [mkAtreeNodeWithSrcPos("<",opPf), :argAtree]] - (symEqual)(op, '"<=") => - [mkAtreeNodeWithSrcPos("not",opPf), - [mkAtreeNodeWithSrcPos("<",opPf), :reverse(argAtree)]] - (symEqual)(op, '"AND") => - [mkAtreeNodeWithSrcPos("and",opPf), :argAtree] - (symEqual)(op, '"OR") => - [mkAtreeNodeWithSrcPos("or",opPf), :argAtree] - (symEqual) (op, '"Iterate") => - [mkAtreeNodeWithSrcPos("iterate",opPf)] - (symEqual)(op, '"by") => - [mkAtreeNodeWithSrcPos("BY",opPf), :argAtree] - (symEqual)(op, '"braceFromCurly") => - argAtree and getUnname first argAtree = "SEQ" => argAtree - [mkAtreeNodeWithSrcPos("SEQ",opPf), :argAtree] - op is [qt, realOp] and (symEqual)(qt, '"QUOTE") => - [mkAtreeNodeWithSrcPos("applyQuote",opPf), - mkAtreeNodeWithSrcPos(op,opPf), :argAtree] ---! val := (hasOptArgs?)(argSex) => [op, :val] - -- handle package call - (pfFromdom?)(opPf) => - opAtree := pf2Atree1 opPf - [CAR opAtree, CADR opAtree, [CADDR opAtree, :argAtree]] - -- regular call - [mkAtreeNodeWithSrcPos(op,opPf), :argAtree] - - op is [qt, realOp] and (symEqual)(qt, '"QUOTE") => - [mkAtreeNodeWithSrcPos("applyQuote",opPf), - mkAtreeNodeWithSrcPos(op,opPf), pf2Atree1 args] - (symEqual)(op, '"braceFromCurly") => - x := pf2Atree1 args - x and getUnname x = "SEQ" => x - [mkAtreeNodeWithSrcPos("SEQ",opPf), x] - (symEqual)(op, '"by") => - [mkAtreeNodeWithSrcPos("BY",opPf), pf2Atree1 args] - -- handle package call - (pfFromdom?)(opPf) => - opAtree := pf2Atree1 opPf - [CAR opAtree, CADR opAtree, [CADDR opAtree, pf2Atree1 args]] - -- regular call - [mkAtreeNodeWithSrcPos(op,opPf), pf2Atree1 args] - --- pfDefinition2Atree pf == --- --! $insideApplication => --- --! ["OPTARG", pf2Atree1 CAR pf0DefinitionLhsItems pf, --- --! pf2Atree1 pfDefinitionRhs pf] --- idList := [pf2Atree1 x for x in (pf0DefinitionLhsItems)(pf)] --- #idList ^= 1 => --- systemError '"lhs of definition must be a single item in the interpreter" --- id := first idList --- rhs := (pfDefinitionRhs)(pf) --- [argList, :body] := pfLambdaTran rhs --- ["DEF", (argList = 'id => id; [id, :argList]), :body] - --- pfLambdaTran pf == --- pfLambda? pf => --- argTypeList := nil --- argList := nil --- for arg in pf0LambdaArgs pf repeat --- pfTyped? arg => --- argList := [pfCollectArgTran pfTypedId arg, :argList] --- pfNothing? pfTypedType arg => --- argTypeList := [nil, :argTypeList] --- argTypeList := [pf2Atree1 pfTypedType arg, :argTypeList] --- systemError '"definition args should be typed" --- argList := nreverse argList --- retType := --- pfNothing? pfLambdaRets pf => nil --- pf2Atree1 pfLambdaRets pf --- argTypeList := [retType, :nreverse argTypeList] --- [argList, :[argTypeList, [nil for arg in argTypeList], --- pf2Atree1 pfLambdaBody pf]] --- ['id, :['(()), '(()), pf2Atree1 pf]] --- --- pfLambda2Atree pf == --- [argList, :body] := pfLambdaTran pf --- ["ADEF", argList, :body] --- --- pfCollectArgTran pf == --- pfCollect? pf => --- conds := [pf2Atree1 x for x in pfParts pfCollectIterators pf] --- id := pf2Atree1 pfCollectBody pf --- conds is [["|", cond]] => --- ["|", id, cond] --- [id, :conds] --- pf2Atree1 pf --- - -pfSequence2Atree pf == - $insideSEQ: local := true - ($insideSEQ): local := true - - seq := pfSequence2Atree0([pf2Atree1 x for x in (pf0SequenceArgs)(pf)], pf) - seqSex := (pfSequence2Sex0)([pf2Sexpr(x) for x in (pf0SequenceArgs)(pf)]) - seqSex is ["SEQ", :ruleList] and ruleList is [["rule", :.], :.] => - [mkAtreeNodeWithSrcPos("ruleset",pf), - [mkAtreeNodeWithSrcPos("construct",pf), :rest seq]] - seq - -pfSequence2Atree0(seqList, pf) == - null seqList => "noBranch" - seqTranList := [] - while seqList ^= nil repeat - item := first seqList - item is [exitVal, cond, value] and getUnname(exitVal) = "exit" => - item := [mkAtreeNodeWithSrcPos("IF",pf), cond, value, - pfSequence2Atree0(rest seqList, pf)] - seqTranList := [item, :seqTranList] - seqList := nil - seqTranList := [item ,:seqTranList] - seqList := rest seqList - #seqTranList = 1 => first seqTranList - [mkAtreeNodeWithSrcPos("SEQ",pf), :nreverse seqTranList] - --- --- float2Atree num == --- eIndex := SEARCH('"e", num) --- mantPart := --- eIndex => SUBSEQ(num, 0, eIndex) --- num --- expPart := (eIndex => READ_-FROM_-STRING SUBSEQ(num, eIndex+1); 0) --- dotIndex := SEARCH('".", mantPart) --- intPart := --- dotIndex => READ_-FROM_-STRING SUBSEQ(mantPart, 0, dotIndex) --- READ_-FROM_-STRING mantPart --- fracPartString := --- dotIndex => SUBSEQ(mantPart, dotIndex+1) --- '"0" --- bfForm := MAKE_-FLOAT(intPart, READ_-FROM_-STRING fracPartString, --- LENGTH fracPartString, expPart) --- [., frac, :exp] := bfForm --- [["$elt", intNewFloat(), 'float], frac, exp, 10] --- - -loopIters2Atree iterList == - -- could probably do a better job of getting accurate SrcPos info onto parts - result := nil - for iter in iterList repeat - -- ON and UNTIL forms are no longer supported - sex := pf2Sexpr(iter) - sex is ['IN, var, ['SEGMENT, i, ["BY", incr]]] => - newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), - mkAtree1WithSrcPos(incr, iter)] - result := [newIter, :result] - sex is ['IN, var, ["BY", ['SEGMENT, i, j], incr]] => - newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), - mkAtree1WithSrcPos(incr, iter), mkAtree1WithSrcPos(j,iter)] - result := [newIter, :result] - sex is ['IN, var, ['SEGMENT, i, j]] => - newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), - mkAtree1WithSrcPos(1,iter), mkAtree1WithSrcPos(j,iter)] - result := [newIter, :result] - sex is ['IN, var, s] => - newIter := ["IN", var, mkAtree1 s] - result := [newIter, :result] - result := [pf2Atree1(iter), :result] - nreverse result - -pfCollect2Atree pf == - atree := [mkAtree1WithSrcPos("COLLECT",pf), - :loopIters2Atree (pfParts)((pfCollectIterators)(pf)), - pf2Atree1 (pfCollectBody)(pf)] - - -- next are for what appears to a parser screw-up - sex := ["COLLECT", - :(loopIters2Sex)((pfParts)((pfCollectIterators)(pf))), - pf2Sexpr (pfCollectBody)(pf)] - sex is ["COLLECT", ["|", cond], var] and SYMBOLP var => - [., [., condAtree], varAtree] := atree - ["SUCHTHAT", varAtree, condAtree] - - atree - --- --- pfRule2Atree pf == --- $quotedOpList:local := nil --- $predicateList:local := nil --- $multiVarPredicateList:local := nil --- lhs := pfLhsRule2Atree pfRuleLhsItems pf --- rhs := pfRhsRule2Atree pfRuleRhs pf --- lhs := ruleLhsTran lhs --- rulePredicateTran --- $quotedOpList => ["rule", lhs, rhs, ["construct", :$quotedOpList]] --- ["rule", lhs, rhs] --- --- --- ruleLhsTran ruleLhs == --- for pred in $predicateList repeat --- [name, predLhs, :predRhs] := pred --- vars := patternVarsOf predRhs --- CDR vars => -- if there is more than one patternVariable --- ruleLhs := NSUBST(predLhs, name, ruleLhs) --- $multiVarPredicateList := [pred, :$multiVarPredicateList] --- predicate := --- [., var] := predLhs --- ["suchThat", predLhs, ["ADEF", [var], --- '((Boolean) (Expression (Integer))), '(() ()), predRhs]] --- ruleLhs := NSUBST(predicate, name, ruleLhs) --- ruleLhs --- --- rulePredicateTran rule == --- null $multiVarPredicateList => rule --- varList := patternVarsOf [rhs for [.,.,:rhs] in $multiVarPredicateList] --- predBody := --- CDR $multiVarPredicateList => --- ['AND, :[:pvarPredTran(rhs, varList) for [.,.,:rhs] in --- $multiVarPredicateList]] --- [[.,.,:rhs],:.] := $multiVarPredicateList --- pvarPredTran(rhs, varList) --- ['suchThat, rule, --- ['construct, :[["QUOTE", var] for var in varList]], --- ['ADEF, '(predicateVariable), --- '((Boolean) (List (Expression (Integer)))), '(() ()), --- predBody]] --- --- pvarPredTran(rhs, varList) == --- for var in varList for i in 1.. repeat --- rhs := NSUBST(['elt, 'predicateVariable, i], var, rhs) --- rhs --- --- patternVarsOf expr == --- patternVarsOf1(expr, nil) --- --- patternVarsOf1(expr, varList) == --- NULL expr => varList --- ATOM expr => --- null SYMBOLP expr => varList --- SymMemQ(expr, varList) => varList --- [expr, :varList] --- expr is [op, :argl] => --- for arg in argl repeat --- varList := patternVarsOf1(arg, varList) --- varList --- varList --- --- pfLhsRule2Atree lhs == --- $insideRule: local := 'left --- ($insideRule): local := 'left --- pf2Atree1 lhs --- --- --- pfRhsRule2Atree rhs == --- $insideRule: local := 'right --- ($insideRule): local := 'right --- pf2Atree1 rhs --- - --- pfSuchThat2Atree args == --- name := GENTEMP() --- argList := pf0TupleParts args --- lhsSex := pf2Atree1 CAR argList --- rhsSex := pf2Atree CADR argList --- $predicateList := [[name, lhsSex, :rhsSex], :$predicateList] --- name -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/postpar.boot b/src/interp/postpar.boot new file mode 100644 index 00000000..58568d22 --- /dev/null +++ b/src/interp/postpar.boot @@ -0,0 +1,531 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +import '"postprop" +)package "BOOT" + +$postStack := [] + +--% Yet Another Parser Transformation File +--These functions are used by for BOOT and SPAD code +--(see new2OldLisp, e.g.) + +postTransform y == + x:= y + u:= postTran x + if u is ["Tuple",:l,[":",y,t]] and (and/[IDENTP x for x in l]) then u:= + [":",["LISTOF",:l,y],t] + postTransformCheck u + aplTran u + +displayPreCompilationErrors() == + n:= #($postStack:= REMDUP NREVERSE $postStack) + n=0 => nil + errors:= + 1 '"errors" + '"error" + if $InteractiveMode + then sayBrightly ['" Semantic ",errors,'" detected: "] + else + heading:= + $topOp ^= '$topOp => ['" ",$topOp,'" has"] + ['" You have"] + sayBrightly [:heading,'%b,n,'%d,'"precompilation ",errors,'":"] + if 1 + postAtom x + op := first x + SYMBOLP op and (f:= GETL(op,'postTran)) => FUNCALL(f,x) + op is ["elt",a,b] => + u:= postTran [b,:rest x] + [postTran op,:rest u] + op is ["Scripts",:.] => + postScriptsForm(op,"append"/[unTuple postTran y for y in rest x]) + op^=(y:= postOp op) => [y,:postTranList rest x] + postForm x + +postTranList x == [postTran y for y in x] + +postBigFloat x == + [.,mant,:expon] := x + $BOOT => INT2RNUM(mant) * INT2RNUM(10) ** expon + eltword := if $InteractiveMode then "$elt" else "elt" + postTran [[eltword,'(Float),"float"],[",",[",",mant,expon],10]] + +postAdd ["add",a,:b] == + null b => postCapsule a + ["add",postTran a,postCapsule first b] + +checkWarning msg == postError concat('"Parsing error: ",msg) + +checkWarningIndentation() == + checkWarning ['"Apparent indentation error following",:bright "add"] + +postCapsule x == + x isnt [op,:.] => checkWarningIndentation() + INTEGERP op or op = "==" => ["CAPSULE",postBlockItem x] + op = ";" => ["CAPSULE",:postBlockItemList postFlatten(x,";")] + op = "if" => ["CAPSULE",postBlockItem x] + checkWarningIndentation() + +postQUOTE x == x + +postColon u == + u is [":",x] => [":",postTran x] + u is [":",x,y] => [":",postTran x,:postType y] + +postColonColon u == + -- for Lisp package calling + -- boot syntax is package::fun but probably need to parenthesize it + $BOOT and u is ["::",package,fun] => + INTERN(STRINGIMAGE fun, package) + postForm u + +postAtSign ["@",x,y] == ["@",postTran x,:postType y] + +postPretend ["pretend",x,y] == ["pretend",postTran x,:postType y] + +postConstruct u == + u is ["construct",b] => + a:= (b is [",",:.] => comma2Tuple b; b) + a is ["SEGMENT",p,q] => ["construct",postTranSegment(p,q)] + a is ["Tuple",:l] => + or/[x is [":",y] for x in l] => postMakeCons l + or/[x is ["SEGMENT",:.] for x in l] => tuple2List l + ["construct",:postTranList l] + ["construct",postTran a] + u + +postError msg == + BUMPERRORCOUNT 'precompilation + xmsg:= + $defOp ^= '$defOp and not $InteractiveMode => [$defOp,'": ",:msg] + msg + $postStack:= [xmsg,:$postStack] + nil + +postMakeCons l == + null l => "nil" + l is [[":",a],:l'] => + l' => ["append",postTran a,postMakeCons l'] + postTran a + ["cons",postTran first l,postMakeCons rest l] + +postAtom x == + $BOOT => x + x=0 => '(Zero) + x=1 => '(One) + EQ(x,'T) => 'T_$ -- rename T in spad code to T$ + IDENTP x and GETDATABASE(x,'NILADIC) => LIST x + x + +postBlock ["Block",:l,x] == + ["SEQ",:postBlockItemList l,["exit",postTran x]] + +postBlockItemList l == [postBlockItem x for x in l] + +postBlockItem x == + x:= postTran x + x is ["Tuple",:l,[":",y,t]] and (and/[IDENTP x for x in l]) => + [":",["LISTOF",:l,y],t] + x + +postCategory (u is ["CATEGORY",:l]) == + --RDJ: ugh_ please -- someone take away need for PROGN as soon as possible + null l => u + op := + $insidePostCategoryIfTrue = true => "PROGN" + "CATEGORY" + [op,:[fn x for x in l]] where fn x == + $insidePostCategoryIfTrue: local := true + postTran x + +postComma u == postTuple comma2Tuple u + +comma2Tuple u == ["Tuple",:postFlatten(u,",")] + +postDef [defOp,lhs,rhs] == +--+ + lhs is ["macro",name] => postMDef ["==>",name,rhs] + + if not($BOOT) then recordHeaderDocumentation nil + if $maxSignatureLineNumber ^= 0 then + $docList := [["constructor",:$headerDocumentation],:$docList] + $maxSignatureLineNumber := 0 + --reset this for next constructor; see recordDocumentation + lhs:= postTran lhs + [form,targetType]:= + lhs is [":",:.] => rest lhs + [lhs,nil] + if null $InteractiveMode and atom form then form := LIST form + newLhs:= + atom form => form + [op,:argl]:= [(x is [":",a,.] => a; x) for x in form] + [op,:postDefArgs argl] + argTypeList:= + atom form => nil + [(x is [":",.,t] => t; nil) for x in rest form] + typeList:= [targetType,:argTypeList] + if atom form then form := [form] + specialCaseForm := [nil for x in form] + ["DEF",newLhs,typeList,specialCaseForm,postTran rhs] + +postDefArgs argl == + null argl => argl + argl is [[":",a],:b] => + b => postError + ['" Argument",:bright a,'"of indefinite length must be last"] + atom a or a is ["QUOTE",:.] => a + postError + ['" Argument",:bright a,'"of indefinite length must be a name"] + [first argl,:postDefArgs rest argl] + +postMDef(t) == + [.,lhs,rhs] := t + $InteractiveMode and not $BOOT => + lhs := postTran lhs + null IDENTP lhs => throwKeyedMsg("S2IP0001",NIL) + ["MDEF",lhs,NIL,NIL,postTran rhs] + lhs:= postTran lhs + [form,targetType]:= + lhs is [":",:.] => rest lhs + [lhs,nil] + form:= + atom form => LIST form + form + newLhs:= [(x is [":",a,:.] => a; x) for x in form] + typeList:= [targetType,:[(x is [":",.,t] => t; nil) for x in rest form]] + ["MDEF",newLhs,typeList,[nil for x in form],postTran rhs] + +postElt (u is [.,a,b]) == + a:= postTran a + b is ["Sequence",:.] => [["elt",a,"makeRecord"],:postTranList rest b] + ["elt",a,postTran b] + +postExit ["=>",a,b] == ["IF",postTran a,["exit",postTran b],"noBranch"] + + +postFlatten(x,op) == + x is [ =op,a,b] => [:postFlatten(a,op),:postFlatten(b,op)] + LIST x + +postForm (u is [op,:argl]) == + x:= + atom op => + argl':= postTranList argl + op':= + true=> op + $BOOT => op + GET(op,'Led) or GET(op,'Nud) or op = 'IN => op + numOfArgs:= (argl' is [["Tuple",:l]] => #l; 1) + INTERNL("*",STRINGIMAGE numOfArgs,PNAME op) + [op',:argl'] + op is ["Scripts",:.] => [:postTran op,:postTranList argl] + u:= postTranList u + if u is [["Tuple",:.],:.] then + postError ['" ",:bright u, + '"is illegal because tuples cannot be applied_!",'%l, + '" Did you misuse infix dot?"] + u + x is [.,["Tuple",:y]] => [first x,:y] + x + +postQuote [.,a] == ["QUOTE",a] + +postScriptsForm(["Scripts",op,a],argl) == + [getScriptName(op,a,#argl),:postTranScripts a,:argl] + +postScripts ["Scripts",op,a] == + [getScriptName(op,a,0),:postTranScripts a] + +getScriptName(op,a,numberOfFunctionalArgs) == + if null IDENTP op then + postError ['" ",op,'" cannot have scripts"] + INTERNL("*",STRINGIMAGE numberOfFunctionalArgs, + decodeScripts a,PNAME op) + +postTranScripts a == + a is ["PrefixSC",b] => postTranScripts b + a is [";",:b] => "append"/[postTranScripts y for y in b] + a is [",",:b] => + ("append"/[fn postTran y for y in b]) where + fn x == + x is ["Tuple",:y] => y + LIST x + LIST postTran a + +decodeScripts a == + a is ["PrefixSC",b] => STRCONC(STRINGIMAGE 0,decodeScripts b) + a is [";",:b] => APPLX('STRCONC,[decodeScripts x for x in b]) + a is [",",:b] => + STRINGIMAGE fn a where fn a == (a is [",",:b] => +/[fn x for x in b]; 1) + STRINGIMAGE 1 + +postIf t == + t isnt ["if",:l] => t + ["IF",:[(null (x:= postTran x) and null $BOOT => "noBranch"; x) + for x in l]] + +postJoin ["Join",a,:l] == + a:= postTran a + l:= postTranList l + if l is [b] and b is [name,:.] and MEMQ(name,'(ATTRIBUTE SIGNATURE)) then l + := LIST ["CATEGORY",b] + al:= + a is ["Tuple",:c] => c + LIST a + ["Join",:al,:l] + +postMapping u == + u isnt ["->",source,target] => u + ["Mapping",postTran target,:unTuple postTran source] + +postOp x == + x=":=" => + $BOOT => "SPADLET" + "LET" + x=":-" => "LETD" + x="Attribute" => "ATTRIBUTE" + x + +postRepeat ["REPEAT",:m,x] == ["REPEAT",:postIteratorList m,postTran x] + +postSEGMENT ["SEGMENT",a,b] == + key:= [a,'"..",:(b => [b]; nil)] + postError ['" Improper placement of segment",:bright key] + +postCollect [constructOp,:m,x] == + x is [["elt",D,"construct"],:y] => + postCollect [["elt",D,"COLLECT"],:m,["construct",:y]] + itl:= postIteratorList m + x:= (x is ["construct",r] => r; x) --added 84/8/31 + y:= postTran x + finish(constructOp,itl,y) where + finish(op,itl,y) == + y is [":",a] => ["REDUCE","append",0,[op,:itl,a]] + y is ["Tuple",:l] => + newBody:= + or/[x is [":",y] for x in l] => postMakeCons l + or/[x is ["SEGMENT",:.] for x in l] => tuple2List l + ["construct",:postTranList l] + ["REDUCE","append",0,[op,:itl,newBody]] + [op,:itl,y] + +postTupleCollect [constructOp,:m,x] == + postCollect [constructOp,:m,["construct",x]] + +postIteratorList x == + x is [p,:l] => + (p:= postTran p) is ["IN",y,u] => + u is ["|",a,b] => [["IN",y,postInSeq a],["|",b],:postIteratorList l] + [["IN",y,postInSeq u],:postIteratorList l] + [p,:postIteratorList l] + x + +postin arg == + arg isnt ["in",i,seq] => systemErrorHere '"postin" + ["in",postTran i, postInSeq seq] + +postIn arg == + arg isnt ["IN",i,seq] => systemErrorHere '"postIn" + ["IN",postTran i,postInSeq seq] + +postInSeq seq == + seq is ["SEGMENT",p,q] => postTranSegment(p,q) + seq is ["Tuple",:l] => tuple2List l + postTran seq + +postTranSegment(p,q) == ["SEGMENT",postTran p,(q => postTran q; nil)] + +tuple2List l == + l is [a,:l'] => + u:= tuple2List l' + a is ["SEGMENT",p,q] => + null u => ["construct",postTranSegment(p,q)] + $InteractiveMode and null $BOOT => + ["append",["construct",postTranSegment(p,q)],tuple2List l'] + ["nconc",["construct",postTranSegment(p,q)],tuple2List l'] + null u => ["construct",postTran a] + ["cons",postTran a,tuple2List l'] + nil + +SEGMENT(a,b) == [i for i in a..b] + +postReduce ["Reduce",op,expr] == + $InteractiveMode or expr is ["COLLECT",:.] => + ["REDUCE",op,0,postTran expr] + postReduce ["Reduce",op,["COLLECT",["IN",g:= GENSYM(),expr], + ["construct", g]]] + +postFlattenLeft(x,op) ==-- + x is [ =op,a,b] => [:postFlattenLeft(a,op),b] + [x] + +postSemiColon u == postBlock ["Block",:postFlattenLeft(u,";")] + +postSequence ["Sequence",:l] == ['(elt $ makeRecord),:postTranList l] + +--------------------> NEW DEFINITION (see br-saturn.boot.pamphlet) +postSignature ["Signature",op,sig] == + sig is ["->",:.] => + sig1:= postType sig + op:= postAtom (STRINGP op => INTERN op; op) + ["SIGNATURE",op,:removeSuperfluousMapping killColons sig1] + +killColons x == + atom x => x + x is ["Record",:.] => x + x is ["Union",:.] => x + x is [":",.,y] => killColons y + [killColons first x,:killColons rest x] + +postSlash ['_/,a,b] == + STRINGP a => postTran ["Reduce",INTERN a,b] + ['_/,postTran a,postTran b] + +removeSuperfluousMapping sig1 == + --get rid of this asap + sig1 is [x,:y] and x is ["Mapping",:.] => [rest x,:y] + sig1 + +postType typ == + typ is ["->",source,target] => + source="constant" => [LIST postTran target,"constant"] + LIST ["Mapping",postTran target,:unTuple postTran source] + typ is ["->",target] => LIST ["Mapping",postTran target] + LIST postTran typ + +postTuple u == + u is ["Tuple"] => u + u is ["Tuple",:l,a] => (["Tuple",:postTranList rest u]) +--u is ["Tuple",:l,a] => (--a:= postTran a; ["Tuple",:postTranList rest u]) + --RDJ: don't understand need for above statement that is commented out + +postWhere ["where",a,b] == + x:= + b is ["Block",:c] => c + LIST b + ["where",postTran a,:postTranList x] + +postWith ["with",a] == + $insidePostCategoryIfTrue: local := true + a:= postTran a + a is [op,:.] and MEMQ(op,'(SIGNATURE ATTRIBUTE IF)) => ["CATEGORY",a] + a is ["PROGN",:b] => ["CATEGORY",:b] + a + +postTransformCheck x == + $defOp: local:= nil + postcheck x + +postcheck x == + atom x => nil + x is ["DEF",form,[target,:.],:.] => + (setDefOp form; postcheckTarget target; postcheck rest rest x) + x is ["QUOTE",:.] => nil + postcheck first x + postcheck rest x + +setDefOp f == + if f is [":",g,:.] then f := g + f := (atom f => f; first f) + if $topOp then $defOp:= f else $topOp:= f + +postcheckTarget x == + -- doesn't seem that useful! + isPackageType x => nil + x is ["Join",:.] => nil + NIL + +isPackageType x == not CONTAINED("$",x) + +unTuple x == + x is ["Tuple",:y] => y + LIST x + +--% APL TRANSFORMATION OF INPUT + +aplTran x == + $BOOT => x + $GENNO: local := 0 + u:= aplTran1 x + containsBang u => throwKeyedMsg("S2IP0002",NIL) + u + +containsBang u == + atom u => EQ(u,"_!") + u is [="QUOTE",.] => false + or/[containsBang x for x in u] + +aplTran1 x == + atom x => x + [op,:argl1] := x + argl := aplTranList argl1 + -- unary case f ! y + op = "_!" => + argl is [f,y] => + y is [op',:y'] and op' = "_!" => aplTran1 [op,op,f,:y'] + $BOOT => ["COLLECT",["IN",g:=GENVAR(),aplTran1 y],[f,g]] + ["map",f,aplTran1 y] + x --do not handle yet + -- multiple argument case + hasAplExtension argl is [arglAssoc,:futureArgl] => + -- choose the last aggregate type to be result of reshape + ["reshape",["COLLECT",:[["IN",g,["ravel",a]] for [g,:a] in arglAssoc], + aplTran1 [op,:futureArgl]],CDAR arglAssoc] + [op,:argl] + +aplTranList x == + atom x => x + [aplTran1 first x,:aplTranList rest x] + +hasAplExtension argl == + or/[x is ["_!",:.] for x in argl] => + u:= [futureArg for x in argl] where futureArg() == + x is ["_!",y] => + z:= deepestExpression y + arglAssoc := [[g := GENVAR(),:aplTran1 z],:arglAssoc] + substitute(g,z,y) + x + [arglAssoc,:u] + nil + +deepestExpression x == + x is ["_!",y] => deepestExpression y + x diff --git a/src/interp/postpar.boot.pamphlet b/src/interp/postpar.boot.pamphlet deleted file mode 100644 index 67cf814a..00000000 --- a/src/interp/postpar.boot.pamphlet +++ /dev/null @@ -1,555 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\$SPAD/src/interp postpar.boot} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -import '"postprop" -)package "BOOT" - -$postStack := [] - ---% Yet Another Parser Transformation File ---These functions are used by for BOOT and SPAD code ---(see new2OldLisp, e.g.) - -postTransform y == - x:= y - u:= postTran x - if u is ["Tuple",:l,[":",y,t]] and (and/[IDENTP x for x in l]) then u:= - [":",["LISTOF",:l,y],t] - postTransformCheck u - aplTran u - -displayPreCompilationErrors() == - n:= #($postStack:= REMDUP NREVERSE $postStack) - n=0 => nil - errors:= - 1 '"errors" - '"error" - if $InteractiveMode - then sayBrightly ['" Semantic ",errors,'" detected: "] - else - heading:= - $topOp ^= '$topOp => ['" ",$topOp,'" has"] - ['" You have"] - sayBrightly [:heading,'%b,n,'%d,'"precompilation ",errors,'":"] - if 1 - postAtom x - op := first x - SYMBOLP op and (f:= GETL(op,'postTran)) => FUNCALL(f,x) - op is ["elt",a,b] => - u:= postTran [b,:rest x] - [postTran op,:rest u] - op is ["Scripts",:.] => - postScriptsForm(op,"append"/[unTuple postTran y for y in rest x]) - op^=(y:= postOp op) => [y,:postTranList rest x] - postForm x - -postTranList x == [postTran y for y in x] - -postBigFloat x == - [.,mant,:expon] := x - $BOOT => INT2RNUM(mant) * INT2RNUM(10) ** expon - eltword := if $InteractiveMode then "$elt" else "elt" - postTran [[eltword,'(Float),"float"],[",",[",",mant,expon],10]] - -postAdd ["add",a,:b] == - null b => postCapsule a - ["add",postTran a,postCapsule first b] - -checkWarning msg == postError concat('"Parsing error: ",msg) - -checkWarningIndentation() == - checkWarning ['"Apparent indentation error following",:bright "add"] - -postCapsule x == - x isnt [op,:.] => checkWarningIndentation() - INTEGERP op or op = "==" => ["CAPSULE",postBlockItem x] - op = ";" => ["CAPSULE",:postBlockItemList postFlatten(x,";")] - op = "if" => ["CAPSULE",postBlockItem x] - checkWarningIndentation() - -postQUOTE x == x - -postColon u == - u is [":",x] => [":",postTran x] - u is [":",x,y] => [":",postTran x,:postType y] - -postColonColon u == - -- for Lisp package calling - -- boot syntax is package::fun but probably need to parenthesize it - $BOOT and u is ["::",package,fun] => - INTERN(STRINGIMAGE fun, package) - postForm u - -postAtSign ["@",x,y] == ["@",postTran x,:postType y] - -postPretend ["pretend",x,y] == ["pretend",postTran x,:postType y] - -postConstruct u == - u is ["construct",b] => - a:= (b is [",",:.] => comma2Tuple b; b) - a is ["SEGMENT",p,q] => ["construct",postTranSegment(p,q)] - a is ["Tuple",:l] => - or/[x is [":",y] for x in l] => postMakeCons l - or/[x is ["SEGMENT",:.] for x in l] => tuple2List l - ["construct",:postTranList l] - ["construct",postTran a] - u - -postError msg == - BUMPERRORCOUNT 'precompilation - xmsg:= - $defOp ^= '$defOp and not $InteractiveMode => [$defOp,'": ",:msg] - msg - $postStack:= [xmsg,:$postStack] - nil - -postMakeCons l == - null l => "nil" - l is [[":",a],:l'] => - l' => ["append",postTran a,postMakeCons l'] - postTran a - ["cons",postTran first l,postMakeCons rest l] - -postAtom x == - $BOOT => x - x=0 => '(Zero) - x=1 => '(One) - EQ(x,'T) => 'T_$ -- rename T in spad code to T$ - IDENTP x and GETDATABASE(x,'NILADIC) => LIST x - x - -postBlock ["Block",:l,x] == - ["SEQ",:postBlockItemList l,["exit",postTran x]] - -postBlockItemList l == [postBlockItem x for x in l] - -postBlockItem x == - x:= postTran x - x is ["Tuple",:l,[":",y,t]] and (and/[IDENTP x for x in l]) => - [":",["LISTOF",:l,y],t] - x - -postCategory (u is ["CATEGORY",:l]) == - --RDJ: ugh_ please -- someone take away need for PROGN as soon as possible - null l => u - op := - $insidePostCategoryIfTrue = true => "PROGN" - "CATEGORY" - [op,:[fn x for x in l]] where fn x == - $insidePostCategoryIfTrue: local := true - postTran x - -postComma u == postTuple comma2Tuple u - -comma2Tuple u == ["Tuple",:postFlatten(u,",")] - -postDef [defOp,lhs,rhs] == ---+ - lhs is ["macro",name] => postMDef ["==>",name,rhs] - - if not($BOOT) then recordHeaderDocumentation nil - if $maxSignatureLineNumber ^= 0 then - $docList := [["constructor",:$headerDocumentation],:$docList] - $maxSignatureLineNumber := 0 - --reset this for next constructor; see recordDocumentation - lhs:= postTran lhs - [form,targetType]:= - lhs is [":",:.] => rest lhs - [lhs,nil] - if null $InteractiveMode and atom form then form := LIST form - newLhs:= - atom form => form - [op,:argl]:= [(x is [":",a,.] => a; x) for x in form] - [op,:postDefArgs argl] - argTypeList:= - atom form => nil - [(x is [":",.,t] => t; nil) for x in rest form] - typeList:= [targetType,:argTypeList] - if atom form then form := [form] - specialCaseForm := [nil for x in form] - ["DEF",newLhs,typeList,specialCaseForm,postTran rhs] - -postDefArgs argl == - null argl => argl - argl is [[":",a],:b] => - b => postError - ['" Argument",:bright a,'"of indefinite length must be last"] - atom a or a is ["QUOTE",:.] => a - postError - ['" Argument",:bright a,'"of indefinite length must be a name"] - [first argl,:postDefArgs rest argl] - -postMDef(t) == - [.,lhs,rhs] := t - $InteractiveMode and not $BOOT => - lhs := postTran lhs - null IDENTP lhs => throwKeyedMsg("S2IP0001",NIL) - ["MDEF",lhs,NIL,NIL,postTran rhs] - lhs:= postTran lhs - [form,targetType]:= - lhs is [":",:.] => rest lhs - [lhs,nil] - form:= - atom form => LIST form - form - newLhs:= [(x is [":",a,:.] => a; x) for x in form] - typeList:= [targetType,:[(x is [":",.,t] => t; nil) for x in rest form]] - ["MDEF",newLhs,typeList,[nil for x in form],postTran rhs] - -postElt (u is [.,a,b]) == - a:= postTran a - b is ["Sequence",:.] => [["elt",a,"makeRecord"],:postTranList rest b] - ["elt",a,postTran b] - -postExit ["=>",a,b] == ["IF",postTran a,["exit",postTran b],"noBranch"] - - -postFlatten(x,op) == - x is [ =op,a,b] => [:postFlatten(a,op),:postFlatten(b,op)] - LIST x - -postForm (u is [op,:argl]) == - x:= - atom op => - argl':= postTranList argl - op':= - true=> op - $BOOT => op - GET(op,'Led) or GET(op,'Nud) or op = 'IN => op - numOfArgs:= (argl' is [["Tuple",:l]] => #l; 1) - INTERNL("*",STRINGIMAGE numOfArgs,PNAME op) - [op',:argl'] - op is ["Scripts",:.] => [:postTran op,:postTranList argl] - u:= postTranList u - if u is [["Tuple",:.],:.] then - postError ['" ",:bright u, - '"is illegal because tuples cannot be applied_!",'%l, - '" Did you misuse infix dot?"] - u - x is [.,["Tuple",:y]] => [first x,:y] - x - -postQuote [.,a] == ["QUOTE",a] - -postScriptsForm(["Scripts",op,a],argl) == - [getScriptName(op,a,#argl),:postTranScripts a,:argl] - -postScripts ["Scripts",op,a] == - [getScriptName(op,a,0),:postTranScripts a] - -getScriptName(op,a,numberOfFunctionalArgs) == - if null IDENTP op then - postError ['" ",op,'" cannot have scripts"] - INTERNL("*",STRINGIMAGE numberOfFunctionalArgs, - decodeScripts a,PNAME op) - -postTranScripts a == - a is ["PrefixSC",b] => postTranScripts b - a is [";",:b] => "append"/[postTranScripts y for y in b] - a is [",",:b] => - ("append"/[fn postTran y for y in b]) where - fn x == - x is ["Tuple",:y] => y - LIST x - LIST postTran a - -decodeScripts a == - a is ["PrefixSC",b] => STRCONC(STRINGIMAGE 0,decodeScripts b) - a is [";",:b] => APPLX('STRCONC,[decodeScripts x for x in b]) - a is [",",:b] => - STRINGIMAGE fn a where fn a == (a is [",",:b] => +/[fn x for x in b]; 1) - STRINGIMAGE 1 - -postIf t == - t isnt ["if",:l] => t - ["IF",:[(null (x:= postTran x) and null $BOOT => "noBranch"; x) - for x in l]] - -postJoin ["Join",a,:l] == - a:= postTran a - l:= postTranList l - if l is [b] and b is [name,:.] and MEMQ(name,'(ATTRIBUTE SIGNATURE)) then l - := LIST ["CATEGORY",b] - al:= - a is ["Tuple",:c] => c - LIST a - ["Join",:al,:l] - -postMapping u == - u isnt ["->",source,target] => u - ["Mapping",postTran target,:unTuple postTran source] - -postOp x == - x=":=" => - $BOOT => "SPADLET" - "LET" - x=":-" => "LETD" - x="Attribute" => "ATTRIBUTE" - x - -postRepeat ["REPEAT",:m,x] == ["REPEAT",:postIteratorList m,postTran x] - -postSEGMENT ["SEGMENT",a,b] == - key:= [a,'"..",:(b => [b]; nil)] - postError ['" Improper placement of segment",:bright key] - -postCollect [constructOp,:m,x] == - x is [["elt",D,"construct"],:y] => - postCollect [["elt",D,"COLLECT"],:m,["construct",:y]] - itl:= postIteratorList m - x:= (x is ["construct",r] => r; x) --added 84/8/31 - y:= postTran x - finish(constructOp,itl,y) where - finish(op,itl,y) == - y is [":",a] => ["REDUCE","append",0,[op,:itl,a]] - y is ["Tuple",:l] => - newBody:= - or/[x is [":",y] for x in l] => postMakeCons l - or/[x is ["SEGMENT",:.] for x in l] => tuple2List l - ["construct",:postTranList l] - ["REDUCE","append",0,[op,:itl,newBody]] - [op,:itl,y] - -postTupleCollect [constructOp,:m,x] == - postCollect [constructOp,:m,["construct",x]] - -postIteratorList x == - x is [p,:l] => - (p:= postTran p) is ["IN",y,u] => - u is ["|",a,b] => [["IN",y,postInSeq a],["|",b],:postIteratorList l] - [["IN",y,postInSeq u],:postIteratorList l] - [p,:postIteratorList l] - x - -postin arg == - arg isnt ["in",i,seq] => systemErrorHere '"postin" - ["in",postTran i, postInSeq seq] - -postIn arg == - arg isnt ["IN",i,seq] => systemErrorHere '"postIn" - ["IN",postTran i,postInSeq seq] - -postInSeq seq == - seq is ["SEGMENT",p,q] => postTranSegment(p,q) - seq is ["Tuple",:l] => tuple2List l - postTran seq - -postTranSegment(p,q) == ["SEGMENT",postTran p,(q => postTran q; nil)] - -tuple2List l == - l is [a,:l'] => - u:= tuple2List l' - a is ["SEGMENT",p,q] => - null u => ["construct",postTranSegment(p,q)] - $InteractiveMode and null $BOOT => - ["append",["construct",postTranSegment(p,q)],tuple2List l'] - ["nconc",["construct",postTranSegment(p,q)],tuple2List l'] - null u => ["construct",postTran a] - ["cons",postTran a,tuple2List l'] - nil - -SEGMENT(a,b) == [i for i in a..b] - -postReduce ["Reduce",op,expr] == - $InteractiveMode or expr is ["COLLECT",:.] => - ["REDUCE",op,0,postTran expr] - postReduce ["Reduce",op,["COLLECT",["IN",g:= GENSYM(),expr], - ["construct", g]]] - -postFlattenLeft(x,op) ==-- - x is [ =op,a,b] => [:postFlattenLeft(a,op),b] - [x] - -postSemiColon u == postBlock ["Block",:postFlattenLeft(u,";")] - -postSequence ["Sequence",:l] == ['(elt $ makeRecord),:postTranList l] - ---------------------> NEW DEFINITION (see br-saturn.boot.pamphlet) -postSignature ["Signature",op,sig] == - sig is ["->",:.] => - sig1:= postType sig - op:= postAtom (STRINGP op => INTERN op; op) - ["SIGNATURE",op,:removeSuperfluousMapping killColons sig1] - -killColons x == - atom x => x - x is ["Record",:.] => x - x is ["Union",:.] => x - x is [":",.,y] => killColons y - [killColons first x,:killColons rest x] - -postSlash ['_/,a,b] == - STRINGP a => postTran ["Reduce",INTERN a,b] - ['_/,postTran a,postTran b] - -removeSuperfluousMapping sig1 == - --get rid of this asap - sig1 is [x,:y] and x is ["Mapping",:.] => [rest x,:y] - sig1 - -postType typ == - typ is ["->",source,target] => - source="constant" => [LIST postTran target,"constant"] - LIST ["Mapping",postTran target,:unTuple postTran source] - typ is ["->",target] => LIST ["Mapping",postTran target] - LIST postTran typ - -postTuple u == - u is ["Tuple"] => u - u is ["Tuple",:l,a] => (["Tuple",:postTranList rest u]) ---u is ["Tuple",:l,a] => (--a:= postTran a; ["Tuple",:postTranList rest u]) - --RDJ: don't understand need for above statement that is commented out - -postWhere ["where",a,b] == - x:= - b is ["Block",:c] => c - LIST b - ["where",postTran a,:postTranList x] - -postWith ["with",a] == - $insidePostCategoryIfTrue: local := true - a:= postTran a - a is [op,:.] and MEMQ(op,'(SIGNATURE ATTRIBUTE IF)) => ["CATEGORY",a] - a is ["PROGN",:b] => ["CATEGORY",:b] - a - -postTransformCheck x == - $defOp: local:= nil - postcheck x - -postcheck x == - atom x => nil - x is ["DEF",form,[target,:.],:.] => - (setDefOp form; postcheckTarget target; postcheck rest rest x) - x is ["QUOTE",:.] => nil - postcheck first x - postcheck rest x - -setDefOp f == - if f is [":",g,:.] then f := g - f := (atom f => f; first f) - if $topOp then $defOp:= f else $topOp:= f - -postcheckTarget x == - -- doesn't seem that useful! - isPackageType x => nil - x is ["Join",:.] => nil - NIL - -isPackageType x == not CONTAINED("$",x) - -unTuple x == - x is ["Tuple",:y] => y - LIST x - ---% APL TRANSFORMATION OF INPUT - -aplTran x == - $BOOT => x - $GENNO: local := 0 - u:= aplTran1 x - containsBang u => throwKeyedMsg("S2IP0002",NIL) - u - -containsBang u == - atom u => EQ(u,"_!") - u is [="QUOTE",.] => false - or/[containsBang x for x in u] - -aplTran1 x == - atom x => x - [op,:argl1] := x - argl := aplTranList argl1 - -- unary case f ! y - op = "_!" => - argl is [f,y] => - y is [op',:y'] and op' = "_!" => aplTran1 [op,op,f,:y'] - $BOOT => ["COLLECT",["IN",g:=GENVAR(),aplTran1 y],[f,g]] - ["map",f,aplTran1 y] - x --do not handle yet - -- multiple argument case - hasAplExtension argl is [arglAssoc,:futureArgl] => - -- choose the last aggregate type to be result of reshape - ["reshape",["COLLECT",:[["IN",g,["ravel",a]] for [g,:a] in arglAssoc], - aplTran1 [op,:futureArgl]],CDAR arglAssoc] - [op,:argl] - -aplTranList x == - atom x => x - [aplTran1 first x,:aplTranList rest x] - -hasAplExtension argl == - or/[x is ["_!",:.] for x in argl] => - u:= [futureArg for x in argl] where futureArg() == - x is ["_!",y] => - z:= deepestExpression y - arglAssoc := [[g := GENVAR(),:aplTran1 z],:arglAssoc] - substitute(g,z,y) - x - [arglAssoc,:u] - nil - -deepestExpression x == - x is ["_!",y] => deepestExpression y - x -@ - -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} -- cgit v1.2.3