From 988485c37966b23cf7f3e058eb93b15d4e81236b Mon Sep 17 00:00:00 2001 From: dos-reis Date: Thu, 20 Sep 2007 03:21:47 +0000 Subject: * Makefile.pamphlet (${DEPSYS}): Now depend on the compiled form of parse. Load it. (parse.$(FASLEXT)): New rule. * parse.boot: New. Import "postpar". * parse.boot.pamphlet: Move content to parse.boot.pamphlet. Remove. --- src/interp/ChangeLog | 8 + src/interp/Makefile.in | 3 + src/interp/Makefile.pamphlet | 11 +- src/interp/parse.boot | 486 +++++++++++++++++++++++++++++++++++ src/interp/parse.boot.pamphlet | 571 ----------------------------------------- 5 files changed, 503 insertions(+), 576 deletions(-) create mode 100644 src/interp/parse.boot delete mode 100644 src/interp/parse.boot.pamphlet diff --git a/src/interp/ChangeLog b/src/interp/ChangeLog index 10e71f06..7651ebe6 100644 --- a/src/interp/ChangeLog +++ b/src/interp/ChangeLog @@ -1,3 +1,11 @@ +2007-09-19 Gabriel Dos Reis + + * Makefile.pamphlet (${DEPSYS}): Now depend on the compiled form + of parse. Load it. + (parse.$(FASLEXT)): New rule. + * parse.boot: New. Import "postpar". + * parse.boot.pamphlet: Move content to parse.boot.pamphlet. Remove. + 2007-09-19 Gabriel Dos Reis * util.lisp.pamphlet ($directory-list): Move to sys-globals.boot. diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index 14c14cbf..ab300b8b 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -465,6 +465,9 @@ $(AUTO)/%.$(FASLEXT): %.$(FASLEXT) ## The old parser component roughtly is: ## +parse.$(FASLEXT): parse.clisp postpar.$(FASLEXT) + $(BOOTSYS) -- --compile --output=$@ --load-directory=. $< + postpar.$(FASLEXT): postpar.clisp postprop.$(FASLEXT) $(BOOTSYS) -- --compile --output=$@ --load-directory=. $< diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index a3612286..d540e5b1 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -982,7 +982,7 @@ ${DEPSYS}: vmlisp.$(FASLEXT) \ bookvol5.$(FASLEXT)\ util.$(FASLEXT) \ postpar.$(FASLEXT) \ - parse.clisp \ + parse.$(FASLEXT) \ parsing.$(FASLEXT) \ metalex.$(FASLEXT) \ bootlex.$(FASLEXT) \ @@ -1011,10 +1011,9 @@ ${DEPSYS}: vmlisp.$(FASLEXT) \ @ echo '(|importModule| "util")' >> makedep.lisp @ echo '(in-package "BOOT")' >> makedep.lisp @ echo '(build-depsys (quote ($(patsubst %, "%", ${DEP}))) "${AXIOM}")' >> makedep.lisp - @ echo '(unless (probe-file "parse.$(FASLEXT)") (|compileLispFile| "parse.clisp" "parse.$(FASLEXT)"))' >> makedep.lisp @ echo '(in-package "AxiomCore")' >> makedep.lisp @ echo '(|importModule| "newaux")' >> makedep.lisp - @ echo '(load "parse")' >> makedep.lisp + @ echo '(|importModule| "parse")' >> makedep.lisp @ echo '(|importModule| "metalex")' >> makedep.lisp @ echo '(|importModule| "parsing")' >> makedep.lisp @ echo '(|importModule| "fnewmeta")' >> makedep.lisp @@ -1038,8 +1037,7 @@ ${DEPSYS}: vmlisp.$(FASLEXT) \ @ echo '(load "g-util")' >> makedep.lisp <> @rm $(addsuffix .$(FASLEXT), \ - parse clam slam g-error \ - g-boot c-util g-util) + clam slam g-error g-boot c-util g-util) @ echo 4 ${DEPSYS} created @@ -1960,6 +1958,9 @@ $(AUTO)/%.$(FASLEXT): %.$(FASLEXT) ## The old parser component roughtly is: ## +parse.$(FASLEXT): parse.clisp postpar.$(FASLEXT) + $(BOOTSYS) -- --compile --output=$@ --load-directory=. $< + postpar.$(FASLEXT): postpar.clisp postprop.$(FASLEXT) $(BOOTSYS) -- --compile --output=$@ --load-directory=. $< diff --git a/src/interp/parse.boot b/src/interp/parse.boot new file mode 100644 index 00000000..8328af6b --- /dev/null +++ b/src/interp/parse.boot @@ -0,0 +1,486 @@ +-- 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 '"postpar" +)package "BOOT" + +--% Transformation of Parser Output + +parseTransform x == + $defOp: local:= nil + x := substitute('$,'%,x) -- for new compiler compatibility + parseTran x + +parseTran x == + $op: local + atom x => parseAtom x + [$op,:argl]:= x + u := g($op) where g op == (op is ["elt",op,x] => g x; op) + u="construct" => + r:= parseConstruct argl + $op is ["elt",:.] => [parseTran $op,:rest r] + r + SYMBOLP u and (fn:= GETL(u,'parseTran)) => FUNCALL(fn,argl) + [parseTran $op,:parseTranList argl] + + +parseAtom x == + -- next line for compatibility with new compiler + x = "break" => parseLeave ["$NoValue"] + x + +parseTranList l == + atom l => parseTran l + [parseTran first l,:parseTranList rest l] + +parseConstruct u == + $insideConstructIfTrue: local:= true + l:= parseTranList u + ["construct",:l] + +parseUpArrow u == parseTran ["**",:u] + +parseLeftArrow u == parseTran ["LET",:u] + +parseIs [a,b] == ["is",parseTran a,transIs parseTran b] + +parseIsnt [a,b] == ["isnt",parseTran a,transIs parseTran b] + +transIs u == + isListConstructor u => ["construct",:transIs1 u] + u + +isListConstructor u == u is [op,:.] and op in '(construct append cons) + +transIs1 u == + u is ["construct",:l] => [transIs x for x in l] + u is ["append",x,y] => + h:= [":",transIs x] + (v:= transIs1 y) is [":",z] => [h,z] + v="nil" => first rest h + atom v => [h,[":",v]] + [h,:v] + u is ["cons",x,y] => + h:= transIs x + (v:= transIs1 y) is [":",z] => [h,z] + v="nil" => [h] + atom v => [h,[":",v]] + [h,:v] + u + +parseLET [x,y] == + p := ["LET",parseTran x,parseTranCheckForRecord(y,opOf x)] + opOf x = "cons" => ["LET",transIs p.1,p.2] + p + +parseLETD [x,y] == ["LETD",parseTran x,parseTran parseType y] + +parseColon u == + u is [x] => [":",parseTran x] + u is [x,typ] => + $InteractiveMode => + $insideConstructIfTrue=true => ["TAG",parseTran x,parseTran typ] + [":",parseTran x,parseTran parseType typ] + [":",parseTran x,parseTran typ] + +parseBigelt [typ,consForm] == + [["elt",typ,"makeRecord"],:transUnCons consForm] + +transUnCons u == + atom u => systemErrorHere '"transUnCons" + u is ["APPEND",x,y] => + null y => x + systemErrorHere '"transUnCons" + u is ["CONS",x,y] => + atom y => [x,:y] + [x,:transUnCons y] + +parseCoerce [x,typ] == + $InteractiveMode => ["::",parseTran x,parseTran parseType typ] + ["::",parseTran x,parseTran typ] + +parseAtSign [x,typ] == + $InteractiveMode => ["@",parseTran x,parseTran parseType typ] + ["@",parseTran x,parseTran typ] + +parsePretend [x,typ] == + $InteractiveMode => ["pretend",parseTran x,parseTran parseType typ] + ["pretend",parseTran x,parseTran typ] + +parseType x == + x := substitute($EmptyMode,$quadSymbol,x) + x is ["typeOf",val] => ["typeOf",parseTran val] + $oldParserExpandAbbrs => parseTypeEvaluate unabbrevAndLoad x + x + +parseTypeEvaluate form == + form is [op,:argl] => + newType? op => form + $op: local:= op + op = "Mapping" => + [op,:[parseTypeEvaluate a for a in argl]] + op = "Union" => + isTaggedUnion form => + [op,:[['_:,sel,parseTypeEvaluate type] for + ['_:,sel,type] in argl]] + [op,:[parseTypeEvaluate a for a in argl]] + op = 'Record => + [op,:[['_:,sel,parseTypeEvaluate type] for ['_:,sel,type] in argl]] + cmm := + fn := constructor? op => + p := pathname [fn,$spadLibFT,'"*"] => + isExistingFile p => getConstructorModemap(abbreviation? fn) + nil + nil + cmm is [[.,.,:argml],:.] => [op,:parseTypeEvaluateArgs(argl,argml)] + throwKeyedMsg("S2IL0015",[op]) + form + +parseTypeEvaluateArgs(argl,argml) == + [argVal for arg in argl for md in argml for i in 1..] where argVal() == + isCategoryForm(md,$CategoryFrame) => parseTypeEvaluate arg + arg + + +parseTypeError(x,md,i) == throwKeyedMsg("S2IP0003",[i,$op,md]) + +specialModeTran form == + form is [op,:argl] => + not ATOM op => form --added 10/5/84 by SCM + (s0:= (sop:= PNAME op).0) = "*" => + n:= #sop + n=1=> form + argKey:= sop.1 + numArgs:= #argl - (argKey="1" => 1; 0) + zeroOrOne:= argKey="0" or argKey="1" + isDmp := + numArgs < 10 => + n=6 and ('"DMP"=SUBSTRING(sop,3,3)) and zeroOrOne + true => + n=7 and ('"DMP"=SUBSTRING(sop,4,3)) and zeroOrOne + isDmp => + if argKey="0" then + extraDomain:= $EmptyMode + vl:= argl + else + [:vl,extraDomain] := argl + ["DistributedMultivariatePolynomial",["construct",:vl], + specialModeTran extraDomain] + n=4 and (s3:= sop.3) = "M" and zeroOrOne => + specialModeTran + extraDomain:= (argKey="0" => [$EmptyMode]; nil) + (n:= PARSE_-INTEGER PNAME sop.2)=1 => + ["SquareMatrix",:argl,:extraDomain] + n=2 => ["RectangularMatrix",:argl,:extraDomain] + form + isUpOrMp := + numArgs < 10 => + n=4 and (s3:= sop.3) = "P" and zeroOrOne or + n=5 and (s3:= sop.3)="R" and sop.4="F" and zeroOrOne + true => + n=5 and (s3:= sop.4) = "P" and zeroOrOne or + n=6 and (s3:= sop.4)="R" and sop.5="F" and zeroOrOne + isUpOrMp => + polyForm:= + domainPart:= (argKey="0" => $EmptyMode; last argl) + argPart:= (argKey="0" => argl; drop(-1,argl)) + numArgs < 10 and (n:= PARSE_-INTEGER PNAME sop.2)=1 + => ["UP",:argPart,domainPart] + ["MP",["construct",:argPart],domainPart] + specialModeTran + s3 = "R" => [$QuotientField,polyForm] + polyForm + [first form,:[specialModeTran x for x in rest form]] + [first form,:[specialModeTran x for x in rest form]] + form + +parseHas [x,y] == + if $InteractiveMode then + x:= + get(x,'value,$CategoryFrame) is [D,m,.] + and m in '((Mode) (Domain) (SubDomain (Domain))) => D + parseType x + mkand [["has",x,u] for u in fn y] where + mkand x == + x is [a] => a + ["and",:x] + fn y == + if $InteractiveMode then y:= unabbrevAndLoad y + y is [":" ,op,["Mapping",:map]] => + op:= (STRINGP op => INTERN op; op) + [["SIGNATURE",op,map]] + y is ["Join",:u] => "append"/[fn z for z in u] + y is ["CATEGORY",:u] => "append"/[fn z for z in u] + kk:= GETDATABASE(opOf y,'CONSTRUCTORKIND) + kk = "domain" or kk = "category" => [makeNonAtomic y] + y is ["ATTRIBUTE",:.] => [y] + y is ["SIGNATURE",:.] => [y] + $InteractiveMode => parseHasRhs y + [["ATTRIBUTE",y]] + +parseHasRhs u == --$InteractiveMode = true + get(u,'value,$CategoryFrame) is [D,m,.] + and m in '((Mode) (Domain) (SubDomain (Domain))) => m + y := abbreviation? u => + loadIfNecessary y => [unabbrevAndLoad y] + [["ATTRIBUTE",u]] + [["ATTRIBUTE",u]] + +parseDEF [$lhs,tList,specialList,body] == + setDefOp $lhs + ["DEF",parseLhs $lhs,parseTranList tList,parseTranList specialList, + parseTranCheckForRecord(body,opOf $lhs)] + +parseLhs x == + atom x => parseTran x + atom first x => [parseTran first x,:[transIs parseTran y for y in rest x]] + parseTran x + +parseMDEF [$lhs,tList,specialList,body] == + ["MDEF",parseTran $lhs,parseTranList tList,parseTranList specialList, + parseTranCheckForRecord(body,opOf $lhs)] + +parseTranCheckForRecord(x,op) == + (x:= parseTran x) is ["Record",:l] => + or/[y for y in l | y isnt [":",.,.]] => + postError ['" Constructor",:bright x,'"has missing label"] + x + x + +parseCases [expr,ifClause] == + casefn(expr,ifClause) where + casefn(x,ifExpr) == + ifExpr="noBranch" => ["ifClauseError",x] + ifExpr is ["IF",a,b,c] => ["IF",parseTran a,parseTran b,casefn(x,c)] + postError ['" CASES format error: cases ",x," of ",ifExpr] + +parseCategory x == + l:= parseTranList parseDropAssertions x + key:= + CONTAINED("$",l) => "domain" + "package" + ["CATEGORY",key,:l] + +parseDropAssertions x == +--note: the COPY of this list is necessary-- do not replace by RPLACing version + x is [y,:r] => + y is ["IF","asserted",:.] => parseDropAssertions r + [y,:parseDropAssertions r] + x + +parseGreaterThan [x,y] == + [substitute("<",">",$op),parseTran y,parseTran x] + +parseGreaterEqual u == parseTran ["not",[substitute("<",">=",$op),:u]] + +parseLessEqual u == parseTran ["not",[substitute(">","<=",$op),:u]] + +parseNotEqual u == parseTran ["not",[substitute("=","^=",$op),:u]] + +parseDollarGreaterThan [x,y] == + [substitute("$<","$>",$op),parseTran y,parseTran x] + +parseDollarGreaterEqual u == + parseTran ["not",[substitute("$<","$>=",$op),:u]] + +parseDollarLessEqual u == + parseTran ["not",[substitute("$>","$<=",$op),:u]] + +parseDollarNotEqual u == + parseTran ["not",[substitute("$=","$^=",$op),:u]] + +parseAnd u == + $InteractiveMode => ["and",:parseTranList u] + null u => "true" + null rest u => first u + parseIf [parseTran first u,parseAnd rest u,"false"] + +parseOr u == + $InteractiveMode => ["or",:parseTranList u] + null u => "false" + null rest u => first u + (x:= parseTran first u) is ["not",y] => parseIf [y,parseOr rest u,"true"] + true => parseIf [x,"true",parseOr rest u] + +parseNot u == ['not,parseTran first u] + +parseEquivalence [a,b] == parseIf [a,b,parseIf [b,:'(false true)]] + +parseImplies [a,b] == parseIf [a,b,"true"] + +parseExclusiveOr [a,b] == parseIf [a,parseIf [b,:'(false true)],b] + +parseExit [a,:b] == + -- note: I wanted to convert 1s to 0s here to facilitate indexing in + -- comp code; unfortunately, parseTran-ning is sometimes done more + -- than once so that the count can be decremented more than once + a:= parseTran a + b:= parseTran b + b => + null INTEGERP a => + (MOAN('"first arg ",a,'" for exit must be integer"); ["exit",1,a]) + ["exit",a,:b] + ["exit",1,a] + +parseLeave [a,:b] == + a:= parseTran a + b:= parseTran b + b => + null INTEGERP a => + (MOAN('"first arg ",a,'" for 'leave' must be integer"); ["leave",1,a]) + ["leave",a,:b] + ["leave",1,a] + +parseReturn [a,:b] == + a:= parseTran a + b:= parseTran b + b => + (if a^=1 then MOAN '"multiple-level 'return' not allowed"; ["return",1,:b]) + ["return",1,a] + +parseJoin l == + ["Join",:fn parseTranList l] where + fn l == + null l => nil + l is [["Join",:x],:y] => [:x,:fn y] + [first l,:fn rest l] + +parseInBy [i,n,inc] == + (u:= parseIn [i,n]) isnt ["STEP",i,a,j,:r] => + postError [" You cannot use",:bright '"by", + '"except for an explicitly indexed sequence."] + inc:= parseTran inc + ["STEP",i,a,parseTran inc,:r] + +parseSegment p == + p is [a,b] => + b => ["SEGMENT",parseTran a, parseTran b] + ["SEGMENT",parseTran a] + ["SEGMENT",:p] + +parseIn [i,n] == + i:= parseTran i + n:= parseTran n + n is ["SEGMENT",a] => ["STEP",i,a,1] + n is ["reverse",["SEGMENT",a]] => + postError ['" You cannot reverse an infinite sequence."] + n is ["SEGMENT",a,b] => (b => ["STEP",i,a,1,b]; ["STEP",i,a,1]) + n is ["reverse",["SEGMENT",a,b]] => + b => ["STEP",i,b,-1,a] + postError ['" You cannot reverse an infinite sequence."] + n is ["tails",s] => ["ON",i,s] + ["IN",i,n] + +parseIf t == + t isnt [p,a,b] => t + ifTran(parseTran p,parseTran a,parseTran b) where + ifTran(p,a,b) == + null($InteractiveMode) and p='true => a + null($InteractiveMode) and p='false => b + p is ['not,p'] => ifTran(p',b,a) + p is ['IF,p',a',b'] => ifTran(p',ifTran(a',COPY a,COPY b),ifTran(b',a,b)) + p is ['SEQ,:l,['exit,1,p']] => + ['SEQ,:l,['exit,1,ifTran(p',incExitLevel a,incExitLevel b)]] + --this assumes that l has no exits + a is ['IF, =p,a',.] => ['IF,p,a',b] + b is ['IF, =p,.,b'] => ['IF,p,a,b'] +-- makeSimplePredicateOrNil p is ['SEQ,:s,['exit,1,val]] => +-- parseTran ['SEQ,:s,['exit,1,incExitLevel ['IF,val,a,b]]] + ['IF,p,a,b] + +makeSimplePredicateOrNil p == nil + +parseWhere l == ["where",:mapInto(l, function parseTran)] + + +parseSeq l == + not l is [:.,["exit",:.]] => + postError ['" Invalid ending to block: ",last l] + transSeq mapInto(l,function parseTran) + +transSeq l == + null l => nil + null rest l => decExitLevel first l + [item,:tail]:= l + item is ["SEQ",:l,["exit",1,["IF",p,["exit", =2,q],"noBranch"]]] and + (and/[x is ["LET",:.] for x in l]) => + ["SEQ",:[decExitLevel x for x in l],["exit",1,["IF",decExitLevel p, + decExitLevel q,transSeq tail]]] + item is ["IF",a,["exit",1,b],"noBranch"] => + ["IF",decExitLevel a,decExitLevel b,transSeq tail] + item is ["IF",a,"noBranch",["exit",1,b]] => + ["IF",decExitLevel a,transSeq tail,decExitLevel b] + (y:= transSeq tail) is ["SEQ",:s] => ["SEQ",item,:s] + ["SEQ",item,["exit",1,incExitLevel y]] + +transCategoryItem x == + x is ["SIGNATURE",lhs,rhs] => + lhs is ["LISTOF",:y] => + "append" /[transCategoryItem ["SIGNATURE",z,rhs] for z in y] + atom lhs => + if STRINGP lhs then lhs:= INTERN lhs + rhs is ["Mapping",:m] => + m is [.,"constant"] => LIST ["SIGNATURE",lhs,[first m],"constant"] + LIST ["SIGNATURE",lhs,m] + $transCategoryAssoc:= [[lhs,:rhs],:$transCategoryAssoc] + NIL + [op,:argl]:= lhs + extra:= nil + if rhs is ["Mapping",:m] then + if rest m then extra:= rest m + --should only be 'constant' or 'variable' + rhs:= first m + LIST ["SIGNATURE",op,[rhs,:SUBLIS($transCategoryAssoc,argl)],:extra] + LIST x + +superSub(name,x) == + for u in x repeat y:= [:y,:u] + code:= + x is [[u]] => $quadSymbol + STRCONC("_(",scriptTranRow first x,scriptTran rest x,"_)") + [INTERNL(PNAME name,"$",code),:y] + +scriptTran x == + null x => "" + STRCONC(";",scriptTranRow first x,scriptTran rest x) + +scriptTranRow x == + null x => "" + STRCONC($quadSymbol,scriptTranRow1 rest x) + +scriptTranRow1 x == + null x => "" + STRCONC(",",$quadSymbol,scriptTranRow1 rest x) + +parseVCONS l == ["VECTOR",:parseTranList l] diff --git a/src/interp/parse.boot.pamphlet b/src/interp/parse.boot.pamphlet deleted file mode 100644 index b4c72963..00000000 --- a/src/interp/parse.boot.pamphlet +++ /dev/null @@ -1,571 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/parse.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{parseTransform} -This is the top-level function in this file. - -When parsing spad code we walk an source code expression such as - -[[P ==> PositiveInteger]] - -This gets translated by [[|postTransform|]]\cite{1} into - -[[(MDEF P NIL NIL (|PositiveInteger|))]] - -[[|parseTranform|]] is called with this expression. The [[%]] symbol, -which represents the current domain, is replaced with the [[$]] symbol -internally. This hack was introduced because the Aldor compiler wanted -to use [[%]] for the [[current domain]]. The Spad compiler used [[$]]. -In order not to have to change this everywhere we do a subsitution here. -<>= -parseTransform x == - $defOp: local:= nil - x := substitute('$,'%,x) -- for new compiler compatibility - parseTran x - -@ - -\section{parseTran} -[[|parseTran|]] sees an expression such as - -[[(MDEF P NIL NIL (|PositiveInteger|))]] - -It walks the -expression, which is a list, item by item (note the tail recursive -call in this function). In general, we are converting certain -source-level constructs into internal constructs. Note the subtle -way that functions get called in this file. The information about -what function to call is stored on the property list of the symbol. - -For example, given the form: [[(|has| S (|OrderedSet|))]] -the symbol [[|has|]] occurs in the car of the list. [[|parseTran|]] -assigns [[$op]] to be [[|has|]] and [[argl]] to be the list -[[(S (|OrderedSet|))]]. Next, a local function [[g]], which checks -for the compile-time elts, returns [[$op]] unchanged. The variable -[[u]] is set to [[|has|]]. - -Since [[|has|]] is an atom we do -[[(GET '|has| '|parseTran|)]] which returns [[|parseHas|]] -because the symbol [[|has|]] contains the association -[[|parseTran| |parseHas|]] on it's symbol property list. -You can see this by calling [[(symbol-plist '|has|)]]. - -This ends up calling [[(|parseHas| '(S (|OrderedSet|)))]]. - -The [[|parseTran|]] function walks the entire s-expression -calling special parsers for various special forms in the input. -This does things like reverse tests so that [[(if (not x) a b)]] -becomes [[(if x b a)]], etc. - -<>= -parseTran x == - $op: local - atom x => parseAtom x - [$op,:argl]:= x - u := g($op) where g op == (op is ["elt",op,x] => g x; op) - u="construct" => - r:= parseConstruct argl - $op is ["elt",:.] => [parseTran $op,:rest r] - r - SYMBOLP u and (fn:= GETL(u,'parseTran)) => FUNCALL(fn,argl) - [parseTran $op,:parseTranList argl] - -@ - -\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" - ---% Transformation of Parser Output - -<> -<> - -parseAtom x == - -- next line for compatibility with new compiler - x = "break" => parseLeave ["$NoValue"] - x - -parseTranList l == - atom l => parseTran l - [parseTran first l,:parseTranList rest l] - -parseConstruct u == - $insideConstructIfTrue: local:= true - l:= parseTranList u - ["construct",:l] - -parseUpArrow u == parseTran ["**",:u] - -parseLeftArrow u == parseTran ["LET",:u] - -parseIs [a,b] == ["is",parseTran a,transIs parseTran b] - -parseIsnt [a,b] == ["isnt",parseTran a,transIs parseTran b] - -transIs u == - isListConstructor u => ["construct",:transIs1 u] - u - -isListConstructor u == u is [op,:.] and op in '(construct append cons) - -transIs1 u == - u is ["construct",:l] => [transIs x for x in l] - u is ["append",x,y] => - h:= [":",transIs x] - (v:= transIs1 y) is [":",z] => [h,z] - v="nil" => first rest h - atom v => [h,[":",v]] - [h,:v] - u is ["cons",x,y] => - h:= transIs x - (v:= transIs1 y) is [":",z] => [h,z] - v="nil" => [h] - atom v => [h,[":",v]] - [h,:v] - u - -parseLET [x,y] == - p := ["LET",parseTran x,parseTranCheckForRecord(y,opOf x)] - opOf x = "cons" => ["LET",transIs p.1,p.2] - p - -parseLETD [x,y] == ["LETD",parseTran x,parseTran parseType y] - -parseColon u == - u is [x] => [":",parseTran x] - u is [x,typ] => - $InteractiveMode => - $insideConstructIfTrue=true => ["TAG",parseTran x,parseTran typ] - [":",parseTran x,parseTran parseType typ] - [":",parseTran x,parseTran typ] - -parseBigelt [typ,consForm] == - [["elt",typ,"makeRecord"],:transUnCons consForm] - -transUnCons u == - atom u => systemErrorHere '"transUnCons" - u is ["APPEND",x,y] => - null y => x - systemErrorHere '"transUnCons" - u is ["CONS",x,y] => - atom y => [x,:y] - [x,:transUnCons y] - -parseCoerce [x,typ] == - $InteractiveMode => ["::",parseTran x,parseTran parseType typ] - ["::",parseTran x,parseTran typ] - -parseAtSign [x,typ] == - $InteractiveMode => ["@",parseTran x,parseTran parseType typ] - ["@",parseTran x,parseTran typ] - -parsePretend [x,typ] == - $InteractiveMode => ["pretend",parseTran x,parseTran parseType typ] - ["pretend",parseTran x,parseTran typ] - -parseType x == - x := substitute($EmptyMode,$quadSymbol,x) - x is ["typeOf",val] => ["typeOf",parseTran val] - $oldParserExpandAbbrs => parseTypeEvaluate unabbrevAndLoad x - x - -parseTypeEvaluate form == - form is [op,:argl] => - newType? op => form - $op: local:= op - op = "Mapping" => - [op,:[parseTypeEvaluate a for a in argl]] - op = "Union" => - isTaggedUnion form => - [op,:[['_:,sel,parseTypeEvaluate type] for - ['_:,sel,type] in argl]] - [op,:[parseTypeEvaluate a for a in argl]] - op = 'Record => - [op,:[['_:,sel,parseTypeEvaluate type] for ['_:,sel,type] in argl]] - cmm := - fn := constructor? op => - p := pathname [fn,$spadLibFT,'"*"] => - isExistingFile p => getConstructorModemap(abbreviation? fn) - nil - nil - cmm is [[.,.,:argml],:.] => [op,:parseTypeEvaluateArgs(argl,argml)] - throwKeyedMsg("S2IL0015",[op]) - form - -parseTypeEvaluateArgs(argl,argml) == - [argVal for arg in argl for md in argml for i in 1..] where argVal() == - isCategoryForm(md,$CategoryFrame) => parseTypeEvaluate arg - arg - - -parseTypeError(x,md,i) == throwKeyedMsg("S2IP0003",[i,$op,md]) - -specialModeTran form == - form is [op,:argl] => - not ATOM op => form --added 10/5/84 by SCM - (s0:= (sop:= PNAME op).0) = "*" => - n:= #sop - n=1=> form - argKey:= sop.1 - numArgs:= #argl - (argKey="1" => 1; 0) - zeroOrOne:= argKey="0" or argKey="1" - isDmp := - numArgs < 10 => - n=6 and ('"DMP"=SUBSTRING(sop,3,3)) and zeroOrOne - true => - n=7 and ('"DMP"=SUBSTRING(sop,4,3)) and zeroOrOne - isDmp => - if argKey="0" then - extraDomain:= $EmptyMode - vl:= argl - else - [:vl,extraDomain] := argl - ["DistributedMultivariatePolynomial",["construct",:vl], - specialModeTran extraDomain] - n=4 and (s3:= sop.3) = "M" and zeroOrOne => - specialModeTran - extraDomain:= (argKey="0" => [$EmptyMode]; nil) - (n:= PARSE_-INTEGER PNAME sop.2)=1 => - ["SquareMatrix",:argl,:extraDomain] - n=2 => ["RectangularMatrix",:argl,:extraDomain] - form - isUpOrMp := - numArgs < 10 => - n=4 and (s3:= sop.3) = "P" and zeroOrOne or - n=5 and (s3:= sop.3)="R" and sop.4="F" and zeroOrOne - true => - n=5 and (s3:= sop.4) = "P" and zeroOrOne or - n=6 and (s3:= sop.4)="R" and sop.5="F" and zeroOrOne - isUpOrMp => - polyForm:= - domainPart:= (argKey="0" => $EmptyMode; last argl) - argPart:= (argKey="0" => argl; drop(-1,argl)) - numArgs < 10 and (n:= PARSE_-INTEGER PNAME sop.2)=1 - => ["UP",:argPart,domainPart] - ["MP",["construct",:argPart],domainPart] - specialModeTran - s3 = "R" => [$QuotientField,polyForm] - polyForm - [first form,:[specialModeTran x for x in rest form]] - [first form,:[specialModeTran x for x in rest form]] - form - -parseHas [x,y] == - if $InteractiveMode then - x:= - get(x,'value,$CategoryFrame) is [D,m,.] - and m in '((Mode) (Domain) (SubDomain (Domain))) => D - parseType x - mkand [["has",x,u] for u in fn y] where - mkand x == - x is [a] => a - ["and",:x] - fn y == - if $InteractiveMode then y:= unabbrevAndLoad y - y is [":" ,op,["Mapping",:map]] => - op:= (STRINGP op => INTERN op; op) - [["SIGNATURE",op,map]] - y is ["Join",:u] => "append"/[fn z for z in u] - y is ["CATEGORY",:u] => "append"/[fn z for z in u] - kk:= GETDATABASE(opOf y,'CONSTRUCTORKIND) - kk = "domain" or kk = "category" => [makeNonAtomic y] - y is ["ATTRIBUTE",:.] => [y] - y is ["SIGNATURE",:.] => [y] - $InteractiveMode => parseHasRhs y - [["ATTRIBUTE",y]] - -parseHasRhs u == --$InteractiveMode = true - get(u,'value,$CategoryFrame) is [D,m,.] - and m in '((Mode) (Domain) (SubDomain (Domain))) => m - y := abbreviation? u => - loadIfNecessary y => [unabbrevAndLoad y] - [["ATTRIBUTE",u]] - [["ATTRIBUTE",u]] - -parseDEF [$lhs,tList,specialList,body] == - setDefOp $lhs - ["DEF",parseLhs $lhs,parseTranList tList,parseTranList specialList, - parseTranCheckForRecord(body,opOf $lhs)] - -parseLhs x == - atom x => parseTran x - atom first x => [parseTran first x,:[transIs parseTran y for y in rest x]] - parseTran x - -parseMDEF [$lhs,tList,specialList,body] == - ["MDEF",parseTran $lhs,parseTranList tList,parseTranList specialList, - parseTranCheckForRecord(body,opOf $lhs)] - -parseTranCheckForRecord(x,op) == - (x:= parseTran x) is ["Record",:l] => - or/[y for y in l | y isnt [":",.,.]] => - postError ['" Constructor",:bright x,'"has missing label"] - x - x - -parseCases [expr,ifClause] == - casefn(expr,ifClause) where - casefn(x,ifExpr) == - ifExpr="noBranch" => ["ifClauseError",x] - ifExpr is ["IF",a,b,c] => ["IF",parseTran a,parseTran b,casefn(x,c)] - postError ['" CASES format error: cases ",x," of ",ifExpr] - -parseCategory x == - l:= parseTranList parseDropAssertions x - key:= - CONTAINED("$",l) => "domain" - "package" - ["CATEGORY",key,:l] - -parseDropAssertions x == ---note: the COPY of this list is necessary-- do not replace by RPLACing version - x is [y,:r] => - y is ["IF","asserted",:.] => parseDropAssertions r - [y,:parseDropAssertions r] - x - -parseGreaterThan [x,y] == - [substitute("<",">",$op),parseTran y,parseTran x] - -parseGreaterEqual u == parseTran ["not",[substitute("<",">=",$op),:u]] - -parseLessEqual u == parseTran ["not",[substitute(">","<=",$op),:u]] - -parseNotEqual u == parseTran ["not",[substitute("=","^=",$op),:u]] - -parseDollarGreaterThan [x,y] == - [substitute("$<","$>",$op),parseTran y,parseTran x] - -parseDollarGreaterEqual u == - parseTran ["not",[substitute("$<","$>=",$op),:u]] - -parseDollarLessEqual u == - parseTran ["not",[substitute("$>","$<=",$op),:u]] - -parseDollarNotEqual u == - parseTran ["not",[substitute("$=","$^=",$op),:u]] - -parseAnd u == - $InteractiveMode => ["and",:parseTranList u] - null u => "true" - null rest u => first u - parseIf [parseTran first u,parseAnd rest u,"false"] - -parseOr u == - $InteractiveMode => ["or",:parseTranList u] - null u => "false" - null rest u => first u - (x:= parseTran first u) is ["not",y] => parseIf [y,parseOr rest u,"true"] - true => parseIf [x,"true",parseOr rest u] - -parseNot u == - $InteractiveMode => ["not",parseTran first u] - parseTran ["IF",first u,:'(false true)] - -parseEquivalence [a,b] == parseIf [a,b,parseIf [b,:'(false true)]] - -parseImplies [a,b] == parseIf [a,b,"true"] - -parseExclusiveOr [a,b] == parseIf [a,parseIf [b,:'(false true)],b] - -parseExit [a,:b] == - -- note: I wanted to convert 1s to 0s here to facilitate indexing in - -- comp code; unfortunately, parseTran-ning is sometimes done more - -- than once so that the count can be decremented more than once - a:= parseTran a - b:= parseTran b - b => - null INTEGERP a => - (MOAN('"first arg ",a,'" for exit must be integer"); ["exit",1,a]) - ["exit",a,:b] - ["exit",1,a] - -parseLeave [a,:b] == - a:= parseTran a - b:= parseTran b - b => - null INTEGERP a => - (MOAN('"first arg ",a,'" for 'leave' must be integer"); ["leave",1,a]) - ["leave",a,:b] - ["leave",1,a] - -parseReturn [a,:b] == - a:= parseTran a - b:= parseTran b - b => - (if a^=1 then MOAN '"multiple-level 'return' not allowed"; ["return",1,:b]) - ["return",1,a] - -parseJoin l == - ["Join",:fn parseTranList l] where - fn l == - null l => nil - l is [["Join",:x],:y] => [:x,:fn y] - [first l,:fn rest l] - -parseInBy [i,n,inc] == - (u:= parseIn [i,n]) isnt ["STEP",i,a,j,:r] => - postError [" You cannot use",:bright '"by", - '"except for an explicitly indexed sequence."] - inc:= parseTran inc - ["STEP",i,a,parseTran inc,:r] - -parseSegment p == - p is [a,b] => - b => ["SEGMENT",parseTran a, parseTran b] - ["SEGMENT",parseTran a] - ["SEGMENT",:p] - -parseIn [i,n] == - i:= parseTran i - n:= parseTran n - n is ["SEGMENT",a] => ["STEP",i,a,1] - n is ["reverse",["SEGMENT",a]] => - postError ['" You cannot reverse an infinite sequence."] - n is ["SEGMENT",a,b] => (b => ["STEP",i,a,1,b]; ["STEP",i,a,1]) - n is ["reverse",["SEGMENT",a,b]] => - b => ["STEP",i,b,-1,a] - postError ['" You cannot reverse an infinite sequence."] - n is ["tails",s] => ["ON",i,s] - ["IN",i,n] - -parseIf t == - t isnt [p,a,b] => t - ifTran(parseTran p,parseTran a,parseTran b) where - ifTran(p,a,b) == - null($InteractiveMode) and p="true" => a - null($InteractiveMode) and p="false" => b - p is ["not",p'] => ifTran(p',b,a) - p is ["IF",p',a',b'] => ifTran(p',ifTran(a',COPY a,COPY b),ifTran(b',a,b)) - p is ["SEQ",:l,["exit",1,p']] => - ["SEQ",:l,["exit",1,ifTran(p',incExitLevel a,incExitLevel b)]] - --this assumes that l has no exits - a is ["IF", =p,a',.] => ["IF",p,a',b] - b is ["IF", =p,.,b'] => ["IF",p,a,b'] - makeSimplePredicateOrNil p is ["SEQ",:s,["exit",1,val]] => - parseTran ["SEQ",:s,["exit",1,incExitLevel ["IF",val,a,b]]] - ["IF",p,a,b] - -makeSimplePredicateOrNil p == - isSimple p => nil - u:= isAlmostSimple p => u - true => wrapSEQExit [["LET",g:= GENSYM(),p],g] - -parseWhere l == ["where",:mapInto(l, function parseTran)] - - -parseSeq l == - not l is [:.,["exit",:.]] => - postError ['" Invalid ending to block: ",last l] - transSeq mapInto(l,function parseTran) - -transSeq l == - null l => nil - null rest l => decExitLevel first l - [item,:tail]:= l - item is ["SEQ",:l,["exit",1,["IF",p,["exit", =2,q],"noBranch"]]] and - (and/[x is ["LET",:.] for x in l]) => - ["SEQ",:[decExitLevel x for x in l],["exit",1,["IF",decExitLevel p, - decExitLevel q,transSeq tail]]] - item is ["IF",a,["exit",1,b],"noBranch"] => - ["IF",decExitLevel a,decExitLevel b,transSeq tail] - item is ["IF",a,"noBranch",["exit",1,b]] => - ["IF",decExitLevel a,transSeq tail,decExitLevel b] - (y:= transSeq tail) is ["SEQ",:s] => ["SEQ",item,:s] - ["SEQ",item,["exit",1,incExitLevel y]] - -transCategoryItem x == - x is ["SIGNATURE",lhs,rhs] => - lhs is ["LISTOF",:y] => - "append" /[transCategoryItem ["SIGNATURE",z,rhs] for z in y] - atom lhs => - if STRINGP lhs then lhs:= INTERN lhs - rhs is ["Mapping",:m] => - m is [.,"constant"] => LIST ["SIGNATURE",lhs,[first m],"constant"] - LIST ["SIGNATURE",lhs,m] - $transCategoryAssoc:= [[lhs,:rhs],:$transCategoryAssoc] - NIL - [op,:argl]:= lhs - extra:= nil - if rhs is ["Mapping",:m] then - if rest m then extra:= rest m - --should only be 'constant' or 'variable' - rhs:= first m - LIST ["SIGNATURE",op,[rhs,:SUBLIS($transCategoryAssoc,argl)],:extra] - LIST x - -superSub(name,x) == - for u in x repeat y:= [:y,:u] - code:= - x is [[u]] => $quadSymbol - STRCONC("_(",scriptTranRow first x,scriptTran rest x,"_)") - [INTERNL(PNAME name,"$",code),:y] - -scriptTran x == - null x => "" - STRCONC(";",scriptTranRow first x,scriptTran rest x) - -scriptTranRow x == - null x => "" - STRCONC($quadSymbol,scriptTranRow1 rest x) - -scriptTranRow1 x == - null x => "" - STRCONC(",",$quadSymbol,scriptTranRow1 rest x) - -parseVCONS l == ["VECTOR",:parseTranList l] -@ - -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} -- cgit v1.2.3