-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2012, 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 ggreater
import sys_-macros
import daase
namespace BOOT

module g_-util where
  abstraction?: %Form -> %Boolean
  getTypeOfSyntax: %Form -> %Mode
  pairList: (%List %Form,%List %Form) -> %List %Pair(%Form,%Form)
  mkList: %List %Form -> %Form
  isSubDomain: (%Mode,%Mode) -> %Form
  isDefaultPackageName: %Symbol -> %Boolean
  makeDefaultPackageName: %String -> %Symbol
  spliceSeqArgs: %List %Code -> %Code
  mkSeq: %List %Code -> %Code
  usesVariable?: (%Code,%Symbol) -> %Boolean

--%

++ Data structure holding a information about capsule-level function
++ specification.
structure %FunctionContext ==
  Record(db: %Maybe %Database, op: %Identifier, sig: %Signature,
    pred: %Predicate) with
        fcDatabase == (.db)
        fcOperator == (.op)
        fcSignature == (.sig)
        fcPredicate == (.pred)

--%

abstraction? x ==
  x is [op,:.] and ident? op and abstractionOperator? op

bindingForm? x ==
  x is [op,:.] and ident? op and op in '(%bind LET)

++ Return true if `form' uses symbol `var'.
usesVariable?(form,var) ==
  symbol? form => symbolEq?(form,var)
  atomic? form => false
  abstraction? form =>
    not symbolMember?(var,form.absParms) and usesVariable?(form.absBody,var)
  form.op is [.,:.] and usesVariable?(form.op,var) => true
  bindingForm? form =>
    x := 
      or/[usesVariable?(second parm,var)
           or symbolEq?(first parm,var) and leave 'bound
             for parm in form.absParms]
    x is 'bound => false
    x or usesVariable?(form.absBody,var)
  -- a variable can be used only in argument position.
  or/[usesVariable?(x,var) for x in form.args]

hasNoLeave?(expr,g) ==
  atomic? expr => true
  expr is ['%leave, =g,:.] => false
  hasNoLeave?(first expr,g) and hasNoLeave?(rest expr,g)

mkScope(tag,expr) ==
  expr is ['%leave,=tag,expr'] and hasNoLeave?(expr',tag) => expr'
  expr is ['%bind,inits,expr'] and hasNoLeave?(inits,tag) =>
    mkBind(inits,mkScope(tag,expr'))
  hasNoLeave?(expr,tag) => expr
  ['%scope,tag,expr]

mkBind(inits,expr) ==
  expr is ['%leave,tag,expr'] =>
    ['%leave,tag,mkBind(inits,expr')]
  expr is ['%bind,inits',expr'] =>
    mkBind([:inits,:inits'],expr')
  ['%bind,inits,expr]

mkSeq stmts ==
  stmts is [s] => s
  ['%seq,:stmts]

++ Given a (possibly multiple) assignment expression `u', return
++ the list of all assignment sub-expressions that must be evaluated before
++ effecting the toplevel assignment indicated by `u'.  In that case,
++ modify `u' in place to reflect the new right-hand-side.
splitAssignments! u == main(u,nil) where
   main(u,l) ==
     u is ['%LET,x,v] =>
       v is ['%LET,y,.] =>
         second(u.args) := y
         [:main(v,l),v]
       [:liftAssignments! v,:l]
     l

liftAssignments! x ==
  x is ['%call,:.] => [:lift! for args in tails x.args] where
    lift!() ==
      s := first args
      atomic? s => nil
      s is ['%LET,y,:.] =>
        args.first := y
        [:splitAssignments! s,s]
      splitAssignments! s
  splitAssignments! x

++ We have a list `l' of expressions to be executed sequentially.
++ Splice in any directly-embedded sequence of expressions.
++ NOTES: This function should not be called on any program with
++        an %exit-form in it.  In particular, it should be called
++        (if at all) before any call to simplifyVMForm.
spliceSeqArgs l ==
  l = nil => l
  s := first l
  s is ['%seq,:.] =>
    stmts := spliceSeqArgs s.args
    stmts = nil => spliceSeqArgs rest l
    lastNode(stmts).rest := spliceSeqArgs rest l
    stmts
  s is ['%scope,tag,['%seq,:ys,['%leave,=tag,z]]] and hasNoLeave?(ys,tag) =>
    stmts := spliceSeqArgs [:ys,z]
    lastNode(stmts).rest := spliceSeqArgs rest l
    stmts
  s is [op,:.] and op in '(%LET %call) and (stmts := liftAssignments! s) =>
    lastNode(stmts).rest := [s,:spliceSeqArgs rest l]
    stmts
  rest l = nil => l
  l.rest := spliceSeqArgs rest l
  l

++ Apply the function `f' on all non-atomic subforms of `x' in
++ depth-first walk.  Mutate `x' in place, replacing each sub-form
++ with the result of applying `f' to that subform.
walkWith!(x,f) ==
  atomic? x => x
  abstraction? x =>
    x.absBody := walkWith!(x.absBody,f)
    x
  for ys in tails x | not atomic? first ys repeat
    ys.first := walkWith!(first ys,f)
  apply(f,[x])

prefixWalk!(x,f) ==
  atomic? x => x
  x := apply(f,[x])
  atomic? x => x
  for xs in tails x | not atomic? first xs repeat
    xs.first := prefixWalk!(first xs,f)
  x

listify x ==
  x is [.,:.] => x
  [x]

--%

++ List of category constructors that do not have entries in the 
++ constructor database. So, they are mostly recognized by their names.
$CategoryNames ==
  '(CATEGORY _
    RecordCategory _
    Join _
    EnumerationCategory _
    SubsetCategory _
    UnionCategory _
    MappingCategory)

macro builtinCategoryName? x ==
  symbolMember?(x,$CategoryNames)

++ List of domain constructors that do not have entries in the constructor
++ database. So, they are mostly recognized by their names.
++ See also $CategoryNames.
$DomainNames ==
  '(Mapping _
    SubDomain _
    Union _
    Record _
    Enumeration _
    Cross)

macro builtinFunctorName? x ==
  symbolMember?(x,$DomainNames)

++ The collection of builtin category names and builtin domain names.
$BuiltinConstructorNames ==
  [:$CategoryNames,:$DomainNames]

++ Return true if the symbol `s' designates a builtin constructor.
macro builtinConstructor? s ==
  symbolMember?(s,$BuiltinConstructorNames)

--%  

$AbstractionOperator ==
  '(LAM ILAM XLAM LAMBDA %lambda %slam)

++ Return the character designated by the string `s'.
stringToChar: %String -> %Char
stringToChar s ==
  #s = 1 => stringChar(s,0)
  s = '"\a" => $Bell
  s = '"\n" => $Newline
  s = '"\f" => $FormFeed
  s = '"\r" => $CarriageReturn
  s = '"\b" => $Backspace
  s = '"\t" => $HorizontalTab
  s = '"\v" => $VerticalTab
  error strconc('"invalid character designator: ", s)
  
++
$interpOnly := false

--% Utility Functions of General Use

mkCacheName(name) ==
  makeSymbol strconc(symbolName name,'";AL")

mkAuxiliaryName(name) ==
  makeSymbol strconc(symbolName name,'";AUX")


homogeneousListToVector(t,l) ==
  makeSimpleArrayFromList(t,l)


++ tests if x is an identifier beginning with #
isSharpVar x ==
  ident? x and stringChar(symbolName x,0) = char "#"

++ If `x' is a formal variable, return its numeral position.
++ Otherwise return nil.
formalVarNumber x ==
  not isSharpVar x => nil
  readIntegerIfCan subsString(symbolName x,1)

isSharpVarWithNum x ==
  not isSharpVar x => nil
  p := symbolName x
  (n := #p) < 2 => nil
  ok := true
  c := 0
  for i in 1..(n-1) while ok repeat
    d := stringChar(p,i)
    ok := digit? d => c := 10*c + DIG2FIX d
  if ok then c else nil


mkBuffer v ==
  [copyVector v,:#v]

macro bufferData buf ==
  first buf

macro bufferLength buf ==
  rest buf

macro bufferRef(buf,i) ==
  vectorRef(bufferData buf,i)

resizeBuffer(buf,n) ==
  #bufferData buf >= n =>
    bufferLength(buf) := n
    buf
  v := mkVector(2 * n)
  for i in 0..(bufferLength buf - 1) repeat
    vectorRef(v,i) := vectorRef(bufferData buf,i)
  bufferData(buf) := v
  bufferLength(buf) := n
  buf

bufferToVector buf ==
  n := bufferLength buf
  v := mkVector n
  for i in 0..(n-1) repeat
    vectorRef(v,i) := vectorRef(bufferData buf,i)
  v


++ Return the name of a relative path for a directory
++ given by the string `s',  GCL does not implement
++ Common Lisp semantics, so we have a special version for it.
relativeDirname s ==
)if %hasFeature &GCL and not %hasFeature &COMMON_-LISP
  [s]
)else
  [&RELATIVE,s]
)endif

--% Sub-domains information handlers

++ If `dom' is a subdomain, return its immediate super-domain.  
superType: %Mode -> %Maybe %Mode
superType dom ==
  dom = "$" => superType $functorForm
  dom isnt [ctor,:args] => nil
  builtinConstructor? ctor => nil
  [super,.] :=
    db := constructorDB ctor or return nil
    dbBeingDefined? db => dbSuperDomain db or return nil
    dbConstructorKind db is 'domain or return nil
    --dbSuperDomain loadDBIfNecessary db or return nil
    getSuperDomainFromDB ctor or return nil
  sublisFormal(args,super,$AtVariables)

++ If the domain designated by the domain form `dom' is a subdomain,
++ then return its defining predicate.  Otherwise, return nil.
domainVMPredicate dom ==
  dom = "$" => domainVMPredicate $functorForm
  dom isnt [ctor,:args] => false
  [.,pred] := getSuperDomainFromDB ctor or return nil
  sublisFormal(args,pred,$AtVariables)

++ Return the root of the reflexive transitive closure of
++ the super-domain chain for the domain designated by the domain 
++ form `d'.
maximalSuperType: %Mode -> %Mode
maximalSuperType d ==
  d' := superType d => maximalSuperType d'
  d

++ Note that the functor `sub' instantiates to domains that
++ are subdomains of `super' instances restricted by the 
++ predicate `pred'.
noteSubDomainInfo: (%Symbol,%Instantiation,%Form) -> %Thing
noteSubDomainInfo(sub,super,pred) ==
  SETDATABASE(sub,"SUPERDOMAIN",[super,pred])

++ Returns non-nil if `d1' is a sub-domain of `d2'.  This is the
++ case when `d1' is transitively given by an instance of SubDomain
++    d1 == SubDomain(d2,pred)
++ The transitive closure of the predicate form is returned, where 
++ the predicate parameter is `#1'.
isSubDomain(d1,d2) ==
  d1 isnt [.,:.] or d2 isnt [.,:.] => false

  -- 1.  Easy, if by syntax constructs.
  d1 is ["SubDomain",=d2,pred] => pred

  -- 2.  Just say no, if there is no hope.
  [sup,pred] := getSuperDomainFromDB first d1 or return false

  -- 3.  We may be onto something.
  -- `sup' and `pred' are in most general form.  We cannot just
  -- test for the functors, as different arguments may instantiate
  -- to super-domains.  
  args := rest d1
  sublisFormal(args,sup,$AtVariables) = d2 => 
    sublisFormal(args,pred,$AtVariables)

  -- 4.  Otherwise, lookup in the super-domain chain.
  pred' := isSubDomain(sup,d2) => 
    ['%and,pred',sublisFormal(args,pred,$AtVariables)]

  -- 5.  Lot of smoke, no fire.
  false

--%

mkList u ==
  u => ['%list,:u]
  nil

ELEMN(x, n, d) ==
  null x => d
  n = 1 => first x
  ELEMN(rest x, n-1, d)

PPtoFile(x, fname) ==
    stream := DEFIOSTREAM([['MODE, :'OUTPUT], ['FILE, :fname]], 80, 0)
    PRETTYPRINT(x, stream)
    SHUT stream
    x

ScanOrPairVec(f, ob) ==
    $seen:     local := hashTable 'EQ
 
    CATCH('ScanOrPairVecAnswer, ScanOrInner(f, ob)) where
        ScanOrInner(f, ob) ==
            tableValue($seen, ob) => nil
            cons? ob =>
                tableValue($seen, ob) := true
                ScanOrInner(f, first ob)
                ScanOrInner(f, rest ob)
                nil
            vector? ob =>
                tableValue($seen, ob) := true
                for i in 0..#ob-1 repeat ScanOrInner(f, ob.i)
                nil
            apply(f,[ob]) =>
                THROW('ScanOrPairVecAnswer, true)
            nil


++ Query properties for an entity in a given environment.
get: (%Thing,%Symbol,%Env) -> %Thing
get0: (%Thing,%Symbol,%Env) -> %Thing
get1: (%Thing,%Symbol,%Env) -> %Thing
get2: (%Thing,%Symbol) -> %Thing

get(x,prop,e) ==
  $InteractiveMode => get0(x,prop,e)
  get1(x,prop,e)

get0(x,prop,e) ==
  cons? x => get0(x.op,prop,e)
  u := symbolTarget(x,first first e) => symbolTarget(prop,u)
  (tail := rest first e) and (u := fastSearchCurrentEnv(x,tail)) =>
    symbolTarget(prop,u)
  nil

get1(x,prop,e) ==
  cons? x => get1(x.op,prop,e)
  prop = "modemap" and $insideCapsuleFunctionIfTrue =>
    symbolTarget("modemap",getProplist(x,$CapsuleModemapFrame))
      or get2(x,prop)
  symbolTarget(prop,getProplist(x,e)) or get2(x,prop)

get2(x,prop) ==
  prop = "modemap" and ident? x and constructor? x =>
    (u := getConstructorModemap x) => [u]
    nil
  nil

++ Update properties of an entity in an environment.
put: (%Thing,%Symbol,%Thing,%Env) -> %Env
addBinding: (%Thing,%List %Thing,%Env) -> %Env
addBindingInteractive: (%Thing, %List %Thing, %Env) -> %Env
augProplistOf: (%Thing,%Symbol,%Thing,%Env) -> %List %Thing
augProplist: (%List %Thing,%Symbol,%Thing) -> %List %Thing
augProplistInteractive: (%List %Thing,%Symbol,%Thing) -> %List %Thing
putIntSymTab: (%Thing,%Symbol,%Form,%Env) -> %Env
addIntSymTabBinding: (%Thing,%List %Thing,%Env) -> %Env

put(x,prop,val,e) ==
  $InteractiveMode and not sameObject?(e,$CategoryFrame) =>
    putIntSymTab(x,prop,val,e)
  --e must never be $CapsuleModemapFrame
  cons? x => put(first x,prop,val,e)
  newProplist := augProplistOf(x,prop,val,e)
  prop="modemap" and $insideCapsuleFunctionIfTrue =>
    SAY ["**** modemap PUT on CapsuleModemapFrame: ",val]
    $CapsuleModemapFrame:=
      addBinding(x,augProplistOf(x,"modemap",val,$CapsuleModemapFrame),
        $CapsuleModemapFrame)
    e
  addBinding(x,newProplist,e)

putIntSymTab(x,prop,val,e) ==
  cons? x => putIntSymTab(first x,prop,val,e)
  pl0 := pl := search(x,e)
  pl :=
    null pl => [[prop,:val]]
    u := objectAssoc(prop,pl) =>
      u.rest := val
      pl
    lp := lastNode pl
    u := [[prop,:val]]
    lp.rest := u
    pl
  sameObject?(pl0,pl) => e
  addIntSymTabBinding(x,pl,e)

addIntSymTabBinding(var,proplist,e is [[curContour,:.],:.]) ==
  -- change proplist of var in e destructively
  u := objectAssoc(var,curContour) =>
    u.rest := proplist
    e
  first(e).first := [[var,:proplist],:curContour]
  e

putMacro(lhs,rhs,e) ==
  lhs isnt [.,:.] => put(lhs,"macro",rhs,e)
  parms := [gensym() for p in lhs.args]
  put(lhs.op,"macro",
    ['%mlambda,parms,applySubst(pairList(lhs.args,parms),rhs)],e)

--% Syntax manipulation

++ Build a quasiquotation form for `x'.
quasiquote x ==
  ["[||]",x]

++ Extract the quoted form, otherwise return nil
isQuasiquote m ==
  m is ["[||]",y] => y


++ returns the inferred domain for the syntactic object t.
getTypeOfSyntax t ==
  t isnt [.,:.] => 
    ident? t => '(Identifier)
    (m := getBasicMode t) and not member(m,[$EmptyMode,$NoValueMode]) =>
      ["Literal",m]
    $Syntax
  [op,:.] := t
  op = "Mapping" => '(MappingAst)
  op = 'QUOTE and #t = 2 and ident? second t => ["Literal",$Symbol]
  op = "IF" => '(IfAst)
  op = "REPEAT" => '(RepeatAst)
  op = "WHILE" => '(WhileAst)
  op = "IN" => '(InAst)
  op = "COLLECT" => '(CollectAst)
  op = "construct" => '(ConstructAst)
  op = "exit" => '(ExitAst)
  op = "return" => '(ReturnAst)
  op = "SEGMENT" => '(SegmentAst)
  op = "SEQ" => '(SequenceAst)
  op = "pretend" => '(PretendAst)
  op = "::" => '(CoerceAst)
  op = "@" => '(RestrictAst)
  op = "%LET" or op = ":=" => '(LetAst)
  op = "|" => '(SuchThatAst)
  op = ":" => '(ColonAst)
  op = ":=" => '(LetAst)
  op = "%Comma" => '(CommaAst)
  op = "case" => '(CaseAst)
  op = "has" => '(HasAst)
  op = "is" => '(IsAst)
  op = "DEF" => '(DefinitionAst)
  op in '(MDEF %Macro) => '(MacroAst)
  op = "where" => '(WhereAst)
  op in '(ATTRIBUTE %Attribute) => '(AttributeAst)
  op = "Join" => '(JoinAst)
  op = "CAPSULE" => '(CapsuleAst)
  op in '(%Import import) => '(ImportAst)
  op in '(%Signature SIGNATURE) => '(SignatureAst)
  op = "CATEGORY" => '(CategoryAst)
  op = "where" => '(WhereAst)
  op = "[||]" => '(QuasiquoteAst)
  $Syntax

--%

-- Convert an arbitrary lisp object to canonical boolean.
bool: %Thing -> %Boolean
bool x ==
    null null x

++ Return true is the form `x' is a predicate known to always
++ evaluate to true.
TruthP x ==
  x = nil or x = '%false => false
  x = true or x = '%true => true
  x is ['QUOTE,:.] => true
  false

--% Record and Union utils.

stripTags doms ==
  [if dom is [":",.,dom'] then dom' else dom for dom in doms]

isTaggedUnion u ==
  u is ['Union,:tl] and tl and first tl is [":",.,.] and true

getUnionOrRecordTags u ==
  tags := nil
  if u is ['Union, :tl] or u is ['Record, :tl] then
      for t in tl repeat
         if t is [":",tag,.] then tags := [tag, :tags]
  tags

--% Various lispy things

Identity x == x

length1? l == cons? l and not cons? rest l

length2? l == cons? l and cons? (l := rest l) and not cons? rest l

pairList(u,v) == [[x,:y] for x in u for y in v]

-- GETALIST(alist,prop) == IFCDR assoc(prop,alist)
GETALIST(alist,prop) == rest assoc(prop,alist)

PUTALIST(alist,prop,val) ==
  null alist => [[prop,:val]]
  pair := assoc(prop,alist) =>
    rest pair = val => alist
    -- else we fall over Lucid's read-only storage feature again
    pair.rest := val
    alist
  lastNode(alist).rest := [[prop,:val]]
  alist

REMALIST(alist,prop) ==
  null alist => alist
  alist is [[ =prop,:.],:r] =>
    null r => nil
    alist.first := first r
    alist.rest := rest r
    alist
  null rest alist => alist
  l := alist
  ok := true
  while ok repeat
    [.,[p,:.],:r] := l
    p = prop =>
      ok := nil
      l.rest := r
    if null (l := rest l) or null rest l then ok := nil
  alist

deleteLassoc(x,y) ==
  y is [[a,:.],:y'] =>
    sameObject?(x,a) => y'
    [first y,:deleteLassoc(x,y')]
  y

--% association list functions

deleteAssoc(x,y) ==
  y is [[a,:.],:y'] =>
   a=x => deleteAssoc(x,y')
   [first y,:deleteAssoc(x,y')]
  y

deleteAssocWOC(x,y) ==
  null y => y
  [[a,:.],:t]:= y
  x=a => t
  (fn(x,y);y) where fn(x,y is [h,:t]) ==
    t is [[a,:.],:t1] =>
      x=a => y.rest := t1
      fn(x,t)
    nil

insertWOC(x,y) ==
  null y => [x]
  (fn(x,y); y) where fn(x,y is [h,:t]) ==
    x=h => nil
    null t =>
      y.rest := [h,:t]
      y.first := x
    fn(x,t)


++ Post-compose substitution `subst' with `s +-> v'
postComposeSubst(subst,s,v) ==
  [[x,:substitute(v,s,y)] for [x,:y] in subst]

--% Miscellaneous Functions for Working with Strings

fillerSpaces(n,charPart == char " ") ==
  n <= 0 => '""
  makeString(n,charPart)

centerString(text,width,fillchar) ==
  wid := entryWidth text
  wid >= width => text
  f := DIVIDE(width - wid,2)
  fill1 := ""
  for i in 1..(f.0) repeat
    fill1 := strconc(fillchar,fill1)
  fill2:= fill1
  if f.1 ~= 0 then fill1 := strconc(fillchar,fill1)
  [fill1,text,fill2]

stringChar2Integer(str,pos) ==
  -- returns small integer represented by character in position pos
  -- in string str. Returns nil if not a digit or other error.
  if ident? str then str := symbolName str
  not (string?(str) and
    integer?(pos) and (pos >= 0) and (pos < #str)) => nil
  not digit?(d := stringChar(str,pos)) => nil
  DIG2FIX d

dropLeadingBlanks str ==
  str := object2String str
  l := # str
  nb := nil
  i := 0
  while (i < l) and nb = nil repeat
    if stringChar(str,i) ~= char " " then nb := i
    else i := i + 1
  nb = 0 => str
  nb => subString(str,nb)
  '""

concat(:l) == concatList l

concatList [x,:y] ==
  null y => x
  null x => concatList y
  concat1(x,concatList y)

concat1(x,y) ==
  null x => y
  x isnt [.,:.] => (null y => x; y isnt [.,:.] => [x,y]; [x,:y])
  null y => x
  y isnt [.,:.] => [:x,y]
  [:x,:y]

--% BOOT ravel and reshape

ravel a == a

reshape(a,b) == a

--% Some functions for algebra code

boolODDP x == ODDP x

--% Miscellaneous

freeOfSharpVars x ==
  x isnt [.,:.] => not isSharpVarWithNum x
  freeOfSharpVars first x and freeOfSharpVars rest x

listOfSharpVars x ==
  x isnt [.,:.] => (isSharpVarWithNum x => [x]; nil)
  setUnion(listOfSharpVars first x,listOfSharpVars rest x)

listOfPatternIds x ==
  isPatternVar x => [x]
  x isnt [.,:.] => nil
  x is ['QUOTE,:.] => nil
  setUnion(listOfPatternIds first x,listOfPatternIds rest x)

isPatternVar v ==
  -- a pattern variable consists of a star followed by a star or digit(s)
  ident?(v) and v in '(_*_* _*1 _*2 _*3 _*4 _*5 _*6 _*7 _*8 _*9 _*10
    _*11 _*12 _*13 _*14 _*15 _*16 _*17 _*18 _*19 _*20) and true

removeZeroOne x ==
  -- replace all occurrences of (Zero) and (One) with
  -- 0 and 1
  x = $Zero => 0
  x = $One => 1
  x isnt [.,:.] => x
  [removeZeroOne first x,:removeZeroOne rest x]

removeZeroOneDestructively t ==
  -- replace all occurrences of (Zero) and (One) with
  -- 0 and 1 destructively
  t = $Zero => 0
  t = $One => 1
  t isnt [.,:.] => t
  RPLNODE(t,removeZeroOneDestructively first t,
    removeZeroOneDestructively rest t)

flattenSexpr s ==
  null s => s
  s isnt [.,:.] => s
  [f,:r] := s
  f isnt [.,:.] => [f,:flattenSexpr r]
  [:flattenSexpr f,:flattenSexpr r]

isLowerCaseLetter c ==
  lowerCase? c

isUpperCaseLetter c ==
  upperCase? c

isLetter c ==
  alphabetic? c

--% Inplace Merge Sort for Lists
-- MBM April/88

-- listSort(pred,list) or listSort(pred,list,key)
-- the pred function is a boolean valued function defining the ordering
-- the key function extracts the key from an item for comparison by pred

listSort(pred,list,:optional) ==
   not functionp pred => error "listSort: first arg must be a function"
   not LISTP list => error "listSort: second argument must be a list"
   optional = nil => mergeSort(pred,function Identity,list,# list)
   key := first optional
   not functionp key => error "listSort: last arg must be a function"
   mergeSort(pred,key,list,# list)

-- non-destructive merge sort using NOT GGREATERP as predicate
MSORT list == listSort(function GLESSEQP, copyList list)

-- destructive merge sort using NOT GGREATERP as predicate
NMSORT list == listSort(function GLESSEQP, list)

-- non-destructive merge sort using ?ORDER as predicate
orderList l == listSort(function _?ORDER, copyList l)

-- dummy defn until clean-up
-- order     l == orderList l

mergeInPlace(f,g,p,q) ==
   -- merge the two sorted lists p and q
   if null p then return p
   if null q then return q
   if apply(f,[apply(g,[first p]),apply(g,[first q])])
   then (r := t := p; p := rest p)
   else (r := t := q; q := rest q)
   while not null p and not null q repeat
      if apply(f,[apply(g,[first p]),apply(g,[first q])])
      then (t.rest := p; t := p; p := rest p)
      else (t.rest := q; t := q; q := rest q)
   if null p then t.rest := q else t.rest := p
   r

mergeSort(f,g,p,n) ==
   if n=2 and apply(f,[apply(g,[second p]),apply(g,[first p])]) then
      t := p
      p := rest p
      p.rest := t
      t.rest := nil
   if n < 3 then return p
   -- split the list p into p and q of equal length
   l := n quo 2
   t := p
   for i in 1..l-1 repeat t := rest t
   q := rest t
   t.rest := nil
   p := mergeSort(f,g,p,l)
   q := mergeSort(f,g,q,n-l)
   mergeInPlace(f,g,p,q)

--% Throwing with glorious highlighting (maybe)

spadThrow() ==
  if $interpOnly and $mapName then
    putHist($mapName,'localModemap, nil, $e)
  THROW($SpadReaderTag,nil)

spadThrowBrightly x ==
  sayBrightly x
  spadThrow()

sublisNQ(al,e) ==
  al isnt [.,:.] => e
  fn(al,e) where fn(al,e) ==
    e isnt [.,:.] =>
      for x in al repeat
        sameObject?(first x,e) => return (e := rest x)
      e
    sameObject?(a := first e,'QUOTE) => e
    u := fn(al,a)
    v := fn(al,rest e)
    sameObject?(a,u) and sameObject?(rest e,v) => e
    [u,:v]

opOf: %Thing -> %Thing
opOf x ==
  cons? x => x.op
  x

getProplist: (%Thing,%Env) -> %List %Thing
search: (%Thing,%Env) -> %List %Thing
searchCurrentEnv: (%Thing,%List %Thing) -> %List %Thing
searchTailEnv: (%Thing,%Env) -> %List %Thing

getProplist(x,E) ==
  cons? x => getProplist(first x,E)
  u:= search(x,E) => u
  --$InteractiveMode => nil
  --$InteractiveMode and (u:= search(x,$InteractiveFrame)) => u
  (pl:=search(x,$CategoryFrame)) =>
    pl
--  (pl:=PROPLIST x) => pl
-- Above line commented out JHD/BMT 2.Aug.90

search(x,e is [curEnv,:tailEnv]) ==
  searchCurrentEnv(x,curEnv) or searchTailEnv(x,tailEnv)

searchCurrentEnv(x,currentEnv) ==
  for contour in currentEnv repeat
    if u:= objectAssoc(x,contour) then return (signal:= u)
  KDR signal

searchTailEnv(x,e) ==
  for env in e repeat
    signal:=
      for contour in env repeat
        if (u := objectAssoc(x,contour)) and objectAssoc("FLUID",u) then
          return (signal:= u)
      if signal then return signal
  KDR signal

augProplist(proplist,prop,val) ==
  $InteractiveMode => augProplistInteractive(proplist,prop,val)
  while (proplist is [[ =prop,:.],:proplist']) repeat proplist:= proplist'
  val = (u := symbolTarget(prop,proplist)) => proplist
  null val =>
    null u => proplist
    DELLASOS(prop,proplist)
  [[prop,:val],:proplist]

augProplistOf(var,prop,val,e) ==
  proplist:= getProplist(var,e)
  semchkProplist(var,proplist,prop,val)
  augProplist(proplist,prop,val)

semchkProplist(x,proplist,prop,val) ==
  prop="isLiteral" =>
    symbolTarget("value",proplist) or symbolTarget("mode",proplist) =>
      warnLiteral x
  prop in '(mode value) =>
    symbolTarget("isLiteral",proplist) => warnLiteral x

addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) ==
  sameObject?(proplist,getProplist(var,e)) => e
  $InteractiveMode => addBindingInteractive(var,proplist,e)
  if curContour is [[ =var,:.],:.] then curContour:= rest curContour
                 --Previous line should save some space
  [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist]

addBindingInteractive(var,proplist,e is [[curContour,:.],:.]) ==
  -- change proplist of var in e destructively
  u := objectAssoc(var,curContour) =>
    u.rest := proplist
    e
  first(e).first := [[var,:proplist],:curContour]
  e

augProplistInteractive(proplist,prop,val) ==
  u := objectAssoc(prop,proplist) =>
    u.rest := val
    proplist
  [[prop,:val],:proplist]

position(x,l) ==
  posn(x,l,0) where
    posn(x,l,n) ==
      null l => -1
      x=first l => n
      posn(x,rest l,n+1)

insert(x,y) ==
  member(x,y) => y
  [x,:y]

after(u,v) ==
  r:= u
  for x in u for y in v repeat r:= rest r
  r


$blank == char " "

trimString s ==
  leftTrim rightTrim s

leftTrim s ==
  k := maxIndex s
  k < 0 => s
  stringChar(s,0) = $blank =>
    for i in 0..k while stringChar(s,i) = $blank repeat (j := i)
    subString(s,j + 1)
  s

rightTrim s ==  -- assumed a non-empty string
  k := maxIndex s
  k < 0 => s
  stringChar(s,k) = $blank =>
    for i in k..0 by -1 while stringChar(s,i) = $blank repeat (j := i)
    subString(s,0,j)
  s

pp x ==
  PRETTYPRINT x
  x

pr x ==
  F_,PRINT_-ONE x
  nil

intern x ==
  string? x =>
    digit? stringChar(x,0) => string2Integer x
    makeSymbol x
  x

-- variables used by browser

$htHash      := makeTable function scalarEq?
$glossHash   := makeTable function scalarEq?
$lispHash    := makeTable function scalarEq?
$sysHash     := makeTable function scalarEq?
$htSystemCommands := '(
 (boot . development) clear display (fin . development) edit help
 frame history load quit read set show synonym system
 trace what )
$currentSysList := [opOf x for x in $htSystemCommands] --see ht-root
$outStream   := nil
$recheckingFlag    := false     --see transformAndRecheckComments
$exposeFlag        := false     --if true, messages go to $outStream
$exposeFlagHeading := false     --see htcheck.boot
$checkingXmptex? := false       --see htcheck.boot
$exposeDocHeading:= nil         --see htcheck.boot
$charPlus == char "+"
$charBlank == char " "
$charLbrace == char "{"
$charRbrace == char "}"
$charBack == char "\"
$charDash == char "-"

$charTab            == abstractChar 9
$charNewline        == abstractChar 10
$charFauxNewline    == abstractChar 25
$stringNewline      == charString abstractChar 10
$stringFauxNewline  == charString abstractChar 25

$charExclusions == [char "a", char "A"]
$charQuote == char "'"
$charSemiColon == char ";"
$charComma     == char ","
$charPeriod    == char "."
$charEscapeList:= [char "%",char "#",$charBack]
$charIdentifierEndings := [char "__", char "!", char "?"]
$charSplitList := [$charComma,$charPeriod,char "[", char "]",$charLbrace, $charRbrace, char "(", char ")", char "$", char "%"]
$charDelimiters := [$charBlank, char "(", char ")", $charBack]
$HTspadmacros := '("\spadtype" "\spadcommand" "\spadop" "\spadfun" "\spadatt" "\spadsyscom" "\spad" "\s")
$HTmacs := [
  ['"\beginmenu",$charRbrace,'"menu",$charLbrace,'"\begin"],
   ['"\endmenu",$charRbrace,'"menu",$charLbrace,'"\end"],
     ['"\beginitems",$charRbrace,'"items",$charLbrace,'"\begin"],
       ['"\enditems",$charRbrace,'"items",$charLbrace,'"\end"],
         ['"\beginscroll",$charRbrace,'"scroll",$charLbrace,'"\begin"],
           ['"\endscroll",$charRbrace,'"scroll",$charLbrace,'"\end"]]

$HTlinks := '(
  "\downlink"
  "\menulink"
  "\menudownlink"
  "\menuwindowlink"
  "\menumemolink")

$HTlisplinks := '(
  "\lispdownlink"
  "\menulispdownlink"
  "\menulispwindowlink"
  "\menulispmemolink"
  "\lispwindowlink"
  "\lispmemolink")

$beginEndList := '(
  "page"
  "items"
  "menu"
  "scroll"
  "verbatim"
  "detail")

isDefaultPackageName x ==
  s := symbolName x
  stringChar(s,maxIndex s) = char "&"

defaultPackageForm? x ==
  x is [op,:.] and ident? op and isDefaultPackageName op

makeDefaultPackageName x ==
  makeSymbol strconc(x,'"&")

normalizeName: %Symbol -> %Symbol
normalizeName x ==
  x = "T" => "T$" -- rename T in spad code to avoid clash with Lisp
  x = "^" => "**" -- always use `**' internally for exponentiation
  x

++ Return the internal exported name of a potential operator `x'.
internalName x ==
  ident? x => normalizeName x
  not integer? x or x < 0 => x
  x = 0 => 'Zero
  x = 1 => 'One
  makeSymbol toString x

++ Return the external exported name of th potential operator `x'.
externalName: %Symbol -> %Symbol
externalName x ==
  x is 'Zero => "0"
  x is 'One => "1"
  x

-- gensym utils

charDigitVal c ==
  digits := '"0123456789"
  n := -1
  for i in 0..maxIndex digits while n < 0 repeat
      if c = stringChar(digits,i) then n := i
  n < 0 => error '"Character is not a digit"
  n

gensymInt g ==
  not gensym? g => error '"Need a GENSYM"
  p := symbolName g
  n := 0
  for i in 2..maxIndex p repeat
    n := 10 * n + charDigitVal stringChar(p,i)
  n

++ Return true if var is a query variable, e.g. any identifier
++ that starts with a question mark.
queryVar? var ==
  s := symbolName var
  #s > 1 and stringChar(s,0) = char "?" and digit? stringChar(s,1)

++ Returns a newly allocated domain shell (a simple vector) of length `n'.
newShell: %Short -> SIMPLE_-ARRAY
newShell n ==
  newVector(n,initial_-element <- nil)

-- Push into the BOOT package when invoked in batch mode.
AxiomCore::$sysScope := '"BOOT"