path: root/src/interp/ptrees.boot

-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2011, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--     - Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
--
--     - Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in
--       the documentation and/or other materials provided with the
--       distribution.
--
--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
--       names of its contributors may be used to endorse or promote products
--       derived from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.



-- This file provides functions to create and examine abstract
-- syntax trees.  These are called pform, for short.
-- The definition of valid pforms see ABSTRACT BOOT.

-- !! This file also contains constructors for concrete syntax, although
-- !! they should be somewhere else.

-- THE PFORM DATA STRUCTURE
--  Leaves: [hd, tok, pos]
--  Trees:  [hd, tree, tree, ...]
--  hd is either an id or (id . alist)



import posit
import serror
namespace BOOT
module ptrees

--% This structure is incomplet
structure %Ast ==
  %Exist(%Vars,%Ast)
  %Forall(%Vars,%Ast)

--% SPECIAL NODES
pfListOf x          == pfTree('listOf,x)
pfListOf? x         == pfAbSynOp?(x,'listOf)
pfAppend ls ==
  ls isnt [l,:ls] => nil
  r := copyList l
  p := r
  repeat
    ls isnt [l,:ls] => return r
    l = nil => nil
    lastNode(p).rest := copyList l
    p := rest p

pfNothing ()        == pfTree('nothing, [])
pfNothing? form     == pfAbSynOp?(form, 'nothing)

-- SemiColon

pfSemiColon(pfbody) == pfTree('SemiColon, [pfbody])
pfSemiColon?(pf)    == pfAbSynOp? (pf, 'SemiColon)
pfSemiColonBody pf   == second pf       -- was ==>

--% Renaming.
--% We decided that the identifier "^" is syntactically synonymous to "**".
--% We could have banned the later and support only the former.
--% However, that would have made all exponentiation examples from
--% the Jenks&Sutor book invalid.  Which would be infortunate.
--% Rather, we opt to the renaming here.  This poses the danger that
--% any other AST scheme would need to do the same work.
--%     --gdr, 2009-10-08.
pfRename x ==
  x = "^" => "**"
  x

--% LEAVES
pfId(expr)               == pfLeaf('id, expr)
pfIdPos(expr,pos)        == pfLeaf('id,expr,pos)
pfId? form               ==
        pfAbSynOp?(form,'id) or pfAbSynOp?(form,'idsy)
pfSymbolVariable? form   == pfAbSynOp?(form,'idsy)
pfIdSymbol form          == pfRename tokPart form
--pfAmpersand(amptok,name) == name

pfDocument strings       == pfLeaf('Document, strings)
pfDocument? form         == pfAbSynOp?(form, 'Document)
pfDocumentText form      == tokPart form

pfDefinableName? form ==
  pfAbSynOp form in '(id integer)

pfLiteral? form ==
  pfAbSynOp form in '(integer symbol expression one zero char string float)

pfLiteralClass form      == pfAbSynOp form
pfLiteralString form     == tokPart form

pfStringConstString form     == tokPart form

pfExpression(expr, :optpos) ==
               pfLeaf("expression", expr, IFCAR optpos)
pfExpression? form          == pfAbSynOp?(form, 'expression)

pfSymbol(expr, :optpos) ==
               pfLeaf("symbol", expr, IFCAR optpos)

pfSymb(expr, :optpos) ==
         if pfLeaf? expr
         then pfSymbol(tokPart expr,IFCAR optpos)
         else pfExpression(pfSexpr expr,IFCAR optpos)

pfSymbol? form          == pfAbSynOp?(form, 'symbol)


pfSymbolSymbol form     == pfRename tokPart form

--% TREES
-- parser interface functions
-- these are potential sources of trouble in macro expansion

-- the comment is attached to all signatutres
pfWDec(doc,name)   == [pfWDeclare(i,doc) for i in pfParts name]

pfTweakIf form==
    a:=pfIfElse form
    b:=if pfNothing? a then pfListOf [] else a
    pfTree('WIf,[pfIfCond form,pfIfThen form,b])

pfInfApplication(op,left,right)==
   pfCheckInfop left =>
       pfWrong(pfDocument ['"infop as argument to infop"],pfListOf [])
   pfCheckInfop right =>
       pfWrong(pfDocument ['"infop as argument to infop"],pfListOf [])
   pfIdSymbol op = "and" => pfAnd (left,right)
   pfIdSymbol op = "or" => pfOr (left,right)
   pfApplication(pfRename op,pfTuple pfListOf [left,right])

pfCheckInfop form== false

pfAnd(pfleft, pfright) == pfTree('And, [pfleft, pfright])
pfAnd?(pf) == pfAbSynOp? (pf, 'And)
pfAndLeft pf == second pf       -- was ==>
pfAndRight pf == third pf       -- was ==>

pfOr(pfleft, pfright) == pfTree('Or, [pfleft, pfright])
pfOr?(pf) == pfAbSynOp? (pf, 'Or)
pfOrLeft pf == second pf       -- was ==>
pfOrRight pf == third pf       -- was ==>

pfNot(arg) == pfTree('Not, [arg])
pfNot?(pf) == pfAbSynOp? (pf, 'Not)
pfNotArg pf == second pf       -- was ==>

pfEnSequence a==
           if null a
           then  pfTuple pfListOf a
           else if null rest a
                then  first a
                else  pfSequence pfListOf a
pfFromDom(dom,expr)==
    if pfApplication? expr
    then pfApplication(pfFromdom(pfApplicationOp expr,dom),
                       pfApplicationArg expr)
    else pfFromdom(expr,dom)

pfReturnTyped(type,body)==pfTree('returntyped,[type,body])

pfLam(variable,body)==-- called from parser
    rets:= if pfAbSynOp?(body,'returntyped)
           then pfFirst body
           else pfNothing ()
    bdy:= if pfAbSynOp?(body,'returntyped) then pfSecond body else body
    pfLambda(variable,rets,bdy)

pfTLam(variable,body)==-- called from parser
    rets:= if pfAbSynOp?(body,'returntyped)
           then pfFirst body
           else pfNothing ()
    bdy:= if pfAbSynOp?(body,'returntyped) then pfSecond body else body
    pfTLambda(variable,rets,bdy)

pfIfThenOnly(pred,first)==pfIf(pred,first,pfNothing())

pfLp(iterators,body)==
       pfLoop pfListOf [:iterators,pfDo body]
pfLoop1 body == pfLoop pfListOf [pfDo body]


pfExitNoCond value== pfExit(pfNothing(),value)

pfReturnNoName(value)==pfReturn(value,pfNothing())

pfBrace(a,part)==pfApplication(pfIdPos( "{}",tokPosn a),part)

pfBracket(a,part) ==  pfApplication(pfIdPos( "[]",tokPosn a),part)
pfBraceBar(a,part)==pfApplication(pfIdPos( "{||}",tokPosn a),part)

pfBracketBar(a,part) ==  pfApplication(pfIdPos( "[||]",tokPosn a),part)
pfHide(a,part) ==   pfTree("Hide",[part])
pfHide? x== pfAbSynOp?(x,"Hide")
pfHidePart x== second x
pfParen(a,part)==part

pfPile(part)==part

pfSpread(l,t)==  [pfTyped(i,t) for i in l]

pfTupleList form== pfParts pfTupleParts form

--The rest have been generated from ABCUT INPUT
-- 1/31/89


--              Add         / Application  / Assign /
--              Coerceto    / Collect      / ComDefinition  / DeclPart /
--              Exit        / Export       / Free /
--              Fromdom     / Id           / If            / Inline /
--              Iterate     / Lambda /
--              Break       / Literal      / Local         / Loop   /
--              MLambda     / Pretend      / Restrict    / Return /
--              Sequence    / Tagged       / Tuple         / Typing /
--              Where       / With

pfExpr? pf ==
     pfAdd? pf or _
     pfApplication? pf or _
     pfAssign? pf or _
     pfCoerceto? pf or _
     pfCollect? pf or _
     pfComDefinition? pf or _
     pfDeclPart? pf or _
     pfExit? pf or _
     pfExport? pf or _
     pfFree? pf or _
     pfFromdom? pf or _
     pfId? pf or _
     pfIf? pf or _
     pfInline? pf or _
     pfIterate? pf or _
     pfLambda? pf or _
     pfBreak? pf or _
     pfLiteral? pf or _
     pfLocal? pf or _
     pfLoop? pf or _
     pfMLambda? pf or _
     pfPretend? pf or _
     pfRestrict? pf or _
     pfReturn? pf or _
     pfTagged? pf or _
     pfTuple? pf or _
     pfWhere? pf or _
     pfWith? pf


pfDeclPart? pf ==
     pfTyping? pf or _
     pfImport? pf or _
     pfDefinition? pf or _
     pfSequence? pf or _
     pfDWhere? pf or _
     pfMacro? pf


-- Wrong       := (Why: Document, Rubble: [Expr])

pfWrong(pfwhy, pfrubble) == pfTree('Wrong, [pfwhy, pfrubble])
pfWrong?(pf) == pfAbSynOp? (pf, 'Wrong)
pfWrongWhy pf == second pf       -- was ==>
pfWrongRubble pf == third pf       -- was ==>
pf0WrongRubble pf == pfParts pfWrongRubble pf


-- Add         := (Base: [Typed],  Addin: Expr)

pfAdd(pfbase, pfaddin,:addon) ==
    lhs := if addon
           then first addon
           else pfNothing()
    pfTree('Add, [pfbase, pfaddin,lhs])

pfAdd?(pf) == pfAbSynOp? (pf, 'Add)
pfAddBase pf == second pf       -- was ==>
pfAddAddin pf == third pf       -- was ==>
pfAddAddon pf == fourth pf       -- was ==>
pf0AddBase pf == pfParts pfAddBase pf



-- DWhere      := (Context: [DeclPart], Expr: [DeclPart])

pfDWhere(pfcontext, pfexpr) == pfTree('DWhere, [pfcontext, pfexpr])
pfDWhere?(pf) == pfAbSynOp? (pf, 'DWhere)
pfDWhereContext pf == second pf       -- was ==>
pfDWhereExpr pf == third pf       -- was ==>



-- With        := (Base: [Typed],  Within: [WithPart])

pfWith(pfbase, pfwithin) ==
         pfTree('With, [pfbase,pfwithin])
pfWith?(pf) == pfAbSynOp? (pf, 'With)
pfWithBase pf == second pf 
pfWithWithin pf == third pf
pf0WithBase pf == pfParts pfWithBase pf
pf0WithWithin pf == pfParts pfWithWithin pf


-- WIf         := (Cond: Primary, Then: [WithPart], Else: [WithPart])

pfWIf(pfcond, pfthen, pfelse) == pfTree('WIf, [pfcond, pfthen, pfelse])
pfWIf?(pf) == pfAbSynOp? (pf, 'WIf)
pfWIfCond pf == second pf       -- was ==>
pfWIfThen pf == third pf       -- was ==>
pfWIfElse pf == fourth pf       -- was ==>

-- WDeclare    := (Signature: Typed, Doc: ? Document)

pfWDeclare(pfsignature, pfdoc) == pfTree('WDeclare, [pfsignature, _
pfdoc])
pfWDeclare?(pf) == pfAbSynOp? (pf, 'WDeclare)
pfWDeclareSignature pf == second pf       -- was ==>
pfWDeclareDoc pf == third pf       -- was ==>


-- Attribute   := (Expr: Primary)

pfAttribute(pfexpr) == pfTree('%Attribute, [pfexpr])
pfAttribute?(pf) == pfAbSynOp? (pf, '%Attribute)
pfAttributeExpr pf == second pf       -- was ==>


-- Typed       := (Id: Id,    Type: ? Type)

pfTyped(pfid, pftype) == pfTree('Typed, [pfid, pftype])
pfTyped?(pf) == pfAbSynOp? (pf, 'Typed)
pfTypedId pf == second pf       -- was ==>
pfTypedType pf == third pf       -- was ==>


-- Application := (Op:   Expr, Arg:    Expr)

pfApplication(pfop, pfarg) ==
        pfTree('Application, [pfop, pfarg])

pfApplication?(pf) == pfAbSynOp? (pf, 'Application)
pfApplicationOp pf == second pf       -- was ==>
pfApplicationArg pf == third pf       -- was ==>


-- Tuple       := (Parts: [Expr])

pfTupleListOf(pfparts) == pfTuple pfListOf pfparts
pfTuple(pfparts) == pfTree("tuple", [pfparts])
pfTuple?(pf) == pfAbSynOp? (pf, "tuple")
pfTupleParts pf == second pf       -- was ==>
pf0TupleParts pf == pfParts pfTupleParts pf


-- Tagged      := (Tag:  Expr, Expr:   Expr)

pfTagged(pftag, pfexpr) == pfTree('Tagged, [pftag, pfexpr])
pfTagged?(pf) == pfAbSynOp? (pf, 'Tagged)
pfTaggedTag pf == second pf       -- was ==>
pfTaggedExpr pf == third pf       -- was ==>


-- Pretend     := (Expr: Expr, Type:   Type)

pfPretend(pfexpr, pftype) == pfTree('Pretend, [pfexpr, pftype])
pfPretend?(pf) == pfAbSynOp? (pf, 'Pretend)
pfPretendExpr pf == second pf       -- was ==>
pfPretendType pf == third pf       -- was ==>


-- Restrict    := (Expr: Expr, Type:   Type)

pfRestrict(pfexpr, pftype) == pfTree('Restrict, [pfexpr, pftype])
pfRestrict?(pf) == pfAbSynOp? (pf, 'Restrict)
pfRestrictExpr pf == second pf       -- was ==>
pfRestrictType pf == third pf       -- was ==>

pfRetractTo(pfexpr, pftype) == pfTree('RetractTo, [pfexpr, pftype])
pfRetractTo?(pf) == pfAbSynOp? (pf, 'RetractTo)
pfRetractToExpr pf == second pf       -- was ==>
pfRetractToType pf == third pf       -- was ==>


-- Coerceto    := (Expr: Expr, Type:   Type)

pfCoerceto(pfexpr, pftype) == pfTree('Coerceto, [pfexpr, pftype])
pfCoerceto?(pf) == pfAbSynOp? (pf, 'Coerceto)
pfCoercetoExpr pf == second pf       -- was ==>
pfCoercetoType pf == third pf       -- was ==>


-- Fromdom     := (What: Id,   Domain: Type)

pfFromdom(pfwhat, pfdomain) == pfTree('Fromdom, [pfwhat, pfdomain])
pfFromdom?(pf) == pfAbSynOp? (pf, 'Fromdom)
pfFromdomWhat pf == second pf       -- was ==>
pfFromdomDomain pf == third pf       -- was ==>


-- Lambda     := (Args: [Typed], Rets: ? Type, Body: Expr)

pfLambda(pfargs, pfrets, pfbody) == pfTree('Lambda, [pfargs, pfrets, _
pfbody])
pfLambda?(pf) == pfAbSynOp? (pf, 'Lambda)
pfLambdaArgs pf == second pf       -- was ==>
pfLambdaRets pf == third pf       -- was ==>
pfLambdaBody pf == fourth pf       -- was ==>
pf0LambdaArgs pf == pfParts pfLambdaArgs pf
pfFix pf== pfApplication(pfId "Y",pf)


-- TLambda      := (Args: [Typed], Rets: ? Type, Body: Expr)

pfTLambda(pfargs, pfrets, pfbody) == pfTree('TLambda, [pfargs, pfrets, pfbody])
pfTLambda?(pf) == pfAbSynOp? (pf, 'TLambda)
pfTLambdaArgs pf == second pf       -- was ==>
pfTLambdaRets pf == third pf       -- was ==>
pfTLambdaBody pf == fourth pf       -- was ==>
pf0TLambdaArgs pf == pfParts pfTLambdaArgs pf


-- MLambda     := (Args: [Id], Body: Expr)

pfMLambda(pfargs, pfbody) == pfTree('MLambda, [pfargs, pfbody])
pfMLambda?(pf) == pfAbSynOp? (pf, 'MLambda)
pfMLambdaArgs pf == second pf       -- was ==>
pfMLambdaBody pf == third pf       -- was ==>
pf0MLambdaArgs pf == pfParts pfMLambdaArgs pf


-- Where       := (Context: [DeclPart], Expr: Expr)

pfWhere(pfcontext, pfexpr) == pfTree('Where, [pfcontext, pfexpr])
pfWhere?(pf) == pfAbSynOp? (pf, 'Where)
pfWhereContext pf == second pf       -- was ==>
pfWhereExpr pf == third pf       -- was ==>
pf0WhereContext pf == pfParts pfWhereContext pf


-- If          := (Cond: Expr, Then: Expr, Else: ? Expr)

pfIf(pfcond, pfthen, pfelse) == pfTree('If, [pfcond, pfthen, pfelse])
pfIf?(pf) == pfAbSynOp? (pf, 'If)
pfIfCond pf == second pf       -- was ==>
pfIfThen pf == third pf       -- was ==>
pfIfElse pf == fourth pf       -- was ==>

-- %Match := (Expr: Expr, Alts: [Exit])

pfCase(pfexpr, pfalts) == pfTree("%Match",[pfexpr,pfalts])
pfCase? pf == pfAbSynOp?(pf,"%Match")
pfCaseScrutinee pf == second pf
pfCaseAlternatives pf == third pf

-- Sequence    := (Args: [Expr])

pfSequence(pfargs) == pfTree('%Sequence, [pfargs])
pfSequence?(pf) == pfAbSynOp? (pf, '%Sequence)
pfSequenceArgs pf == second pf       -- was ==>
pf0SequenceArgs pf == pfParts pfSequenceArgs pf


-- Novalue     := (Expr: Expr)

pfNovalue(pfexpr) == pfTree('Novalue, [pfexpr])
pfNovalue?(pf) == pfAbSynOp? (pf, 'Novalue)
pfNovalueExpr pf == second pf       -- was ==>


-- Loop        := (Iterators: [Iterator])

pfLoop(pfiterators) == pfTree('Loop, [pfiterators])
pfLoop?(pf) == pfAbSynOp? (pf, 'Loop)
pfLoopIterators pf == second pf       -- was ==>
pf0LoopIterators pf == pfParts pfLoopIterators pf


-- Collect     := (Body: Expr, Iterators: [Iterator])

pfCollect(pfbody, pfiterators) == pfTree('Collect, [pfbody, _
pfiterators])
pfCollect?(pf) == pfAbSynOp? (pf, 'Collect)
pfCollectBody pf == second pf       -- was ==>
pfCollectIterators pf == third pf       -- was ==>
pf0CollectIterators pf == pfParts pfCollectIterators pf


-- Forin       := (Lhs: [AssLhs], Whole: Expr)

pfForin(pflhs, pfwhole) == pfTree('Forin, [pflhs, pfwhole])
pfForin?(pf) == pfAbSynOp? (pf, 'Forin)
pfForinLhs pf == second pf       -- was ==>
pfForinWhole pf == third pf       -- was ==>
pf0ForinLhs pf == pfParts pfForinLhs pf


-- While       := (Cond: Expr)

pfWhile(pfcond) == pfTree('While, [pfcond])
pfWhile?(pf) == pfAbSynOp? (pf, 'While)
pfWhileCond pf == second pf       -- was ==>


-- Until       := (Cond: Expr)

--pfUntil(pfcond) == pfTree('Until, [pfcond])
--pfUntil?(pf) == pfAbSynOp? (pf, 'Until)
--pfUntilCond pf == second pf       -- was ==>


-- Suchthat    := (Cond: Expr)

pfSuchthat(pfcond) == pfTree('Suchthat, [pfcond])
pfSuchthat?(pf) == pfAbSynOp? (pf, 'Suchthat)
pfSuchthatCond pf == second pf       -- was ==>


-- Do          := (Body: Expr)

pfDo(pfbody) == pfTree('Do, [pfbody])
pfDo?(pf) == pfAbSynOp? (pf, 'Do)
pfDoBody pf == second pf       -- was ==>


-- Iterate     := (From: ? Id)

pfIterate(pffrom) == pfTree('Iterate, [pffrom])
pfIterate?(pf) == pfAbSynOp? (pf, 'Iterate)
pfIterateFrom pf == second pf       -- was ==>


-- Break       := (From: ? Id)

pfBreak(pffrom) == pfTree('Break, [pffrom])
pfBreak?(pf) == pfAbSynOp? (pf, 'Break)
pfBreakFrom pf == second pf       -- was ==>


-- Return      := (Expr: ? Expr, From: ? Id)

pfReturn(pfexpr, pffrom) == pfTree('Return, [pfexpr, pffrom])
pfReturn?(pf) == pfAbSynOp? (pf, 'Return)
pfReturnExpr pf == second pf       -- was ==>
pfReturnFrom pf == third pf       -- was ==>


-- Exit        := (Cond: ? Expr, Expr: ? Expr)

pfExit(pfcond, pfexpr) == pfTree('Exit, [pfcond, pfexpr])
pfExit?(pf) == pfAbSynOp? (pf, 'Exit)
pfExitCond pf == second pf       -- was ==>
pfExitExpr pf == third pf       -- was ==>


-- Macro       := (Lhs:  Id,     Rhs: ExprorNot)

pfMacro(pflhs, pfrhs) == pfTree('Macro, [pflhs, pfrhs])
pfMacro?(pf) == pfAbSynOp? (pf, 'Macro)
pfMacroLhs pf == second pf       -- was ==>
pfMacroRhs pf == third pf       -- was ==>


-- Definition  := (LhsItems:  [Typed], Rhs:  Expr)

pfDefinition(pflhsitems, pfrhs) == pfTree('Definition, [pflhsitems, pfrhs])
pfDefinition?(pf) == pfAbSynOp? (pf, 'Definition)
pfDefinitionLhsItems pf == second pf       -- was ==>
pfDefinitionRhs pf == third pf       -- was ==>
pf0DefinitionLhsItems pf == pfParts pfDefinitionLhsItems pf

pfRule(pflhsitems, pfrhs) == pfTree('Rule, [pflhsitems, _
pfrhs])
pfRule?(pf) == pfAbSynOp? (pf, 'Rule)
pfRuleLhsItems pf == second pf       -- was ==>
pfRuleRhs pf == third pf       -- was ==>

-- ComDefinition := (Doc:Document,Def:Definition)

pfComDefinition(pfdoc, pfdef) == pfTree('ComDefinition, [pfdoc, pfdef] )
pfComDefinition?(pf) == pfAbSynOp? (pf, 'ComDefinition)
pfComDefinitionDoc pf == second pf       -- was ==>
pfComDefinitionDef pf == third pf       -- was ==>


-- DefinitionSequence    := (Args: [DeclPart])

pfDefinitionSequenceArgs pf == second pf       -- was ==>

-- Export      := (Def:   Definition)

pfExportDef pf == second pf       -- was ==>

-- Assign      := (LhsItems:  [AssLhs], Rhs:  Expr)

pfAssign(pflhsitems, pfrhs) == pfTree('Assign, [pflhsitems, pfrhs])
pfAssign?(pf) == pfAbSynOp? (pf, 'Assign)
pfAssignLhsItems pf == second pf       -- was ==>
pfAssignRhs pf == third pf       -- was ==>
pf0AssignLhsItems pf == pfParts pfAssignLhsItems pf


-- Typing      := (Items: [Typed])

pfTyping(pfitems) == pfTree('Typing, [pfitems])
pfTyping?(pf) == pfAbSynOp? (pf, 'Typing)
pfTypingItems pf == second pf       -- was ==>
pf0TypingItems pf == pfParts pfTypingItems pf


-- Export       := (Items: [Typed])

pfExport(pfitems) == pfTree('Export, [pfitems])
pfExport?(pf) == pfAbSynOp? (pf, 'Export)
pfExportItems pf == second pf       -- was ==>
pf0ExportItems pf == pfParts pfExportItems pf


-- Local       := (Items: [Typed])

pfLocal(pfitems) == pfTree('Local, [pfitems])
pfLocal?(pf) == pfAbSynOp? (pf, 'Local)
pfLocalItems pf == second pf       -- was ==>
pf0LocalItems pf == pfParts pfLocalItems pf

-- Free        := (Items: [Typed])

pfFree(pfitems) == pfTree('Free, [pfitems])
pfFree?(pf) == pfAbSynOp? (pf, 'Free)
pfFreeItems pf == second pf       -- was ==>
pf0FreeItems pf == pfParts pfFreeItems pf


-- Import      := (Items: [QualType])

pfImport(pfitems) == pfTree('Import, [pfitems])
pfImport?(pf) == pfAbSynOp? (pf, 'Import)
pfImportItems pf == second pf       -- was ==>
pf0ImportItems pf == pfParts pfImportItems pf


-- Inline      := (Items: [QualType])

pfInline(pfitems) == pfTree('Inline, [pfitems])
pfInline?(pf) == pfAbSynOp? (pf, 'Inline)
pfInlineItems pf == second pf       -- was ==>
pf0InlineItems pf == pfParts pfInlineItems pf

-- QualType    := (Type: Type, Qual: ? Type)

pfQualType(pftype, pfqual) == pfTree('QualType, [pftype, pfqual])
pfQualType?(pf) == pfAbSynOp? (pf, 'QualType)
pfQualTypeType pf == second pf       -- was ==>
pfQualTypeQual pf == third pf       -- was ==>

pfSuch(x,y)== pfInfApplication(pfId "|",x,y)

pfTaggedToTyped x==
  rt:=if pfTagged? x then pfTaggedExpr x else pfNothing()
  form:= if pfTagged? x then pfTaggedTag x else x
  not pfId? form =>
      a:=pfId gensym()
      pfTyped(pfSuch(a,
           pfInfApplication (pfId "=", a,form)),rt)
  pfTyped(form,rt)

pfTaggedToTyped1 x==
    pfCollect1? x => pfCollectVariable1 x
    pfDefinition? x => pfTyped(x,pfNothing())
    pfTaggedToTyped x

pfCollectVariable1 x==
      a := pfApplicationArg x
      var:=first pf0TupleParts a
      id:=pfTaggedToTyped var
      pfTyped(pfSuch(pfTypedId id,second pf0TupleParts a),
              pfTypedType id)

pfPushBody(t,args,body)==
        if null args
        then  body
        else if null rest args
              then  pfLambda(first args,t,body)
              else
                 pfLambda(first args,pfNothing(),
                     pfPushBody(t,rest args,body))

pfCheckItOut x ==
  rt:=if pfTagged? x then pfTaggedExpr x else pfNothing()
  form:= if pfTagged? x then pfTaggedTag x else x
  pfDefinableName? form => [pfListOf [pfTyped(form,rt)],nil,rt]
  pfCollect1? form =>
                [pfListOf [pfCollectVariable1 form],nil,rt]
  pfTuple? form =>
       [pfListOf [pfTaggedToTyped i for i in pf0TupleParts form],nil,rt]
  pfDefinition? form =>
       [pfListOf [pfTyped(form,pfNothing())],nil,rt]
  pfApplication? form =>
          ls:=pfFlattenApp form
          op:= pfTaggedToTyped1 first ls
          args:=[pfTransformArg i for i in rest ls]
          [pfListOf [op],args,rt]
  npTrapForm form

pfCollect1? x==
        pfApplication? x =>
              a:=pfApplicationOp x
              pfId? a => pfIdSymbol a = "|"
              false
        false

pfTransformArg  args==
          argl:= if pfTuple? args then pf0TupleParts args else [args]
          pfListOf [pfTaggedToTyped1 i for i in argl]


pfCheckMacroOut form ==
  pfId? form => [form,nil]
  pfApplication? form =>
          ls:=pfFlattenApp form
          op:= pfCheckId first ls
          args:=[pfCheckArg i for i in rest ls]
          [op,args]
  npTrapForm form

pfCheckArg args==
          argl:= if pfTuple? args then pf0TupleParts args else [args]
          pfListOf [pfCheckId i for i in argl]

pfCheckId form==   if not pfId? form then npTrapForm(form) else form

pfPushMacroBody(args,body)==
    null args =>   body
    pfMLambda(first args,pfPushMacroBody(rest args,body))

pfFlattenApp x==
   pfApplication? x=>
             pfCollect1? x =>[ x ]
             append (pfFlattenApp pfApplicationOp x,
                        pfFlattenApp pfApplicationArg x)
   [x]


--% Utility operations on Abstract Syntax Trees
 
-- An S-expression which people can read.
pfSexpr pform ==
    strip pform where
         strip pform ==
            pfId? pform       => pfIdSymbol pform
            pfLiteral?  pform => pfLiteralString pform
            pfLeaf? pform     => tokPart pform
 
            pfApplication? pform =>
                args :=
                    a := pfApplicationArg pform
                    if pfTuple? a then pf0TupleParts a else [a]
                [strip p for p in [pfApplicationOp pform, :args]]
 
            [pfAbSynOp pform, :[strip p for p in pfParts pform]]
 
pfCopyWithPos( pform , pos ) == 
    pfLeaf? pform =>         pfLeaf( pfAbSynOp pform , tokPart pform , pos )
    pfTree( pfAbSynOp pform , [ pfCopyWithPos( p , pos ) for p in pfParts pform ] )
 
pfMapParts(f, pform) ==
    pfLeaf? pform => pform
    parts0 := pfParts pform
    parts1 := [apply(f,[p]) for p in parts0]
    -- Return the original if no changes.
    same := true
    for p0 in parts0 for p1 in parts1 while same repeat same := sameObject?(p0,p1)
    same => pform
    pfTree(pfAbSynOp pform, parts1)
 
 
pf0ApplicationArgs pform ==
    arg := pfApplicationArg pform
    pf0FlattenSyntacticTuple arg
 
pf0FlattenSyntacticTuple pform ==
    not pfTuple? pform => [pform]
    [:pf0FlattenSyntacticTuple p for p in pf0TupleParts pform]