\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>>=
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>>= 
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}
<<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.

@

<<*>>=
<<license>>

)package "BOOT"

--% Transformation of Parser Output
 
<<parseTransform>>
<<parseTran>>

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}